From c6b45ec6b10673e315aa59f466e125fac615cf30 Mon Sep 17 00:00:00 2001 From: Stephen Adams Date: Tue, 25 Oct 1994 01:46:13 +0000 Subject: [PATCH] Changes to merge with Win32 edwin screen driver and support. The main change is the addition of a new Edwin screen device for Win32. The new device implements special keys and mouse buttons. A certain degree of reorganization has been done to make the X and Win32 versions as similar as possible. Some things that used to be called X-MUMBLE are now just called MUMBLE (e.g BUTTON1-UP, MOUSE-SET-POINT). New files: win32.scm: New screen device win32com.scm: Win32 specific commands key-w32.scm, key-x11.scm: System specific handling of special keys (arrows etc). These files replace key.scm mousecom.scm: mouse commands, edited from xcom.scm Notable changes: calias.scm: much of the old key.scm was moved here. Now the keys `f1', `up' etc are available in all Edwins, even if the keyboard cannot generate them. (I have a prototype fix for the console screen driver too). debug.scm, modefs.scm, xmodef.scm: renamed and/or reorganized bindings xcom.scm: A whole lot of this moved to mousecom.scm --- v7/src/edwin/calias.scm | 76 +++++++++++++++-- v7/src/edwin/debug.scm | 24 ++---- v7/src/edwin/decls.scm | 8 +- v7/src/edwin/ed-ffi.scm | 8 +- v7/src/edwin/edwin.ldr | 81 ++++++++++++++++-- v7/src/edwin/edwin.pkg | 85 +++++++++---------- v7/src/edwin/modefs.scm | 41 +++++++++- v7/src/edwin/xcom.scm | 177 ++++++++++++++++++++++------------------ v7/src/edwin/xmodef.scm | 34 +------- 9 files changed, 346 insertions(+), 188 deletions(-) diff --git a/v7/src/edwin/calias.scm b/v7/src/edwin/calias.scm index 7e3c45810..db38639b1 100644 --- a/v7/src/edwin/calias.scm +++ b/v7/src/edwin/calias.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/calias.scm,v 1.14 1992/10/20 20:03:03 jinx Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/calias.scm,v 1.15 1994/10/25 01:46:12 adams Exp $ ;;; ;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology ;;; @@ -223,8 +223,14 @@ ;;;; Special keys (room for system-dependent extension) -(define-structure (special-key (constructor %make-special-key) - (conc-name special-key/)) +(define-structure + (special-key (constructor %make-special-key) + (conc-name special-key/) + (print-procedure + (standard-unparser-method 'SPECIAL-KEY + (lambda (key port) + (write-char #\space port) + (write-string (special-key/name key) port))))) (symbol false read-only true) (bucky-bits false read-only true)) @@ -249,7 +255,67 @@ (fix:lsh bit -1) (string-append (vector-ref bucky-bit-map n) name))))))) -(define hook/make-special-key %make-special-key) + +(define hashed-keys) + +(define (intern-special-key name bucky-bits) + (let ((name-entry (assq name (cdr hashed-keys)))) + (if name-entry + (let ((bits-entry (assq bucky-bits (cdr name-entry)))) + (if bits-entry + (cdr bits-entry) + (let ((new-key (%make-special-key name bucky-bits))) + (set-cdr! name-entry + (cons (cons bucky-bits new-key) + (cdr name-entry))) + new-key))) + (let ((new-key (%make-special-key name bucky-bits))) + (set-cdr! hashed-keys + (cons (cons name (list (cons bucky-bits new-key))) + (cdr hashed-keys))) + new-key)))) + + +(define hook/make-special-key intern-special-key) (define (make-special-key name bits) - (hook/make-special-key name bits)) \ No newline at end of file + (hook/make-special-key name bits)) + + +;; Predefined special keys + +(set! hashed-keys (list 'hashed-keys)) + +(let-syntax ((make-key + (macro (name) + `(define ,name (intern-special-key ',name 0))))) + (make-key backspace) + (make-key stop) + (make-key f1) + (make-key f2) + (make-key f3) + (make-key f4) + (make-key menu) + (make-key system) + (make-key user) + (make-key f5) + (make-key f6) + (make-key f7) + (make-key f8) + (make-key f9) + (make-key f10) + (make-key f11) + (make-key f12) + (make-key insertline) + (make-key deleteline) + (make-key insertchar) + (make-key deletechar) + (make-key home) + (make-key prior) + (make-key next) + (make-key up) + (make-key down) + (make-key left) + (make-key right) + (make-key select) + (make-key print)) \ No newline at end of file diff --git a/v7/src/edwin/debug.scm b/v7/src/edwin/debug.scm index 0ec3e8ca1..48049202e 100644 --- a/v7/src/edwin/debug.scm +++ b/v7/src/edwin/debug.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: debug.scm,v 1.31 1994/10/12 01:42:43 cph Exp $ +;;; $Id: debug.scm,v 1.32 1994/10/25 01:46:12 adams Exp $ ;;; ;;; Copyright (c) 1992-94 Massachusetts Institute of Technology ;;; @@ -230,7 +230,7 @@ "Select a bline when mouse clicked there." () (lambda () - ((ref-command x-mouse-set-point)) + ((ref-command mouse-set-point)) (let ((bline (mark->bline (current-point)))) (if bline (select-bline bline))))) @@ -1223,13 +1223,9 @@ one of these buffers, simply rename it using `M-x rename-buffer': once it has been renamed, it will not be deleted automatically.") (define-key 'continuation-browser #\p 'quit-with-restart-value) -(if (equal? microcode-id/operating-system-name "unix") - (begin - (define-key 'continuation-browser down 'browser-next-line) - (define-key 'continuation-browser up 'browser-previous-line) - (define-key 'continuation-browser x-button1-down - 'debugger-mouse-select-bline))) - +(define-key 'continuation-browser down 'browser-next-line) +(define-key 'continuation-browser up 'browser-previous-line) +(define-key 'continuation-browser button1-down 'debugger-mouse-select-bline) (define-key 'continuation-browser #\c-n 'browser-next-line) (define-key 'continuation-browser #\c-p 'browser-previous-line) (define-key 'continuation-browser #\? 'describe-mode) @@ -1596,13 +1592,9 @@ to keep one of these buffers, simply rename it using `M-x rename-buffer': once it has been renamed, it will not be deleted automatically.") -(if (equal? microcode-id/operating-system-name "unix") - (begin - (define-key 'environment-browser down 'browser-next-line) - (define-key 'environment-browser up 'browser-previous-line) - (define-key 'environment-browser x-button1-down - 'debugger-mouse-select-bline))) - +(define-key 'environment-browser down 'browser-next-line) +(define-key 'environment-browser up 'browser-previous-line) +(define-key 'environment-browser button1-down 'debugger-mouse-select-bline) (define-key 'environment-browser #\c-n 'browser-next-line) (define-key 'environment-browser #\c-p 'browser-previous-line) (define-key 'environment-browser #\? 'describe-mode) diff --git a/v7/src/edwin/decls.scm b/v7/src/edwin/decls.scm index 0c04355c6..a4879b8bf 100644 --- a/v7/src/edwin/decls.scm +++ b/v7/src/edwin/decls.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: decls.scm,v 1.51 1994/10/12 00:31:13 cph Exp $ +$Id: decls.scm,v 1.52 1994/10/25 01:46:12 adams Exp $ Copyright (c) 1989-94 Massachusetts Institute of Technology @@ -86,7 +86,8 @@ MIT in each case. |# "clscon" "clsmac" "display" - "key" + "key-w32" + "key-x11" "macros" "make" "nvector" @@ -99,6 +100,7 @@ MIT in each case. |# "strtab" "termcap" "utils" + "win32" "winren" "xform" "xterm")) @@ -170,6 +172,7 @@ MIT in each case. |# "modlin" "motcom" "motion" + "mousecom" "notify" "outline" "occur" @@ -210,6 +213,7 @@ MIT in each case. |# "wincom" "winout" "xcom" + "win32com" "xmodef"))) (for-each sf-class '("comwin" diff --git a/v7/src/edwin/ed-ffi.scm b/v7/src/edwin/ed-ffi.scm index f5a2758a8..38ca675de 100644 --- a/v7/src/edwin/ed-ffi.scm +++ b/v7/src/edwin/ed-ffi.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: ed-ffi.scm,v 1.34 1994/10/12 00:30:59 cph Exp $ +$Id: ed-ffi.scm,v 1.35 1994/10/25 01:46:12 adams Exp $ Copyright (c) 1990-94 Massachusetts Institute of Technology @@ -149,7 +149,9 @@ of that license should have been included along with this file. edwin-syntax-table) ("iserch" (edwin incremental-search) edwin-syntax-table) - ("key" (edwin keys) + ("key-w32" (edwin win32-keys) + edwin-syntax-table) + ("key-x11" (edwin x-keys) edwin-syntax-table) ("keymap" (edwin command-summary) edwin-syntax-table) @@ -285,6 +287,8 @@ of that license should have been included along with this file. syntax-table/system-internal) ("utlwin" (edwin window) class-syntax-table) + ("win32" (edwin screen win32) + edwin-syntax-table) ("vc" (edwin vc) edwin-syntax-table) ("wincom" (edwin) diff --git a/v7/src/edwin/edwin.ldr b/v7/src/edwin/edwin.ldr index fa742b035..3a06c81c1 100644 --- a/v7/src/edwin/edwin.ldr +++ b/v7/src/edwin/edwin.ldr @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.ldr,v 1.49 1994/10/08 08:57:28 cph Exp $ +$Id: edwin.ldr,v 1.50 1994/10/25 01:46:12 adams Exp $ Copyright (c) 1989-94 Massachusetts Institute of Technology @@ -131,10 +131,17 @@ MIT in each case. |# (load "buffrm" environment) (load "edtfrm" environment)) (load "calias" environment) - (load-set-and-initialize! '("xterm") - (->environment '(EDWIN SCREEN X-SCREEN))) - (load-set-and-initialize! '("key") - (->environment '(EDWIN KEYS))) + (case (lookup 'os-type) + ((NT) + (load-set-and-initialize! '("win32") + (->environment '(EDWIN SCREEN WIN32))) + (load-set-and-initialize! '("key-w32") + (->environment '(EDWIN WIN32-KEYS)))) + ((UNIX) + (load-set-and-initialize! '("xterm") + (->environment '(EDWIN SCREEN X-SCREEN))) + (load-set-and-initialize! '("key-x11") + (->environment '(EDWIN X-KEYS))))) (let ((env (->environment '(EDWIN SCREEN CONSOLE-SCREEN)))) (load-set-and-initialize! '("termcap" "tterm") env) @@ -186,8 +193,70 @@ MIT in each case. |# (load "compile" environment) (load "dabbrev" environment) + (load "mousecom" environment) (load "xcom" (->environment '(EDWIN X-COMMANDS))) - ;; debug depends on x-button1-down defined in xcom + (if (memq (lookup 'os-type) '(NT)) + (load-set-and-initialize! '("key-w32") + (->environment '(EDWIN WIN32-KEYS)))) + (if (memq (lookup 'os-type) '(UNIX)) + (load-set-and-initialize! '("key-x11") + (->environment '(EDWIN X-KEYS)))) + + + (let ((env (->environment '(EDWIN SCREEN CONSOLE-SCREEN)))) + (load-set-and-initialize! '("termcap" "tterm") env) + (if (memq (lookup 'os-type) '(dos nt)) + (begin + (load "ansi" env) + (if (load "bios" env) + ((access bios-initialize-package! env)))))) + + (load "edtstr" environment) + (load "editor" environment) + (load "curren" environment) + (load "simple" environment) + (load "debuge" environment) + (load "modlin" (->environment '(EDWIN MODELINE-STRING))) + (load "input" (->environment '(EDWIN KEYBOARD))) + (load "prompt" (->environment '(EDWIN PROMPT))) + (load "comred" (->environment '(EDWIN COMMAND-READER))) + (load "bufinp" (->environment '(EDWIN BUFFER-INPUT-PORT))) + (load "bufout" (->environment '(EDWIN BUFFER-OUTPUT-PORT))) + (load "winout" (->environment '(EDWIN WINDOW-OUTPUT-PORT))) + (load "things" environment) + (load "tparse" environment) + (load "syntax" environment) + (load "regexp" (->environment '(EDWIN REGULAR-EXPRESSION))) + (load "rgxcmp" (->environment '(EDWIN REGULAR-EXPRESSION-COMPILER))) + (load "linden" (->environment '(EDWIN LISP-INDENTATION))) + + (load-case 'os-type '((unix . "unix") (dos . "dos") (nt . "dos")) + environment) + + (load "fileio" environment) + + (load-case 'os-type '((unix . "process") + (dos . "dosproc") + (nt . "dosproc")) + (->environment '(EDWIN PROCESS))) + + (load "argred" (->environment '(EDWIN COMMAND-ARGUMENT))) + (load "autold" environment) + (load "autosv" environment) + (load "basic" environment) + (load "bufcom" environment) + (load "bufmnu" (->environment '(EDWIN BUFFER-MENU))) + (load "c-mode" environment) + (load "cinden" (->environment '(EDWIN C-INDENTATION))) + (load "comhst" environment) + (load "comint" environment) + (load "compile" environment) + (load "dabbrev" environment) + + (load "mousecom" environment) + (load "xcom" (->environment '(EDWIN X-COMMANDS))) + (load "win32com" (->environment '(EDWIN WIN-COMMANDS))) + ;; debug depends on button1-down defined in mousecom (load "debug" (->environment '(EDWIN DEBUGGER))) (let ((env (->environment '(EDWIN DIRED)))) diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index ee0d8b7aa..7dc299f05 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.pkg,v 1.153 1994/10/13 04:02:54 cph Exp $ +$Id: edwin.pkg,v 1.154 1994/10/25 01:46:12 adams Exp $ Copyright (c) 1989-1994 Massachusetts Institute of Technology @@ -36,6 +36,10 @@ MIT in each case. |# (global-definitions "../runtime/runtime") +#| Only for Win32: +(global-definitions "../win32/win32") +|# + (define-package (edwin) (file-case os-type ((unix) "unix") @@ -104,6 +108,8 @@ MIT in each case. |# "outline" ; outline minor mode "sort" + "mousecom" ; mouse commands + ;; These are only available under Unix/X "comint" ; command interpreter process stuff @@ -1011,19 +1017,37 @@ MIT in each case. |# xterm-screen/set-name) (initialization (initialize-package!))) +#| PC only: +(define-package (edwin screen win32) + (files "win32") + (parent (edwin screen)) + (import (win32) + destroy-window + get-handle + message-beep + send-message + set-window-text + sleep + ) + (initialization (initialize-package!))) + +(define-package (edwin win32-keys) + (files "key-w32") + (parent (edwin)) + (export (edwin screen win32) + win32-make-special-key) + (export (edwin) + end ; the END key + ) + (initialization (initialize-package!))) +|# + (define-package (edwin x-commands) (files "xcom") (parent (edwin)) (export (edwin) edwin-command$x-auto-raise-mode edwin-command$x-lower-screen - edwin-command$x-mouse-ignore - edwin-command$x-mouse-keep-one-window - edwin-command$x-mouse-select - edwin-command$x-mouse-select-and-split - edwin-command$x-mouse-set-mark - edwin-command$x-mouse-set-point - edwin-command$x-mouse-show-event edwin-command$x-raise-screen edwin-command$x-set-background-color edwin-command$x-set-border-color @@ -1054,44 +1078,23 @@ MIT in each case. |# x-button5-up) (export (edwin screen x-screen) update-xterm-screen-names!)) + + +(define-package (edwin win-commands) + (files "win32com") + (parent (edwin)) + (export (edwin) + )) + -(define-package (edwin keys) - (files "key") +(define-package (edwin x-keys) + (files "key-x11") (parent (edwin)) (export (edwin screen x-screen) x-make-special-key) - (export (edwin) - stop - f1 - f2 - f3 - f4 - menu - system - user - f5 - f6 - f7 - f8 - f9 - f10 - f11 - f12 - insertline - deleteline - insertchar - deletechar - home - prior - next - up - down - left - right - select - print) (initialization (initialize-package!))) - + + (define-package (edwin vc) (files "vc") (parent (edwin)) diff --git a/v7/src/edwin/modefs.scm b/v7/src/edwin/modefs.scm index f0f5eee94..d2ec07197 100644 --- a/v7/src/edwin/modefs.scm +++ b/v7/src/edwin/modefs.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: modefs.scm,v 1.147 1994/03/16 23:39:59 cph Exp $ +;;; $Id: modefs.scm,v 1.148 1994/10/25 01:46:12 adams Exp $ ;;; ;;; Copyright (c) 1985, 1989-94 Massachusetts Institute of Technology ;;; @@ -86,6 +86,7 @@ Like Fundamental mode, but no self-inserting characters.") (define-key 'read-only-noarg char-set:graphic 'undefined) (define-key 'read-only-noarg '(#\c-x #\c-q) 'no-toggle-read-only) +(define-key 'fundamental #\c-space 'set-mark-command) (define-key 'fundamental #\c-% 'replace-string) (define-key 'fundamental #\c-- 'negative-argument) (define-key 'fundamental #\c-0 'digit-argument) @@ -178,7 +179,8 @@ Like Fundamental mode, but no self-inserting characters.") (define-key 'fundamental #\m-m 'back-to-indentation) (define-key 'fundamental #\m-q 'fill-paragraph) (define-key 'fundamental #\m-r 'move-to-window-line) -;; This should only be bound in NT/Windows: +;; This should only be bound in NT/Windows, and only when running with +;; I/O through the scheme window as a terminal (rather than a proper screen). (define-key 'fundamental #\m-S 'resize-screen) (define-key 'fundamental #\m-t 'transpose-words) (define-key 'fundamental #\m-u 'upcase-word) @@ -323,4 +325,37 @@ Like Fundamental mode, but no self-inserting characters.") (define-key 'fundamental '(#\c-x #\z) 'suspend-edwin) (define-key 'fundamental '(#\c-x #\{) 'shrink-window-horizontally) (define-key 'fundamental '(#\c-x #\}) 'enlarge-window-horizontally) -(define-key 'fundamental '(#\c-x #\rubout) 'backward-kill-sentence) \ No newline at end of file +(define-key 'fundamental '(#\c-x #\rubout) 'backward-kill-sentence) + + +;; Additional bindings to `standard' special keys + +(define-key 'fundamental left 'backward-char) +(define-key 'fundamental (make-special-key 'left 1) 'backward-word) +(define-key 'fundamental deletechar 'delete-char) +(define-key 'fundamental right 'forward-char) +(define-key 'fundamental (make-special-key 'right 1) 'forward-word) +(define-key 'fundamental deleteline 'kill-line) +(define-key 'fundamental down 'next-line) +(define-key 'fundamental insertline 'open-line) +(define-key 'fundamental up 'previous-line) +(define-key 'fundamental home 'home-cursor) +(define-key 'fundamental next 'scroll-up) +(define-key 'fundamental prior 'scroll-down) +(define-key 'fundamental (make-special-key 'next 1) 'scroll-other-window) +(define-key 'fundamental (make-special-key 'prior 1) 'scroll-other-window-down) + +;;; Jokes + +(define-key 'fundamental #\h-space 'hyper-space) +(define-key 'fundamental (make-special-key 'malesymbol 4) 'super-man) +(define-key 'fundamental (make-special-key 'menu 4) 'super-menu) +(define-key 'fundamental #\t-$ 'top-dollar) +(define-key 'fundamental #\t-^ 'top-hat) + +(define-key 'fundamental button1-down 'mouse-set-point) +(define-key 'fundamental button1-up 'mouse-ignore) +(define-key 'fundamental button2-up 'mouse-ignore) +(define-key 'fundamental button3-up 'mouse-ignore) +(define-key 'fundamental button4-up 'mouse-ignore) +(define-key 'fundamental button5-up 'mouse-ignore) diff --git a/v7/src/edwin/xcom.scm b/v7/src/edwin/xcom.scm index 3b5a226c4..737455a20 100644 --- a/v7/src/edwin/xcom.scm +++ b/v7/src/edwin/xcom.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: xcom.scm,v 1.10 1992/11/20 19:10:04 cph Exp $ +;;; $Id: xcom.scm,v 1.11 1994/10/25 01:46:12 adams Exp $ ;;; -;;; Copyright (c) 1989-92 Massachusetts Institute of Technology +;;; Copyright (c) 1989-94 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -154,7 +154,7 @@ Useful only if `x-screen-icon-name-format' is false." (typein-edit-other-window) (screen-selected-window screen)))) (let ((buffer (window-buffer window)) - (update-name + (update-name (lambda (set-name format length) (if format (set-name @@ -312,81 +312,98 @@ When called interactively, completion is available on the input." "ur-angle" "watch" "xterm")) - -;;;; Mouse Commands - -(define-command x-mouse-select - "Select window the mouse is on." - () - (lambda () - (select-window (button-event/window (current-button-event))))) - -(define-command x-mouse-keep-one-window - "Select window mouse is on, then kill all other windows." - () - (lambda () - ((ref-command x-mouse-select)) - ((ref-command delete-other-windows)))) - -(define-command x-mouse-select-and-split - "Select window mouse is on, then split it vertically in half." - () - (lambda () - ((ref-command x-mouse-select)) - ((ref-command split-window-vertically) false))) -(define-command x-mouse-set-point - "Select window mouse is on, and move point to mouse position." - () - (lambda () - (let ((button-event (current-button-event))) - (let ((window (button-event/window button-event))) - (select-window window) - (set-current-point! - (or (window-coordinates->mark window - (button-event/x button-event) - (button-event/y button-event)) - (buffer-end (window-buffer window)))))))) - -(define-command x-mouse-set-mark - "Select window mouse is on, and set mark at mouse position. -Display cursor at that position for a second." - () - (lambda () - (let ((button-event (current-button-event))) - (let ((window (button-event/window button-event))) - (select-window window) - (let ((mark - (or (window-coordinates->mark window - (button-event/x button-event) - (button-event/y button-event)) - (buffer-end (window-buffer window))))) - (push-current-mark! mark) - (mark-flash mark)))))) - -(define-command x-mouse-show-event - "Show the mouse position in the minibuffer." - () - (lambda () - (let ((button-event (current-button-event))) - (message "window: " (button-event/window button-event) - " x: " (button-event/x button-event) - " y: " (button-event/y button-event))))) - -(define-command x-mouse-ignore - "Don't do anything." - () - (lambda () unspecific)) - -(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 x-button1-down 'x-mouse-set-point) \ No newline at end of file + +;;;;;; Mouse Commands +;; +;; Now taken care of in mousecom.scm +;; +;;(define-command x-mouse-select +;; "Select window the mouse is on." +;; () +;; (lambda () +;; (select-window (button-event/window (current-button-event))))) +;; +;;(define-command x-mouse-keep-one-window +;; "Select window mouse is on, then kill all other windows." +;; () +;; (lambda () +;; ((ref-command x-mouse-select)) +;; ((ref-command delete-other-windows)))) +;; +;;(define-command x-mouse-select-and-split +;; "Select window mouse is on, then split it vertically in half." +;; () +;; (lambda () +;; ((ref-command x-mouse-select)) +;; ((ref-command split-window-vertically) false))) +;; +;;(define-command x-mouse-set-point +;; "Select window mouse is on, and move point to mouse position." +;; () +;; (lambda () +;; (let ((button-event (current-button-event))) +;; (let ((window (button-event/window button-event))) +;; (select-window window) +;; (set-current-point! +;; (or (window-coordinates->mark window +;; (button-event/x button-event) +;; (button-event/y button-event)) +;; (buffer-end (window-buffer window)))))))) +;; +;;(define-command x-mouse-set-mark +;; "Select window mouse is on, and set mark at mouse position. +;;Display cursor at that position for a second." +;; () +;; (lambda () +;; (let ((button-event (current-button-event))) +;; (let ((window (button-event/window button-event))) +;; (select-window window) +;; (let ((mark +;; (or (window-coordinates->mark window +;; (button-event/x button-event) +;; (button-event/y button-event)) +;; (buffer-end (window-buffer window))))) +;; (push-current-mark! mark) +;; (mark-flash mark)))))) +;; +;;(define-command x-mouse-show-event +;; "Show the mouse position in the minibuffer." +;; () +;; (lambda () +;; (let ((button-event (current-button-event))) +;; (message "window: " (button-event/window button-event) +;; " x: " (button-event/x button-event) +;; " y: " (button-event/y button-event))))) +;; +;;(define-command x-mouse-ignore +;; "Don't do anything." +;; () +;; (lambda () unspecific)) +;; +;;(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 x-button1-down 'x-mouse-set-point) + + +;; X compatibility + +(define x-button1-down button1-down) +(define x-button2-down button2-down) +(define x-button3-down button3-down) +(define x-button4-down button4-down) +(define x-button5-down button5-down) +(define x-button1-up button1-up) +(define x-button2-up button2-up) +(define x-button3-up button3-up) +(define x-button4-up button4-up) +(define x-button5-up button5-up) diff --git a/v7/src/edwin/xmodef.scm b/v7/src/edwin/xmodef.scm index dfc88fa1d..06c587b8c 100644 --- a/v7/src/edwin/xmodef.scm +++ b/v7/src/edwin/xmodef.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: xmodef.scm,v 1.1 1992/10/20 20:03:21 jinx Exp $ +;;; $Id: xmodef.scm,v 1.2 1994/10/25 01:46:12 adams Exp $ ;;; ;;; Copyright (c) 1985, 1989-92 Massachusetts Institute of Technology ;;; @@ -46,35 +46,3 @@ (declare (usual-integrations)) -(let-syntax ((define-function-key - (macro (mode key command) - (let ((token (if (pair? key) (car key) key))) - `(if (not (lexical-unreferenceable? (the-environment) - ',token)) - (define-key ,mode ,key ,command)))))) - - (define-function-key 'fundamental left 'backward-char) - (define-function-key 'fundamental deletechar 'delete-char) - (define-function-key 'fundamental right 'forward-char) - (define-function-key 'fundamental deleteline 'kill-line) - (define-function-key 'fundamental down 'next-line) - (define-function-key 'fundamental insertline 'open-line) - (define-function-key 'fundamental up 'previous-line) - (define-function-key 'fundamental next 'scroll-up) - (define-function-key 'fundamental home 'home-cursor) - (define-function-key 'fundamental prior 'scroll-down) - (define-function-key 'fundamental (make-special-key 'next 1) - 'scroll-other-window) - (define-function-key 'fundamental (make-special-key 'prior 1) - 'scroll-other-window-down) - -;;; Jokes - - (define-key 'fundamental #\h-space 'hyper-space) - (define-function-key 'fundamental (make-special-key 'malesymbol 4) - 'super-man) - (define-function-key 'fundamental (make-special-key 'menu 4) 'super-menu) - (define-key 'fundamental #\t-$ 'top-dollar) - (define-key 'fundamental #\t-^ 'top-hat) - -) ;; End of let-syntax \ No newline at end of file -- 2.25.1