;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufcom.scm,v 1.83 1989/08/09 13:16:45 cph Exp $
+;;; $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 $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(prompt-for-select-buffer "Switch to buffer")
(lambda (buffer)
(select-buffer (find-buffer buffer))))
+
+(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.")
+ (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))))
+
(define-command switch-to-buffer-other-window
"Select buffer in another window."
(prompt-for-select-buffer "Switch to buffer in other window")
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/curren.scm,v 1.86 1989/08/12 08:31:40 cph Exp $
+;;; $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 $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
+;;;; Editor frames
+
+(define (change-frame new-frame)
+ (set-editor-current-frame-window! current-editor new-frame))
+
+(define (create-new-frame #!optional buffer)
+ (without-interrupts
+ (lambda ()
+ (let* ((new-screen (make-editor-screen #f))
+ (new-frame
+ (make-editor-frame
+ new-screen
+ (if (default-object? buffer)
+ (current-buffer)
+ buffer)
+ (make-buffer " *Typein-0*"))))
+ (set-screen-window! new-screen new-frame)
+ (editor-add-screen! current-editor new-screen)
+ (editor-add-frame! current-editor new-frame)
+ (let ((hook (ref-variable select-buffer-hook)))
+ (if hook (hook buffer new-frame)))))))
+
+(define (delete-frame! frame)
+ (let ((screen (editor-frame-screen frame)))
+ (editor-delete-screen! current-editor screen)
+ (editor-delete-frame! current-editor frame)
+ (screen-discard! screen)))
+
+(define (delete-current-frame!) (delete-frame! (current-editor-frame)))
+\f
+;;;; Screens
+
+;; This version of change-screen was meant to be used in conjunction
+;; with the reader-continuation stuff in edtfrm.scm and input.scm. But
+;; since that stuff doesn't quite work I'm commenting out this
+;; version.
+#|
+(define (change-screen screen)
+ (let ((old-frame (current-editor-frame))
+ (my-frame (screen-window screen)))
+ (change-frame my-frame)
+ (set-editor-input-port! (current-editor-input-port))
+ (without-interrupts
+ (lambda ()
+ (change-local-bindings!
+ (window-buffer (editor-frame-selected-window old-frame))
+ (window-buffer (editor-frame-selected-window my-frame))
+ (lambda () unspecific))))
+ (update-screens! #t)
+ (change-reading my-frame old-frame)))
+|#
+
+(define (change-screen screen)
+ (let ((old-frame (current-editor-frame))
+ (my-frame (screen-window screen)))
+ (set-reader-do-before-next-read!
+ (lambda ()
+ (change-frame my-frame)
+ (set-editor-input-port! (current-editor-input-port))
+ (without-interrupts
+ (lambda ()
+ (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)))
+
+(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)))
+\f
;;;; Windows
(define-integrable (current-window)
(loop (cdr windows) new-buffer))))
(bufferset-kill-buffer! (current-bufferset) buffer))
\f
+(define-variable select-buffer-hook
+ "If not false, a procedure to call when a buffer is selected.
+The procedure is passed the new buffer and the window in which
+it is selected.
+The buffer is guaranteed to be selected at that time."
+ false)
+
(define-integrable (select-buffer buffer)
(set-window-buffer! (current-window) buffer true))
buffer
(lambda () (%set-window-buffer! window buffer)))
(if record? (bufferset-select-buffer! (current-bufferset) buffer)))
- (%set-window-buffer! window buffer)))))
+ (%set-window-buffer! window buffer))
+ (if (not (minibuffer? buffer))
+ (let ((hook (ref-variable select-buffer-hook)))
+ (if hook (hook buffer window)))))))
+
(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/decls.scm,v 1.10 1989/08/29 21:39:43 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/decls.scm,v 1.11 1990/08/31 20:11:55 markf Exp $
Copyright (c) 1989 Massachusetts Institute of Technology
"regexp"
"replaz"
"schmod"
+ "scrcom"
"sercom"
"struct"
"syntax"
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.193 1990/06/20 23:01:51 cph Exp $
+;;; $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 $
;;;
-;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(initialize-display-type!))
(set! edwin-editor
(let ((screen (apply make-editor-screen make-screen-args)))
- (make-editor "Edwin" screen (make-editor-input-port screen))))
+ (make-editor "Edwin" screen)))
(set! edwin-initialization
(lambda ()
(set! edwin-initialization false)
(lambda ()
(if edwin-editor
(begin
- (screen-discard! (editor-screen edwin-editor))
+ (for-each (lambda (screen)
+ (screen-discard! screen))
+ (editor-screens edwin-editor))
(set! edwin-editor false)
unspecific)))))
(define (within-editor?)
(not (unassigned? current-editor)))
+
+;;; There is a problem with recursive edits and multiple screens.
+;;; When you switch screens the recursive edit aborts. The problem
+;;; is that a top level ^G in a recursive edit aborts the recursive
+;;; edit and a ^G is signalled when you switch screens. I think that
+;;; ^G should not abort a recursive edit.
+
(define (enter-recursive-edit)
(let ((value
(call-with-current-continuation
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtfrm.scm,v 1.79 1989/08/11 11:50:30 cph Exp $
+;;; $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 $
;;;
;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
selected-window
cursor-window
select-time
- properties))
+ 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
+ ))
(define (make-editor-frame root-screen main-buffer typein-buffer)
(let ((window (make-object editor-frame)))
(set! redisplay-flags (list false))
(set! inferiors '())
(set! properties (make-1d-table))
+ (set! typein-bufferset (make-bufferset typein-buffer))
+ (set! input-port (make-editor-input-port root-screen))
+ (bufferset-guarantee-buffer! typein-bufferset typein-buffer)
(let ((main-window (make-buffer-frame window main-buffer true))
(typein-window (make-buffer-frame window typein-buffer false)))
(set! screen root-screen)
(set! select-time 2)
(set-window-select-time! main-window 1)
(=> (window-cursor main-window) :enable!))
- (set-editor-frame-size! window x-size y-size))
+ (set-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!)))))
+|#
+ )
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)
(with-instance-variables editor-frame window (display-style)
(with-screen-in-update! screen
(define-integrable (editor-frame-screen window)
(with-instance-variables editor-frame window ()
screen))
+
+(define-integrable (editor-frame-typein-bufferset window)
+ (with-instance-variables editor-frame window ()
+ typein-bufferset))
+
+(define-integrable (editor-frame-input-port window)
+ (with-instance-variables editor-frame window ()
+ input-port))
+
(define (editor-frame-windows window)
(cons (editor-frame-typein-window window)
(let ((start (editor-frame-window0 window)))
\f
(define-structure (editor (constructor %make-editor))
(name false read-only true)
- (screen false read-only true)
- (input-port false read-only true)
- (frame-window false read-only true)
+ (screens false)
+ (current-frame-window false)
(bufferset false read-only true)
(kill-ring false read-only true)
(char-history false read-only true)
- (button-event false))
+ (button-event false)
+ (frame-windows false))
-(define (make-editor name screen input-port)
+(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
- (bufferset-create-buffer bufferset
- " *Typein-0*"))))
+ (make-buffer " *Typein-0*"))))
(set-screen-window! screen frame)
(%make-editor name
- screen
- input-port
+ (list screen)
frame
bufferset
(make-ring 10)
(make-ring 100)
- false)))))
+ false
+ (list frame))))))
+
+(define (editor-add-screen! editor screen)
+ (if (not (memq 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-screen current-editor))
+ (editor-frame-screen (current-editor-frame)))
(define-integrable (all-screens)
- (list (current-screen)))
+ (editor-screens current-editor))
(define-integrable (current-editor-input-port)
- (editor-input-port current-editor))
+ (editor-frame-input-port (current-editor-frame)))
(define-integrable (current-editor-frame)
- (editor-frame-window current-editor))
+ (editor-current-frame-window current-editor))
(define-integrable (all-editor-frames)
- (list (current-editor-frame)))
+ (editor-frame-windows current-editor))
(define-integrable (all-windows)
- #|(append-map editor-frame-windows (all-editor-frames))|#
- (editor-frame-windows (current-editor-frame)))
+ (append-map editor-frame-windows (all-editor-frames)))
+
(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.7 1989/08/12 08:31:57 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.ldr,v 1.8 1990/08/31 20:17:56 markf Exp $
;;; program to load package contents
;;; **** This program (unlike most .ldr files) is not generated by a program.
(load "iserch" (->environment '(EDWIN INCREMENTAL-SEARCH)))
(load "texcom" environment)
(load "wincom" environment)
+ (load "scrcom" environment)
(load "xcom" (->environment '(EDWIN X-COMMANDS)))
(load "modefs" environment)
(load "rename" environment)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.14 1989/08/14 10:23:37 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.15 1990/08/31 20:18:01 markf Exp $
Copyright (c) 1989 Massachusetts Institute of Technology
"motcom" ; motion commands
"replaz" ; replace commands
"schmod" ; scheme mode
+ "scrcom" ; screen commands
"sercom" ; search commands
"texcom" ; text commands
"wincom" ; window commands
button3-up
button4-up
button5-up
- x-display-type)
+ x-display-type
+ x-display-type-name)
(export (edwin x-commands)
screen-xterm)
(initialization (initialize-package!)))
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
window-point-coordinates
window-point-x
window-point-y
+ window-root-window
window-redraw!
window-redraw-preserving-point!
window-scroll-y-absolute!
message-args->string
reset-command-prompt!
set-command-prompt!
+ set-editor-input-port!
+ set-reader-do-before-next-read!
temporary-message
with-editor-input-port))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.139 1989/08/12 08:32:08 cph Exp $
+;;; $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 $
;;;
;;; Copyright (c) 1986, 1989 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)
+ (create-new-frame (find-file-noselect filename true)))
+
(define (find-file-noselect filename warn?)
(let ((pathname (pathname->absolute-pathname (->pathname filename))))
(if (file-directory? pathname)
(let ((buffer* (new-buffer "*dummy*")))
(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)
\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/input.scm,v 1.81 1989/08/12 08:32:19 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/input.scm,v 1.82 1990/08/31 20:12:44 markf Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(if (not command-prompt-displayed?)
(clear-message!)))))
\f
+;; The reader-continuation is intended to be used to switch
+;; between reader loops for different editor frames. However,
+;; its interactions with typein and typeout don't quite work, so
+;; I'm commenting out the code that deals with this.
+;(define *reader-continuation* #f)
+
(define editor-input-port)
(define (with-editor-input-port new-port thunk)
(fluid-let ((editor-input-port new-port))
(thunk)))
+(define-integrable (set-editor-input-port! new-port)
+ (set! editor-input-port new-port))
+
(define-integrable (keyboard-active? delay)
(char-ready? editor-input-port delay))
(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
+ (remap-alias-char
+ (let loop ()
+ (before-reading-maybe-do-something)
+ (let ((char
+#| see comment for *reader-continuation*
+ (call-with-current-continuation
+ (lambda (continuation)
+ (fluid-let ((*reader-continuation* continuation))
+|#
+ (read-char editor-input-port)))
+#|
+ )))
+|#
+ (if (and char (not (eof-object? char)))
+ char
+ (loop))))))
+\f
+#| see comment for *reader-continuation*
+(define (switch-reader new-reader save-old-reader)
+ (if *reader-continuation*
+ (save-old-reader *reader-continuation*))
+ (if (within-typein-edit?)
+ (abort-current-command (lambda () (new-reader #f)))
+ (new-reader #f)))
+|#
+
+(define *reader-do-before-next-read* #f)
+
+(define (set-reader-do-before-next-read! to-do)
+ (set! *reader-do-before-next-read* to-do))
+
+(define (before-reading-maybe-do-something)
+ (if *reader-do-before-next-read*
+ (begin
+ (*reader-do-before-next-read*)
+ (set! *reader-do-before-next-read* #f))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/prompt.scm,v 1.136 1989/08/14 09:49:13 cph Exp $
+;;; $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 $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(let ((window (typein-window)))
(select-window window)
(select-buffer
- (find-or-create-buffer
+ (bufferset-find-or-create-buffer
+ (editor-frame-typein-bufferset (current-editor-frame))
(string-append " *Typein-"
(number->string typein-edit-depth)
"*")))
(lambda (new-string)
(let ((end (string-length new-string)))
(let ((index
- (substring-find-next-char-not-of-syntax
- new-string
- (string-length string)
- end
- #\w))) (if index
+ (and (string-prefix? string new-string)
+ (substring-find-next-char-not-of-syntax
+ new-string
+ (string-length string)
+ end
+ #\w))))
+ (if index
(substring new-string 0 (1+ index))
new-string))))))
(let ((if-unique
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/scrcom.scm,v 1.1 1990/08/31 20:12:53 markf Exp $
+;;;
+;;; Copyright (c) 1987, 1989 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+;;; NOTE: Parts of this program (Edwin) were created by translation
+;;; from corresponding parts of GNU Emacs. Users should be aware that
+;;; the GNU GENERAL PUBLIC LICENSE may apply to these parts. A copy
+;;; of that license should have been included along with this file.
+;;;
+
+;;;; Screen Commands
+
+(declare (usual-integrations))
+\f
+(define-command delete-screen
+ "Delete the screen that point is in. If this is the last screen,
+then a message is diplayed and the screen is not deleted."
+ ()
+ (lambda ()
+ (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
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xcom.scm,v 1.3 1989/08/12 08:32:52 cph Exp $
+;;; $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 $
;;;
;;; Copyright (c) 1989 Massachusetts Institute of Technology
;;;
(x-window-set-internal-border-width 2)
(xterm-x-size 1)
(xterm-y-size 1)
- (xterm-set-size 3))
+ (xterm-set-size 3)
+ (x-set-window-name 2)
+ (x-set-icon-name 2))
(define (current-xterm)
(screen-xterm (current-screen)))
"watch"
"xterm"))
\f
+(define-command x-set-window-name
+ "Set X window name to NAME."
+ "sSet X window name"
+ (lambda (name)
+ (x-set-window-name (current-xterm) name)))
+
+(define-command x-set-icon-name
+ "Set X window icon name to NAME."
+ "sSet X window icon name"
+ (lambda (name)
+ (x-set-icon-name (current-xterm) name)))
+\f
;;;; Mouse Commands
(define-command x-mouse-select
(define-key 'fundamental button4-up 'x-mouse-ignore)
(define-key 'fundamental button5-up 'x-mouse-ignore)
-(define-key 'fundamental button1-down 'x-mouse-set-point)
\ No newline at end of file
+(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
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.8 1989/08/12 08:32:56 cph Exp $
+;;; $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 $
;;;
;;; Copyright (c) 1989 Massachusetts Institute of Technology
;;;
(xterm-read-chars 2)
(xterm-button 1)
(xterm-pointer-x 1)
- (xterm-pointer-y 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))
(define-structure (xterm-screen-state
(constructor make-xterm-screen-state (xterm))
(highlight 0))
(define (make-xterm-screen #!optional geometry)
- (make-screen (make-xterm-screen-state
- (xterm-open-window (or (get-x-display)
+ (let* ((xterm (xterm-open-window (or (get-x-display)
(error "unable to open display"))
(and (not (default-object? geometry))
geometry)
false))
- 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!))
+ (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)
+ screen))
(define-integrable (screen-xterm screen)
(xterm-screen-state/xterm (screen-state screen)))
(define-integrable (screen-highlight screen)
(xterm-screen-state/highlight (screen-state screen)))
+
+(define xterm-screen-alist '())
+
+(define (add-to-xterm-screen-alist xterm screen)
+ (set! xterm-screen-alist (cons (cons xterm screen) xterm-screen-alist)))
+
+(define (xterm->screen xterm)
+ (let ((entry (assv xterm xterm-screen-alist)))
+ (and entry (cdr entry))))
\f
(define-integrable (set-screen-highlight! screen highlight)
(set-xterm-screen-state/highlight! (screen-state screen) highlight))
(define (xterm-screen/start-update! screen)
- (xterm-screen/process-events! screen))
+ screen ;ignored
+ unspecific)
(define (xterm-screen/finish-update! screen)
(x-window-flush (screen-xterm screen)))
unspecific)
(define (xterm-screen/enter! screen)
- screen ; ignored
+ (if (not (eq? screen (current-screen)))
+ (change-screen screen))
unspecific)
(define (xterm-screen/exit! screen)
\f
(define (refill-buffer! state index)
(let ((screen (xterm-input-port-state/screen state)))
- (let loop ()
- (let ((buffer (xterm-screen/read-chars screen false)))
- (if (not buffer)
- (loop)
- (begin
- (check-for-interrupts! state buffer index)
- (string-ref buffer 0)))))))
+ (let ((buffer (xterm-screen/read-chars screen #f)))
+ (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-screen/process-events! screen))
- (update-screen! screen false))
+ (xterm-process-events!))
+ (update-screens! false))
result))
(define (check-for-interrupts! state buffer index)
(if (and old-mask pending-interrupt?)
(signal-interrupt!))))))
\f
-(define (xterm-screen/process-events! screen)
- (let ((xterm (screen-xterm screen))
- (window (screen-window screen)))
- (and window
- (let ((handlers
- (vector-ref xterm-event-flags->handlers
- (x-window-read-event-flags! xterm))))
- (and (not (null? handlers))
- (begin
- (for-each (lambda (handler) (handler xterm window)) handlers)
- true))))))
-
-(define-integrable xterm-event-flag:resized 0)
-(define-integrable xterm-event-flag:button-down 1)
-(define-integrable xterm-event-flag:button-up 2)
-(define-integrable xterm-number-of-event-flags 3)
+
+;;; 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)
- (set! xterm-event-flags->handlers
- (binary-powerset-vector xterm-event-handlers))
unspecific)
-(define (binary-powerset-vector items)
- (let ((n-items (vector-length items)))
- (let ((table-length (expt 2 n-items)))
- (let ((table (make-vector table-length '())))
- (let loop ((i 1))
- (if (< i table-length)
- (begin
- (vector-set!
- table
- i
- (let loop ((i i) (index 0))
- (if (zero? i)
- '()
- (let ((qr (integer-divide i 2)))
- (let ((rest
- (loop (integer-divide-quotient qr)
- (1+ index))))
- (if (zero? (integer-divide-remainder qr))
- rest
- (cons (vector-ref items index) rest)))))))
- (loop (1+ i)))))
- table))))
+(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)))
-(define xterm-event-handlers
- (make-vector xterm-number-of-event-flags false))
-
-(define xterm-event-flags->handlers)
-
-(define-xterm-event-handler xterm-event-flag:resized
- (lambda (xterm window)
- (send window ':set-size!
- (xterm-x-size xterm)
- (xterm-y-size xterm))))
-
-(define-xterm-event-handler xterm-event-flag:button-down
- (lambda (xterm window)
- (send window ':button-event!
- (button-downify (xterm-button xterm))
- (xterm-pointer-x xterm)
- (xterm-pointer-y xterm))))
-
-(define-xterm-event-handler xterm-event-flag:button-up
- (lambda (xterm window)
- (send window ':button-event!
- (button-upify (xterm-button xterm))
- (xterm-pointer-x xterm)
- (xterm-pointer-y xterm))))
\f
(define button1-down)
(define button2-down)
(set! x-display-data false)
unspecific)
+(define x-display-type-name 'X)
+
(define (initialize-package!)
(set! x-display-type
- (make-display-type 'X
+ (make-display-type x-display-type-name
get-x-display
make-xterm-screen
make-xterm-input-port
(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
+ unspecific)
projects / mit-scheme.git / commitdiff