From f60ff90716b7851b814584ab640dff41ee0442c9 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Fri, 22 Jun 2018 03:14:45 -0700 Subject: [PATCH] Replace Edwin's X display type with the x11-screen plugin. --- src/edwin/decls.scm | 5 +- src/edwin/ed-ffi.scm | 3 - src/edwin/edwin.ldr | 5 +- src/edwin/edwin.pkg | 95 +-- src/edwin/key-x11.scm | 916 -------------------------- src/edwin/kilcom.scm | 12 + src/edwin/xcom.scm | 346 ---------- src/edwin/xmodef.scm | 30 - src/edwin/xterm.scm | 1452 +---------------------------------------- 9 files changed, 49 insertions(+), 2815 deletions(-) delete mode 100644 src/edwin/key-x11.scm delete mode 100644 src/edwin/xcom.scm delete mode 100644 src/edwin/xmodef.scm diff --git a/src/edwin/decls.scm b/src/edwin/decls.scm index 719527f3a..6f9183c60 100644 --- a/src/edwin/decls.scm +++ b/src/edwin/decls.scm @@ -83,7 +83,6 @@ USA. "comatch" "display" "key-w32" - "key-x11" "macros" "make" "nntp" @@ -229,10 +228,8 @@ USA. "webster" "wincom" "winout" - "xcom" "win32com" - "world-monitor" - "xmodef"))) + "world-monitor"))) (for-each sf-class '("comwin" "modwin" diff --git a/src/edwin/ed-ffi.scm b/src/edwin/ed-ffi.scm index f8a3b4842..9764c7df3 100644 --- a/src/edwin/ed-ffi.scm +++ b/src/edwin/ed-ffi.scm @@ -96,7 +96,6 @@ USA. ("iserch" (edwin incremental-search)) ("javamode" (edwin)) ("key-w32" (edwin win32-keys)) - ("key-x11" (edwin x-keys)) ("keymap" (edwin command-summary)) ("keyparse" (edwin keyparser)) ("kilcom" (edwin)) @@ -184,7 +183,5 @@ USA. ("wincom" (edwin)) ("window" (edwin window)) ("winout" (edwin window-output-port)) - ("xcom" (edwin x-commands)) ("xform" (edwin class-macros transform-instance-variables)) - ("xmodef" (edwin)) ("xterm" (edwin screen x-screen)))) \ No newline at end of file diff --git a/src/edwin/edwin.ldr b/src/edwin/edwin.ldr index 62beebb52..d3282eb4c 100644 --- a/src/edwin/edwin.ldr +++ b/src/edwin/edwin.ldr @@ -171,9 +171,7 @@ USA. (load-set-and-initialize! '("key-w32") (->environment '(edwin win32-keys)))) ((unix) - (load-set-and-initialize! '("xterm") - (->environment '(edwin screen x-screen))) - (load "key-x11" (->environment '(edwin x-keys))))) + (load "xterm" (->environment '(edwin screen x-screen))))) (load-case 'os-type '((unix . "process") @@ -183,7 +181,6 @@ USA. (load "mousecom" environment) (case (lookup 'os-type) - ((unix) (load "xcom" (->environment '(edwin x-commands)))) ((nt) (load "win32com" (->environment '(edwin win-commands))))) ;; debug depends on button1-down defined in mousecom (load "debug" (->environment '(edwin debugger))) diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg index e281b95c4..597e370e2 100644 --- a/src/edwin/edwin.pkg +++ b/src/edwin/edwin.pkg @@ -1153,7 +1153,6 @@ USA. "shell" ; shell subprocess commands "techinfo" ; techinfo commands "telnet" ; telnet subprocess commands - "xmodef" ; x bindings for fundamental mode "manual" ; man page display "print" ; printer output )) @@ -1172,98 +1171,8 @@ USA. (define-package (edwin screen x-screen) (files "xterm") (parent (edwin screen)) - (export (edwin) - edwin-variable$x-cut-to-clipboard - edwin-variable$x-paste-from-clipboard - os/interprogram-cut - os/interprogram-paste - x-root-window-size - x-screen-ignore-focus-button? - x-selection-timeout - xterm-screen/flush! - xterm-screen/grab-focus!) - (export (edwin x-commands) - screen-display - screen-xterm - xterm-screen/set-icon-name - xterm-screen/set-name) - (import (edwin keyboard) - keyboard-peek-busy-no-hang) - (import (edwin process) - register-process-output-events) - (initialization (initialize-package!))) - - (define-package (edwin x-keys) - (files "key-x11") - (parent (edwin)) - (export (edwin screen x-screen) - x-make-special-key)) - - (define-package (edwin x-commands) - (files "xcom") - (parent (edwin)) - (export (edwin) - edwin-command$lower-frame - edwin-command$raise-frame - edwin-command$set-background-color - edwin-command$set-border-color - edwin-command$set-border-width - edwin-command$set-cursor-color - edwin-command$set-default-font - edwin-command$set-font - edwin-command$set-foreground-color - edwin-command$set-frame-icon-name - edwin-command$set-frame-name - edwin-command$set-frame-position - edwin-command$set-frame-size - edwin-command$set-internal-border-width - edwin-command$set-mouse-color - edwin-command$set-mouse-shape - edwin-command$show-frame-position - edwin-command$show-frame-size - edwin-command$x-lower-screen - edwin-command$x-mouse-ignore - edwin-command$x-mouse-keep-one-window - edwin-command$x-mouse-select - edwin-command$x-mouse-select-and-split - edwin-command$x-mouse-set-mark - edwin-command$x-mouse-set-point - edwin-command$x-mouse-show-event - edwin-command$x-raise-screen - edwin-command$x-set-background-color - edwin-command$x-set-border-color - edwin-command$x-set-border-width - edwin-command$x-set-cursor-color - edwin-command$x-set-font - edwin-command$x-set-foreground-color - edwin-command$x-set-icon-name - edwin-command$x-set-internal-border-width - edwin-command$x-set-mouse-color - edwin-command$x-set-mouse-shape - edwin-command$x-set-position - edwin-command$x-set-size - edwin-command$x-set-window-name - edwin-variable$frame-icon-name-format - edwin-variable$frame-icon-name-length - edwin-variable$frame-name-format - edwin-variable$frame-name-length - edwin-variable$x-screen-icon-name-format - edwin-variable$x-screen-icon-name-length - edwin-variable$x-screen-name-format - edwin-variable$x-screen-name-length - x-button1-down - x-button1-up - x-button2-down - x-button2-up - x-button3-down - x-button3-up - x-button4-down - x-button4-up - x-button5-down - x-button5-up) - (export (edwin screen x-screen) - update-xterm-screen-names!))) - + (import (runtime ffi) + load-option-quietly))) ((nt) (global-definitions "../win32/win32") diff --git a/src/edwin/key-x11.scm b/src/edwin/key-x11.scm deleted file mode 100644 index 6324e147c..000000000 --- a/src/edwin/key-x11.scm +++ /dev/null @@ -1,916 +0,0 @@ -#| -*-Scheme-*- - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, - 2017, 2018 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -|# - -;;;; Keys -;;; Package: (edwin x-keys) - -(declare (usual-integrations)) - -(define (x-make-special-key keysym bucky-bits) - (make-special-key (or (keysym->name keysym) - (editor-error "Keysym not registered:" keysym)) - bucky-bits)) - -(define (keysym->name keysym) - (let ((entry - (vector-binary-search x-key-translation-table - (lambda (u v) (< u v)) - (lambda (pair) (car pair)) - keysym))) - (and entry (cdr entry)))) - -;; This table is a simple translation of /usr/include/X11/keysym.h. -;; However, that the vendor-specific marker (bit 28, numbered from 0) -;; has been moved to bit 23 so that all keysym values will fit in -;; Scheme fixnums, even with eight-bit type tags. Duplicate keysyms -;; have been pruned arbitrarily. - -(define x-key-translation-table - (vector - '(#x7B . braceleft) - '(#x7C . bar) - '(#x7D . braceright) - '(#x7E . asciitilde) - '(#xA0 . nobreakspace) - '(#xA1 . exclamdown) - '(#xA2 . cent) - '(#xA3 . sterling) - '(#xA4 . currency) - '(#xA5 . yen) - '(#xA6 . brokenbar) - '(#xA7 . section) - '(#xA8 . diaeresis) - '(#xA9 . copyright) - '(#xAA . ordfeminine) - '(#xAB . guillemotleft) - '(#xAC . notsign) - '(#xAD . hyphen) - '(#xAE . registered) - '(#xAF . macron) - '(#xB0 . degree) - '(#xB1 . plusminus) - '(#xB2 . twosuperior) - '(#xB3 . threesuperior) - '(#xB4 . acute) - '(#xB5 . mu) - '(#xB6 . paragraph) - '(#xB7 . periodcentered) - '(#xB8 . cedilla) - '(#xB9 . onesuperior) - '(#xBA . masculine) - '(#xBB . guillemotright) - '(#xBC . onequarter) - '(#xBD . onehalf) - '(#xBE . threequarters) - '(#xBF . questiondown) - '(#xC0 . Agrave) - '(#xC1 . Aacute) - '(#xC2 . Acircumflex) - '(#xC3 . Atilde) - '(#xC4 . Adiaeresis) - '(#xC5 . Aring) - '(#xC6 . AE) - '(#xC7 . Ccedilla) - '(#xC8 . Egrave) - '(#xC9 . Eacute) - '(#xCA . Ecircumflex) - '(#xCB . Ediaeresis) - '(#xCC . Igrave) - '(#xCD . Iacute) - '(#xCE . Icircumflex) - '(#xCF . Idiaeresis) - '(#xD0 . Eth) - '(#xD1 . Ntilde) - '(#xD2 . Ograve) - '(#xD3 . Oacute) - '(#xD4 . Ocircumflex) - '(#xD5 . Otilde) - '(#xD6 . Odiaeresis) - '(#xD7 . multiply) - '(#xD8 . Ooblique) - '(#xD9 . Ugrave) - '(#xDA . Uacute) - '(#xDB . Ucircumflex) - '(#xDC . Udiaeresis) - '(#xDD . Yacute) - '(#xDE . Thorn) - '(#xDF . ssharp) - '(#xE0 . agrave) - '(#xE1 . aacute) - '(#xE2 . acircumflex) - '(#xE3 . atilde) - '(#xE4 . adiaeresis) - '(#xE5 . aring) - '(#xE6 . ae) - '(#xE7 . ccedilla) - '(#xE8 . egrave) - '(#xE9 . eacute) - '(#xEA . ecircumflex) - '(#xEB . ediaeresis) - '(#xEC . igrave) - '(#xED . iacute) - '(#xEE . icircumflex) - '(#xEF . idiaeresis) - '(#xF0 . eth) - '(#xF1 . ntilde) - '(#xF2 . ograve) - '(#xF3 . oacute) - '(#xF4 . ocircumflex) - '(#xF5 . otilde) - '(#xF6 . odiaeresis) - '(#xF7 . division) - '(#xF8 . oslash) - '(#xF9 . ugrave) - '(#xFA . uacute) - '(#xFB . ucircumflex) - '(#xFC . udiaeresis) - '(#xFD . yacute) - '(#xFE . thorn) - '(#xFF . ydiaeresis) - '(#x1A1 . Aogonek) - '(#x1A2 . breve) - '(#x1A3 . Lstroke) - '(#x1A5 . Lcaron) - '(#x1A6 . Sacute) - '(#x1A9 . Scaron) - '(#x1AA . Scedilla) - '(#x1AB . Tcaron) - '(#x1AC . Zacute) - '(#x1AE . Zcaron) - '(#x1AF . Zabovedot) - '(#x1B1 . aogonek) - '(#x1B2 . ogonek) - '(#x1B3 . lstroke) - '(#x1B5 . lcaron) - '(#x1B6 . sacute) - '(#x1B7 . caron) - '(#x1B9 . scaron) - '(#x1BA . scedilla) - '(#x1BB . tcaron) - '(#x1BC . zacute) - '(#x1BD . doubleacute) - '(#x1BE . zcaron) - '(#x1BF . zabovedot) - '(#x1C0 . Racute) - '(#x1C3 . Abreve) - '(#x1C5 . Lacute) - '(#x1C6 . Cacute) - '(#x1C8 . Ccaron) - '(#x1CA . Eogonek) - '(#x1CC . Ecaron) - '(#x1CF . Dcaron) - '(#x1D0 . Dstroke) - '(#x1D1 . Nacute) - '(#x1D2 . Ncaron) - '(#x1D5 . Odoubleacute) - '(#x1D8 . Rcaron) - '(#x1D9 . Uring) - '(#x1DB . Udoubleacute) - '(#x1DE . Tcedilla) - '(#x1E0 . racute) - '(#x1E3 . abreve) - '(#x1E5 . lacute) - '(#x1E6 . cacute) - '(#x1E8 . ccaron) - '(#x1EA . eogonek) - '(#x1EC . ecaron) - '(#x1EF . dcaron) - '(#x1F0 . dstroke) - '(#x1F1 . nacute) - '(#x1F2 . ncaron) - '(#x1F5 . odoubleacute) - '(#x1F8 . rcaron) - '(#x1F9 . uring) - '(#x1FB . udoubleacute) - '(#x1FE . tcedilla) - '(#x1FF . abovedot) - '(#x2A1 . Hstroke) - '(#x2A6 . Hcircumflex) - '(#x2A9 . Iabovedot) - '(#x2AB . Gbreve) - '(#x2AC . Jcircumflex) - '(#x2B1 . hstroke) - '(#x2B6 . hcircumflex) - '(#x2B9 . idotless) - '(#x2BB . gbreve) - '(#x2BC . jcircumflex) - '(#x2C5 . Cabovedot) - '(#x2C6 . Ccircumflex) - '(#x2D5 . Gabovedot) - '(#x2D8 . Gcircumflex) - '(#x2DD . Ubreve) - '(#x2DE . Scircumflex) - '(#x2E5 . cabovedot) - '(#x2E6 . ccircumflex) - '(#x2F5 . gabovedot) - '(#x2F8 . gcircumflex) - '(#x2FD . ubreve) - '(#x2FE . scircumflex) - '(#x3A2 . kappa) - '(#x3A3 . Rcedilla) - '(#x3A5 . Itilde) - '(#x3A6 . Lcedilla) - '(#x3AA . Emacron) - '(#x3AB . Gcedilla) - '(#x3AC . Tslash) - '(#x3B3 . rcedilla) - '(#x3B5 . itilde) - '(#x3B6 . lcedilla) - '(#x3BA . emacron) - '(#x3BB . gcedilla) - '(#x3BC . tslash) - '(#x3BD . ENG) - '(#x3BF . eng) - '(#x3C0 . Amacron) - '(#x3C7 . Iogonek) - '(#x3CC . Eabovedot) - '(#x3CF . Imacron) - '(#x3D1 . Ncedilla) - '(#x3D2 . Omacron) - '(#x3D3 . Kcedilla) - '(#x3D9 . Uogonek) - '(#x3DD . Utilde) - '(#x3DE . Umacron) - '(#x3E0 . amacron) - '(#x3E7 . iogonek) - '(#x3EC . eabovedot) - '(#x3EF . imacron) - '(#x3F1 . ncedilla) - '(#x3F2 . omacron) - '(#x3F3 . kcedilla) - '(#x3F9 . uogonek) - '(#x3FD . utilde) - '(#x3FE . umacron) - '(#x47E . overline) - '(#x4A1 . kana-fullstop) - '(#x4A2 . kana-openingbracket) - '(#x4A3 . kana-closingbracket) - '(#x4A4 . kana-comma) - '(#x4A5 . kana-conjunctive) - '(#x4A6 . kana-WO) - '(#x4A7 . kana-a) - '(#x4A8 . kana-i) - '(#x4A9 . kana-u) - '(#x4AA . kana-e) - '(#x4AB . kana-o) - '(#x4AC . kana-ya) - '(#x4AD . kana-yu) - '(#x4AE . kana-yo) - '(#x4AF . kana-tu) - '(#x4B0 . prolongedsound) - '(#x4B1 . kana-A) - '(#x4B2 . kana-I) - '(#x4B3 . kana-U) - '(#x4B4 . kana-E) - '(#x4B5 . kana-O) - '(#x4B6 . kana-KA) - '(#x4B7 . kana-KI) - '(#x4B8 . kana-KU) - '(#x4B9 . kana-KE) - '(#x4BA . kana-KO) - '(#x4BB . kana-SA) - '(#x4BC . kana-SHI) - '(#x4BD . kana-SU) - '(#x4BE . kana-SE) - '(#x4BF . kana-SO) - '(#x4C0 . kana-TA) - '(#x4C1 . kana-TI) - '(#x4C2 . kana-TU) - '(#x4C3 . kana-TE) - '(#x4C4 . kana-TO) - '(#x4C5 . kana-NA) - '(#x4C6 . kana-NI) - '(#x4C7 . kana-NU) - '(#x4C8 . kana-NE) - '(#x4C9 . kana-NO) - '(#x4CA . kana-HA) - '(#x4CB . kana-HI) - '(#x4CC . kana-HU) - '(#x4CD . kana-HE) - '(#x4CE . kana-HO) - '(#x4CF . kana-MA) - '(#x4D0 . kana-MI) - '(#x4D1 . kana-MU) - '(#x4D2 . kana-ME) - '(#x4D3 . kana-MO) - '(#x4D4 . kana-YA) - '(#x4D5 . kana-YU) - '(#x4D6 . kana-YO) - '(#x4D7 . kana-RA) - '(#x4D8 . kana-RI) - '(#x4D9 . kana-RU) - '(#x4DA . kana-RE) - '(#x4DB . kana-RO) - '(#x4DC . kana-WA) - '(#x4DD . kana-N) - '(#x4DE . voicedsound) - '(#x4DF . semivoicedsound) - '(#x5AC . Arabic-comma) - '(#x5BB . Arabic-semicolon) - '(#x5BF . Arabic-question-mark) - '(#x5C1 . Arabic-hamza) - '(#x5C2 . Arabic-maddaonalef) - '(#x5C3 . Arabic-hamzaonalef) - '(#x5C4 . Arabic-hamzaonwaw) - '(#x5C5 . Arabic-hamzaunderalef) - '(#x5C6 . Arabic-hamzaonyeh) - '(#x5C7 . Arabic-alef) - '(#x5C8 . Arabic-beh) - '(#x5C9 . Arabic-tehmarbuta) - '(#x5CA . Arabic-teh) - '(#x5CB . Arabic-theh) - '(#x5CC . Arabic-jeem) - '(#x5CD . Arabic-hah) - '(#x5CE . Arabic-khah) - '(#x5CF . Arabic-dal) - '(#x5D0 . Arabic-thal) - '(#x5D1 . Arabic-ra) - '(#x5D2 . Arabic-zain) - '(#x5D3 . Arabic-seen) - '(#x5D4 . Arabic-sheen) - '(#x5D5 . Arabic-sad) - '(#x5D6 . Arabic-dad) - '(#x5D7 . Arabic-tah) - '(#x5D8 . Arabic-zah) - '(#x5D9 . Arabic-ain) - '(#x5DA . Arabic-ghain) - '(#x5E0 . Arabic-tatweel) - '(#x5E1 . Arabic-feh) - '(#x5E2 . Arabic-qaf) - '(#x5E3 . Arabic-kaf) - '(#x5E4 . Arabic-lam) - '(#x5E5 . Arabic-meem) - '(#x5E6 . Arabic-noon) - '(#x5E7 . Arabic-heh) - '(#x5E8 . Arabic-waw) - '(#x5E9 . Arabic-alefmaksura) - '(#x5EA . Arabic-yeh) - '(#x5EB . Arabic-fathatan) - '(#x5EC . Arabic-dammatan) - '(#x5ED . Arabic-kasratan) - '(#x5EE . Arabic-fatha) - '(#x5EF . Arabic-damma) - '(#x5F0 . Arabic-kasra) - '(#x5F1 . Arabic-shadda) - '(#x5F2 . Arabic-sukun) - '(#x6A1 . Serbian-dje) - '(#x6A2 . Macedonia-gje) - '(#x6A3 . Cyrillic-io) - '(#x6A4 . Ukranian-je) - '(#x6A5 . Macedonia-dse) - '(#x6A6 . Ukranian-i) - '(#x6A7 . Ukranian-yi) - '(#x6A8 . Cyrillic-je) - '(#x6A9 . Cyrillic-lje) - '(#x6AA . Cyrillic-nje) - '(#x6AB . Serbian-tshe) - '(#x6AC . Macedonia-kje) - '(#x6AE . Byelorussian-shortu) - '(#x6AF . Cyrillic-dzhe) - '(#x6B0 . numerosign) - '(#x6B1 . Serbian-DJE) - '(#x6B2 . Macedonia-GJE) - '(#x6B3 . Cyrillic-IO) - '(#x6B4 . Ukranian-JE) - '(#x6B5 . Macedonia-DSE) - '(#x6B6 . Ukranian-I) - '(#x6B7 . Ukrainian-YI) - '(#x6B8 . Cyrillic-JE) - '(#x6B9 . Cyrillic-LJE) - '(#x6BA . Cyrillic-NJE) - '(#x6BB . Serbian-TSHE) - '(#x6BC . Macedonia-KJE) - '(#x6BE . Byelorussian-SHORTU) - '(#x6BF . Cyrillic-DZHE) - '(#x6C0 . Cyrillic-yu) - '(#x6C1 . Cyrillic-a) - '(#x6C2 . Cyrillic-be) - '(#x6C3 . Cyrillic-tse) - '(#x6C4 . Cyrillic-de) - '(#x6C5 . Cyrillic-ie) - '(#x6C6 . Cyrillic-ef) - '(#x6C7 . Cyrillic-ghe) - '(#x6C8 . Cyrillic-ha) - '(#x6C9 . Cyrillic-i) - '(#x6CA . Cyrillic-shorti) - '(#x6CB . Cyrillic-ka) - '(#x6CC . Cyrillic-el) - '(#x6CD . Cyrillic-em) - '(#x6CE . Cyrillic-en) - '(#x6CF . Cyrillic-o) - '(#x6D0 . Cyrillic-pe) - '(#x6D1 . Cyrillic-ya) - '(#x6D2 . Cyrillic-er) - '(#x6D3 . Cyrillic-es) - '(#x6D4 . Cyrillic-te) - '(#x6D5 . Cyrillic-u) - '(#x6D6 . Cyrillic-zhe) - '(#x6D7 . Cyrillic-ve) - '(#x6D8 . Cyrillic-softsign) - '(#x6D9 . Cyrillic-yeru) - '(#x6DA . Cyrillic-ze) - '(#x6DB . Cyrillic-sha) - '(#x6DC . Cyrillic-e) - '(#x6DD . Cyrillic-shcha) - '(#x6DE . Cyrillic-che) - '(#x6DF . Cyrillic-hardsign) - '(#x6E0 . Cyrillic-YU) - '(#x6E1 . Cyrillic-A) - '(#x6E2 . Cyrillic-BE) - '(#x6E3 . Cyrillic-TSE) - '(#x6E4 . Cyrillic-DE) - '(#x6E5 . Cyrillic-IE) - '(#x6E6 . Cyrillic-EF) - '(#x6E7 . Cyrillic-GHE) - '(#x6E8 . Cyrillic-HA) - '(#x6E9 . Cyrillic-I) - '(#x6EA . Cyrillic-SHORTI) - '(#x6EB . Cyrillic-KA) - '(#x6EC . Cyrillic-EL) - '(#x6ED . Cyrillic-EM) - '(#x6EE . Cyrillic-EN) - '(#x6EF . Cyrillic-O) - '(#x6F0 . Cyrillic-PE) - '(#x6F1 . Cyrillic-YA) - '(#x6F2 . Cyrillic-ER) - '(#x6F3 . Cyrillic-ES) - '(#x6F4 . Cyrillic-TE) - '(#x6F5 . Cyrillic-U) - '(#x6F6 . Cyrillic-ZHE) - '(#x6F7 . Cyrillic-VE) - '(#x6F8 . Cyrillic-SOFTSIGN) - '(#x6F9 . Cyrillic-YERU) - '(#x6FA . Cyrillic-ZE) - '(#x6FB . Cyrillic-SHA) - '(#x6FC . Cyrillic-E) - '(#x6FD . Cyrillic-SHCHA) - '(#x6FE . Cyrillic-CHE) - '(#x6FF . Cyrillic-HARDSIGN) - '(#x7A1 . Greek-ALPHAaccent) - '(#x7A2 . Greek-EPSILONaccent) - '(#x7A3 . Greek-ETAaccent) - '(#x7A4 . Greek-IOTAaccent) - '(#x7A5 . Greek-IOTAdiaeresis) - '(#x7A7 . Greek-OMICRONaccent) - '(#x7A8 . Greek-UPSILONaccent) - '(#x7A9 . Greek-UPSILONdieresis) - '(#x7AB . Greek-OMEGAaccent) - '(#x7AE . Greek-accentdieresis) - '(#x7AF . Greek-horizbar) - '(#x7B1 . Greek-alphaaccent) - '(#x7B2 . Greek-epsilonaccent) - '(#x7B3 . Greek-etaaccent) - '(#x7B4 . Greek-iotaaccent) - '(#x7B5 . Greek-iotadieresis) - '(#x7B6 . Greek-iotaaccentdieresis) - '(#x7B7 . Greek-omicronaccent) - '(#x7B8 . Greek-upsilonaccent) - '(#x7B9 . Greek-upsilondieresis) - '(#x7BA . Greek-upsilonaccentdieresis) - '(#x7BB . Greek-omegaaccent) - '(#x7C1 . Greek-ALPHA) - '(#x7C2 . Greek-BETA) - '(#x7C3 . Greek-GAMMA) - '(#x7C4 . Greek-DELTA) - '(#x7C5 . Greek-EPSILON) - '(#x7C6 . Greek-ZETA) - '(#x7C7 . Greek-ETA) - '(#x7C8 . Greek-THETA) - '(#x7C9 . Greek-IOTA) - '(#x7CA . Greek-KAPPA) - '(#x7CB . Greek-LAMBDA) - '(#x7CC . Greek-MU) - '(#x7CD . Greek-NU) - '(#x7CE . Greek-XI) - '(#x7CF . Greek-OMICRON) - '(#x7D0 . Greek-PI) - '(#x7D1 . Greek-RHO) - '(#x7D2 . Greek-SIGMA) - '(#x7D4 . Greek-TAU) - '(#x7D5 . Greek-UPSILON) - '(#x7D6 . Greek-PHI) - '(#x7D7 . Greek-CHI) - '(#x7D8 . Greek-PSI) - '(#x7D9 . Greek-OMEGA) - '(#x7E1 . Greek-alpha) - '(#x7E2 . Greek-beta) - '(#x7E3 . Greek-gamma) - '(#x7E4 . Greek-delta) - '(#x7E5 . Greek-epsilon) - '(#x7E6 . Greek-zeta) - '(#x7E7 . Greek-eta) - '(#x7E8 . Greek-theta) - '(#x7E9 . Greek-iota) - '(#x7EA . Greek-kappa) - '(#x7EB . Greek-lambda) - '(#x7EC . Greek-mu) - '(#x7ED . Greek-nu) - '(#x7EE . Greek-xi) - '(#x7EF . Greek-omicron) - '(#x7F0 . Greek-pi) - '(#x7F1 . Greek-rho) - '(#x7F2 . Greek-sigma) - '(#x7F3 . Greek-finalsmallsigma) - '(#x7F4 . Greek-tau) - '(#x7F5 . Greek-upsilon) - '(#x7F6 . Greek-phi) - '(#x7F7 . Greek-chi) - '(#x7F8 . Greek-psi) - '(#x7F9 . Greek-omega) - '(#x8A1 . leftradical) - '(#x8A2 . topleftradical) - '(#x8A3 . horizconnector) - '(#x8A4 . topintegral) - '(#x8A5 . botintegral) - '(#x8A6 . vertconnector) - '(#x8A7 . topleftsqbracket) - '(#x8A8 . botleftsqbracket) - '(#x8A9 . toprightsqbracket) - '(#x8AA . botrightsqbracket) - '(#x8AB . topleftparens) - '(#x8AC . botleftparens) - '(#x8AD . toprightparens) - '(#x8AE . botrightparens) - '(#x8AF . leftmiddlecurlybrace) - '(#x8B0 . rightmiddlecurlybrace) - '(#x8B1 . topleftsummation) - '(#x8B2 . botleftsummation) - '(#x8B3 . topvertsummationconnector) - '(#x8B4 . botvertsummationconnector) - '(#x8B5 . toprightsummation) - '(#x8B6 . botrightsummation) - '(#x8B7 . rightmiddlesummation) - '(#x8BC . lessthanequal) - '(#x8BD . notequal) - '(#x8BE . greaterthanequal) - '(#x8BF . integral) - '(#x8C0 . therefore) - '(#x8C1 . variation) - '(#x8C2 . infinity) - '(#x8C5 . nabla) - '(#x8C8 . approximate) - '(#x8C9 . similarequal) - '(#x8CD . ifonlyif) - '(#x8CE . implies) - '(#x8CF . identical) - '(#x8D6 . radical) - '(#x8DA . includedin) - '(#x8DB . includes) - '(#x8DC . intersection) - '(#x8DD . union) - '(#x8DE . logicaland) - '(#x8DF . logicalor) - '(#x8EF . partialderivative) - '(#x8F6 . function) - '(#x8FB . leftarrow) - '(#x8FC . uparrow) - '(#x8FD . rightarrow) - '(#x8FE . downarrow) - '(#x9DF . blank) - '(#x9E0 . soliddiamond) - '(#x9E1 . checkerboard) - '(#x9E2 . ht) - '(#x9E3 . ff) - '(#x9E4 . cr) - '(#x9E5 . lf) - '(#x9E8 . nl) - '(#x9E9 . vt) - '(#x9EA . lowrightcorner) - '(#x9EB . uprightcorner) - '(#x9EC . upleftcorner) - '(#x9ED . lowleftcorner) - '(#x9EE . crossinglines) - '(#x9EF . horizlinescan1) - '(#x9F0 . horizlinescan3) - '(#x9F1 . horizlinescan5) - '(#x9F2 . horizlinescan7) - '(#x9F3 . horizlinescan9) - '(#x9F4 . leftt) - '(#x9F5 . rightt) - '(#x9F6 . bott) - '(#x9F7 . topt) - '(#x9F8 . vertbar) - '(#xAA1 . emspace) - '(#xAA2 . enspace) - '(#xAA3 . em3space) - '(#xAA4 . em4space) - '(#xAA5 . digitspace) - '(#xAA6 . punctspace) - '(#xAA7 . thinspace) - '(#xAA8 . hairspace) - '(#xAA9 . emdash) - '(#xAAA . endash) - '(#xAAC . signifblank) - '(#xAAE . ellipsis) - '(#xAAF . doubbaselinedot) - '(#xAB0 . onethird) - '(#xAB1 . twothirds) - '(#xAB2 . onefifth) - '(#xAB3 . twofifths) - '(#xAB4 . threefifths) - '(#xAB5 . fourfifths) - '(#xAB6 . onesixth) - '(#xAB7 . fivesixths) - '(#xAB8 . careof) - '(#xABB . figdash) - '(#xABC . leftanglebracket) - '(#xABD . decimalpoint) - '(#xABE . rightanglebracket) - '(#xABF . marker) - '(#xAC3 . oneeighth) - '(#xAC4 . threeeighths) - '(#xAC5 . fiveeighths) - '(#xAC6 . seveneighths) - '(#xAC9 . trademark) - '(#xACA . signaturemark) - '(#xACB . trademarkincircle) - '(#xACC . leftopentriangle) - '(#xACD . rightopentriangle) - '(#xACE . emopencircle) - '(#xACF . emopenrectangle) - '(#xAD0 . leftsinglequotemark) - '(#xAD1 . rightsinglequotemark) - '(#xAD2 . leftdoublequotemark) - '(#xAD3 . rightdoublequotemark) - '(#xAD4 . prescription) - '(#xAD6 . minutes) - '(#xAD7 . seconds) - '(#xAD9 . latincross) - '(#xADA . hexagram) - '(#xADB . filledrectbullet) - '(#xADC . filledlefttribullet) - '(#xADD . filledrighttribullet) - '(#xADE . emfilledcircle) - '(#xADF . emfilledrect) - '(#xAE0 . enopencircbullet) - '(#xAE1 . enopensquarebullet) - '(#xAE2 . openrectbullet) - '(#xAE3 . opentribulletup) - '(#xAE4 . opentribulletdown) - '(#xAE5 . openstar) - '(#xAE6 . enfilledcircbullet) - '(#xAE7 . enfilledsqbullet) - '(#xAE8 . filledtribulletup) - '(#xAE9 . filledtribulletdown) - '(#xAEA . leftpointer) - '(#xAEB . rightpointer) - '(#xAEC . club) - '(#xAED . diamond) - '(#xAEE . heart) - '(#xAF0 . maltesecross) - '(#xAF1 . dagger) - '(#xAF2 . doubledagger) - '(#xAF3 . checkmark) - '(#xAF4 . ballotcross) - '(#xAF5 . musicalsharp) - '(#xAF6 . musicalflat) - '(#xAF7 . malesymbol) - '(#xAF8 . femalesymbol) - '(#xAF9 . telephone) - '(#xAFA . telephonerecorder) - '(#xAFB . phonographcopyright) - '(#xAFC . caret) - '(#xAFD . singlelowquotemark) - '(#xAFE . doublelowquotemark) - '(#xAFF . cursor) - '(#xBA3 . leftcaret) - '(#xBA6 . rightcaret) - '(#xBA8 . downcaret) - '(#xBA9 . upcaret) - '(#xBC0 . overbar) - '(#xBC2 . downtack) - '(#xBC3 . upshoe) - '(#xBC4 . downstile) - '(#xBC6 . underbar) - '(#xBCA . jot) - '(#xBCC . quad) - '(#xBCE . uptack) - '(#xBCF . circle) - '(#xBD3 . upstile) - '(#xBD6 . downshoe) - '(#xBD8 . rightshoe) - '(#xBDA . leftshoe) - '(#xBDC . lefttack) - '(#xBFC . righttack) - '(#xCDF . hebrew-doublelowline) - '(#xCE0 . hebrew-aleph) - '(#xCE1 . hebrew-beth) - '(#xCE2 . hebrew-gimmel) - '(#xCE3 . hebrew-daleth) - '(#xCE4 . hebrew-he) - '(#xCE5 . hebrew-waw) - '(#xCE6 . hebrew-zayin) - '(#xCE7 . hebrew-het) - '(#xCE8 . hebrew-teth) - '(#xCE9 . hebrew-yod) - '(#xCEA . hebrew-finalkaph) - '(#xCEB . hebrew-kaph) - '(#xCEC . hebrew-lamed) - '(#xCED . hebrew-finalmem) - '(#xCEE . hebrew-mem) - '(#xCEF . hebrew-finalnun) - '(#xCF0 . hebrew-nun) - '(#xCF1 . hebrew-samekh) - '(#xCF2 . hebrew-ayin) - '(#xCF3 . hebrew-finalpe) - '(#xCF4 . hebrew-pe) - '(#xCF5 . hebrew-finalzadi) - '(#xCF6 . hebrew-zadi) - '(#xCF7 . hebrew-qoph) - '(#xCF8 . hebrew-resh) - '(#xCF9 . hebrew-shin) - '(#xCFA . hebrew-taf) - '(#xFF08 . BackSpace) - '(#xFF09 . Tab) - '(#xFF0A . Linefeed) - '(#xFF0B . Clear) - '(#xFF0D . Return) - '(#xFF13 . Pause) - '(#xFF14 . Scroll-Lock) - '(#xFF1B . Escape) - '(#xFF20 . Multi-key) - '(#xFF21 . Kanji) - '(#xFF22 . Muhenkan) - '(#xFF23 . Henkan) - '(#xFF24 . Romaji) - '(#xFF25 . Hiragana) - '(#xFF26 . Katakana) - '(#xFF27 . Hiragana-Katakana) - '(#xFF28 . Zenkaku) - '(#xFF29 . Hankaku) - '(#xFF2A . Zenkaku-Hankaku) - '(#xFF2B . Touroku) - '(#xFF2C . Massyo) - '(#xFF2D . Kana-Lock) - '(#xFF2E . Kana-Shift) - '(#xFF2F . Eisu-Shift) - '(#xFF30 . Eisu-toggle) - '(#xFF50 . Home) - '(#xFF51 . Left) - '(#xFF52 . Up) - '(#xFF53 . Right) - '(#xFF54 . Down) - '(#xFF55 . Prior) - '(#xFF56 . Next) - '(#xFF57 . End) - '(#xFF58 . Begin) - '(#xFF60 . Select) - '(#xFF61 . Print) - '(#xFF62 . Execute) - '(#xFF63 . Insert) - '(#xFF65 . Undo) - '(#xFF66 . Redo) - '(#xFF67 . Menu) - '(#xFF68 . Find) - '(#xFF69 . Stop) ;originally called Cancel - '(#xFF6A . Help) - '(#xFF6B . Break) - '(#xFF7E . script-switch) - '(#xFF7F . Num-Lock) - '(#xFF80 . KP-Space) - '(#xFF89 . KP-Tab) - '(#xFF8D . KP-Enter) - '(#xFF91 . KP-F1) - '(#xFF92 . KP-F2) - '(#xFF93 . KP-F3) - '(#xFF94 . KP-F4) - '(#xFFAA . KP-Multiply) - '(#xFFAB . KP-Add) - '(#xFFAC . KP-Separator) - '(#xFFAD . KP-Subtract) - '(#xFFAE . KP-Decimal) - '(#xFFAF . KP-Divide) - '(#xFFB0 . KP-0) - '(#xFFB1 . KP-1) - '(#xFFB2 . KP-2) - '(#xFFB3 . KP-3) - '(#xFFB4 . KP-4) - '(#xFFB5 . KP-5) - '(#xFFB6 . KP-6) - '(#xFFB7 . KP-7) - '(#xFFB8 . KP-8) - '(#xFFB9 . KP-9) - '(#xFFBD . KP-Equal) - '(#xFFBE . F1) - '(#xFFBF . F2) - '(#xFFC0 . F3) - '(#xFFC1 . F4) - '(#xFFC2 . F5) - '(#xFFC3 . F6) - '(#xFFC4 . F7) - '(#xFFC5 . F8) - '(#xFFC6 . F9) - '(#xFFC7 . F10) - '(#xFFC8 . F11) - '(#xFFC9 . F12) - '(#xFFCA . F13) - '(#xFFCB . F14) - '(#xFFCC . F15) - '(#xFFCD . F16) - '(#xFFCE . F17) - '(#xFFCF . F18) - '(#xFFD0 . F19) - '(#xFFD1 . F20) - '(#xFFD2 . F21) - '(#xFFD3 . F22) - '(#xFFD4 . F23) - '(#xFFD5 . F24) - '(#xFFD6 . F25) - '(#xFFD7 . F26) - '(#xFFD8 . F27) - '(#xFFD9 . F28) - '(#xFFDA . F29) - '(#xFFDB . F30) - '(#xFFDC . F31) - '(#xFFDD . F32) - '(#xFFDE . F33) - '(#xFFDF . F34) - '(#xFFE0 . F35) - '(#xFFE1 . Shift-L) - '(#xFFE2 . Shift-R) - '(#xFFE3 . Control-L) - '(#xFFE4 . Control-R) - '(#xFFE5 . Caps-Lock) - '(#xFFE6 . Shift-Lock) - '(#xFFE7 . Meta-L) - '(#xFFE8 . Meta-R) - '(#xFFE9 . Alt-L) - '(#xFFEA . Alt-R) - '(#xFFEB . Super-L) - '(#xFFEC . Super-R) - '(#xFFED . Hyper-L) - '(#xFFEE . Hyper-R) - '(#xFFFF . Delete) - '(#x8000A8 . mute-acute) - '(#x8000A9 . mute-grave) - '(#x8000AA . mute-asciicircum) - '(#x8000AB . mute-diaeresis) - '(#x8000AC . mute-asciitilde) - '(#x8000AF . lira) - '(#x8000BE . guilder) - '(#x8000EE . Ydiaeresis) - '(#x8000F6 . longminus) - '(#x8000FC . block) - '(#x80FF48 . hpModelock1) - '(#x80FF49 . hpModelock2) - '(#x80FF6C . Reset) - '(#x80FF6D . System) - '(#x80FF6E . User) - '(#x80FF6F . ClearLine) - '(#x80FF70 . InsertLine) - '(#x80FF71 . DeleteLine) - '(#x80FF72 . InsertChar) - '(#x80FF73 . DeleteChar) - '(#x80FF74 . BackTab) - '(#x80FF75 . KP-BackTab) - '(#x80FF76 . Ext16bit-L) - '(#x80FF77 . Ext16bit-R) - '(#x84FF02 . osfCopy) - '(#x84FF03 . osfCut) - '(#x84FF04 . osfPaste) - '(#x84FF08 . osfBackSpace) - '(#x84FF0B . osfClear) - '(#x84FF31 . osfAddMode) - '(#x84FF32 . osfPrimaryPaste) - '(#x84FF33 . osfQuickPaste) - '(#x84FF41 . osfPageUp) - '(#x84FF42 . osfPageDown) - '(#x84FF44 . osfActivate) - '(#x84FF45 . osfMenuBar) - '(#x84FF51 . osfLeft) - '(#x84FF52 . osfUp) - '(#x84FF53 . osfRight) - '(#x84FF54 . osfDown) - '(#x84FF57 . osfEndLine) - '(#x84FF58 . osfBeginLine) - '(#x84FF60 . osfSelect) - '(#x84FF63 . osfInsert) - '(#x84FF65 . osfUndo) - '(#x84FF67 . osfMenu) - '(#x84FF69 . osfCancel) - '(#x84FF6A . osfHelp) - '(#x84FFFF . osfDelete) - '(#xFFFFFF . VoidSymbol))) \ No newline at end of file diff --git a/src/edwin/kilcom.scm b/src/edwin/kilcom.scm index e2c9f3642..738e4fadb 100644 --- a/src/edwin/kilcom.scm +++ b/src/edwin/kilcom.scm @@ -193,6 +193,18 @@ The command \\[yank] can retrieve it from there. (let ((point (if (default-object? point) (current-point) point))) (kill-ring-save (extract-string mark point) (mark<= point mark) point))) +(define (os/interprogram-cut string context) + ;; This dummy is re-assigned by the last display type loaded(!). It + ;; needs to be a display type operation. + (declare (ignore string context)) + unspecific) + +(define (os/interprogram-paste point) + ;; This dummy is re-assigned by the last display type loaded(!). It + ;; needs to be a display type operation. + (declare (ignore point)) + unspecific) + (define (kill-ring-save string forward? context) (command-message-receive append-next-kill-tag (lambda () diff --git a/src/edwin/xcom.scm b/src/edwin/xcom.scm deleted file mode 100644 index 5113bfb99..000000000 --- a/src/edwin/xcom.scm +++ /dev/null @@ -1,346 +0,0 @@ -#| -*-Scheme-*- - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, - 2017, 2018 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -|# - -;;;; X Commands - -(declare (usual-integrations)) - -(define-primitives - (x-list-fonts 3) - (x-set-default-font 2) - (x-window-clear 1) - (x-window-get-position 1) - (x-window-get-size 1) - (x-window-lower 1) - (x-window-raise 1) - (x-window-set-background-color 2) - (x-window-set-border-color 2) - (x-window-set-border-width 2) - (x-window-set-cursor-color 2) - (x-window-set-font 2) - (x-window-set-foreground-color 2) - (x-window-set-internal-border-width 2) - (x-window-set-mouse-color 2) - (x-window-set-mouse-shape 2) - (x-window-set-position 3) - (x-window-set-size 3) - (x-window-x-size 1) - (x-window-y-size 1) - (xterm-reconfigure 3) - (xterm-set-size 3) - (xterm-x-size 1) - (xterm-y-size 1)) - -(define (current-xterm) - (screen-xterm (selected-screen))) - -(define-command set-foreground-color - "Set foreground (text) color of selected frame to COLOR." - "sSet foreground color" - (lambda (color) - (x-window-set-foreground-color (current-xterm) color) - (update-screen! (selected-screen) true))) - -(define-command set-background-color - "Set background color of selected frame to COLOR." - "sSet background color" - (lambda (color) - (let ((xterm (current-xterm))) - (x-window-set-background-color xterm color) - (x-window-clear xterm)) - (update-screen! (selected-screen) true))) - -(define-command set-border-color - "Set border color of selected frame to COLOR." - "sSet border color" - (lambda (color) - (x-window-set-border-color (current-xterm) color))) - -(define-command set-cursor-color - "Set cursor color of selected frame to COLOR." - "sSet cursor color" - (lambda (color) - (x-window-set-cursor-color (current-xterm) color))) - -(define-command set-mouse-color - "Set mouse color of selected frame to COLOR." - "sSet mouse color" - (lambda (color) - (x-window-set-mouse-color (current-xterm) color))) - -(define-command set-border-width - "Set border width of selected frame to WIDTH." - "nSet border width" - (lambda (width) - (x-window-set-border-width (current-xterm) (max 0 width)) - (update-screen! (selected-screen) true))) - -(define-command set-internal-border-width - "Set internal border width of selected frame to WIDTH." - "nSet internal border width" - (lambda (width) - (x-window-set-internal-border-width (current-xterm) (max 0 width)))) - -(define-command set-font - "Set text font of selected frame to FONT." - (lambda () - (list (prompt-for-x-font-name "Set font" #f))) - (lambda (font) - (let ((xterm (current-xterm))) - (let ((x-size (xterm-x-size xterm)) - (y-size (xterm-y-size xterm))) - (if (not (x-window-set-font xterm font)) - (editor-error "Unknown font name: " font)) - (xterm-reconfigure xterm x-size y-size))))) - -(define-command set-default-font - "Set text font to be used in new frames." - (lambda () - (list (prompt-for-x-font-name "Set default font" #f))) - (lambda (font) - (x-set-default-font (screen-display (selected-screen)) font))) - -(define-command font-apropos - "Show all X fonts whose names match a given regular expression." - "sFont apropos (regexp)" - (lambda (regexp) - (with-output-to-help-display - (lambda () - (font-apropos regexp))))) - -(define-command apropos-font - (command-description (ref-command-object font-apropos)) - (command-interactive-specification (ref-command-object font-apropos)) - (command-procedure (ref-command-object font-apropos))) - -(define (font-apropos regexp) - (for-each (lambda (font) - (write-string font) - (newline)) - (string-table-apropos (x-font-name-table) regexp))) - -(define (prompt-for-x-font-name prompt default . options) - (apply prompt-for-string-table-name prompt default (x-font-name-table) - options)) - -(define (x-font-name-table) - (build-x-font-name-table (screen-display (selected-screen)) - "*" - #f)) - -(define (build-x-font-name-table display pattern limit) - (let ((font-name-vector (x-list-fonts display pattern limit)) - (font-name-table (make-string-table))) - (do ((index 0 (fix:+ index 1))) - ((fix:= index (vector-length font-name-vector))) - (let ((font-name (vector-ref font-name-vector index))) - (string-table-put! font-name-table font-name font-name))) - font-name-table)) - -(define-command show-frame-size - "Show size of editor frame." - () - (lambda () - (let ((screen (selected-screen))) - (let ((w.h (x-window-get-size (screen-xterm screen)))) - (message "Frame is " - (screen-x-size screen) - " chars wide and " - (screen-y-size screen) - " chars high (" - (car w.h) - "x" - (cdr w.h) - " pixels)"))))) - -(define-command set-frame-size - "Set size of selected frame to WIDTH x HEIGHT." - "nFrame width (chars)\nnFrame height (chars)" - (lambda (width height) - (xterm-set-size (current-xterm) (max 2 width) (max 2 height)))) - -(define-command show-frame-position - "Show position of editor frame. -This is the position of the upper left-hand corner of the frame border -surrounding the frame, relative to the upper left-hand corner of the -desktop." - () - (lambda () - (let ((x.y (x-window-get-position (current-xterm)))) - (message "Frame's upper left-hand corner is at (" - (car x.y) "," (cdr x.y) ")")))) - -(define-command set-frame-position - "Set position of selected frame to (X,Y)." - "nX position (pixels)\nnY position (pixels)" - (lambda (x y) - (x-window-set-position (current-xterm) x y))) - -(define-command set-frame-name - "Set name of selected frame to NAME. -Useful only if `frame-name-format' is false." - "sSet frame name" - (lambda (name) (xterm-screen/set-name (selected-screen) name))) - -(define-command set-frame-icon-name - "Set icon name of selected frame to NAME. -Useful only if `frame-icon-name-format' is false." - "sSet frame icon name" - (lambda (name) (xterm-screen/set-icon-name (selected-screen) name))) - -(define (update-xterm-screen-names! screen) - (let ((window - (if (and (selected-screen? screen) (within-typein-edit?)) - (typein-edit-other-window) - (screen-selected-window screen)))) - (let ((buffer (window-buffer window)) - (update-name - (lambda (set-name format length) - (if format - (set-name - screen - (string-trim-right - (format-modeline-string window format length))))))) - (update-name xterm-screen/set-name - (ref-variable frame-name-format buffer) - (ref-variable frame-name-length buffer)) - (update-name xterm-screen/set-icon-name - (ref-variable frame-icon-name-format buffer) - (ref-variable frame-icon-name-length buffer))))) - -(define-variable frame-icon-name-format - "If not false, template for displaying frame icon name. -Has same format as `mode-line-format'." - "edwin") - -(define-variable frame-icon-name-length - "Maximum length of frame icon name. -Used only if `frame-icon-name-format' is non-false." - 32 - exact-nonnegative-integer?) - -(define-command raise-frame - "Raise the selected frame so that it is not obscured by other windows." - () - (lambda () (x-window-raise (current-xterm)))) - -(define-command lower-frame - "Lower the selected frame so that it does not obscure other windows." - () - (lambda () (x-window-lower (current-xterm)))) - -(define-command set-mouse-shape - "Set mouse cursor shape for selected frame to SHAPE. -SHAPE must be the (string) name of one of the known cursor shapes. -When called interactively, completion is available on the input." - (lambda () - (list (prompt-for-alist-value "Set mouse shape" - (map (lambda (x) (cons x x)) - mouse-cursor-shapes)))) - (lambda (shape) - (x-window-set-mouse-shape - (current-xterm) - (let loop ((shapes mouse-cursor-shapes) (index 0)) - (if (not (pair? shapes)) - (error "Unknown shape name:" shape)) - (if (string-ci=? shape (car shapes)) - index - (loop (cdr shapes) (fix:+ index 1))))))) - -(define mouse-cursor-shapes - '("X-cursor" "arrow" "based-arrow-down" "based-arrow-up" "boat" "bogosity" - "bottom-left-corner" "bottom-right-corner" "bottom-side" - "bottom-tee" "box-spiral" "center-ptr" "circle" "clock" - "coffee-mug" "cross" "cross-reverse" "crosshair" "diamond-cross" - "dot" "dotbox" "double-arrow" "draft-large" "draft-small" - "draped-box" "exchange" "fleur" "gobbler" "gumby" "hand1" - "hand2" "heart" "icon" "iron-cross" "left-ptr" "left-side" - "left-tee" "leftbutton" "ll-angle" "lr-angle" "man" - "middlebutton" "mouse" "pencil" "pirate" "plus" "question-arrow" - "right-ptr" "right-side" "right-tee" "rightbutton" "rtl-logo" - "sailboat" "sb-down-arrow" "sb-h-double-arrow" "sb-left-arrow" - "sb-right-arrow" "sb-up-arrow" "sb-v-double-arrow" "shuttle" - "sizing" "spider" "spraycan" "star" "target" "tcross" - "top-left-arrow" "top-left-corner" "top-right-corner" - "top-side" "top-tee" "trek" "ul-angle" "umbrella" "ur-angle" - "watch" "xterm")) - -;;;; Mouse Commands -;;; (For compatibility with old code.) - -(define-syntax define-old-mouse-command - (sc-macro-transformer - (lambda (form environment) - (let ((name (cadr form))) - `(define ,(symbol 'edwin-command$x- name) - ,(close-syntax (symbol 'edwin-command$ name) - environment)))))) - -(define-old-mouse-command set-foreground-color) -(define-old-mouse-command set-background-color) -(define-old-mouse-command set-border-color) -(define-old-mouse-command set-cursor-color) -(define-old-mouse-command set-mouse-color) -(define-old-mouse-command set-font) -(define-old-mouse-command set-border-width) -(define-old-mouse-command set-internal-border-width) -(define-old-mouse-command set-mouse-shape) -(define-old-mouse-command mouse-select) -(define-old-mouse-command mouse-keep-one-window) -(define-old-mouse-command mouse-select-and-split) -(define-old-mouse-command mouse-set-point) -(define-old-mouse-command mouse-set-mark) -(define-old-mouse-command mouse-show-event) -(define-old-mouse-command mouse-ignore) - -(define edwin-command$x-set-size edwin-command$set-frame-size) -(define edwin-command$x-set-position edwin-command$set-frame-position) -(define edwin-command$x-set-window-name edwin-command$set-frame-name) -(define edwin-command$x-set-icon-name edwin-command$set-frame-icon-name) -(define edwin-command$x-raise-screen edwin-command$raise-frame) -(define edwin-command$x-lower-screen edwin-command$lower-frame) - -(define-syntax define-old-screen-command - (sc-macro-transformer - (lambda (form environment) - (let ((name (cadr form))) - `(define ,(symbol 'edwin-variable$x-screen- name) - ,(close-syntax (symbol 'edwin-variable$frame- name) - environment)))))) - -(define-old-screen-command icon-name-format) -(define-old-screen-command icon-name-length) - -(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) \ No newline at end of file diff --git a/src/edwin/xmodef.scm b/src/edwin/xmodef.scm deleted file mode 100644 index e3d1fd4d9..000000000 --- a/src/edwin/xmodef.scm +++ /dev/null @@ -1,30 +0,0 @@ -#| -*-Scheme-*- - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, - 2017, 2018 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -|# - -;;;; Fundamental Mode, additional X bindings - -(declare (usual-integrations)) - diff --git a/src/edwin/xterm.scm b/src/edwin/xterm.scm index 6299e316c..fc741bc6f 100644 --- a/src/edwin/xterm.scm +++ b/src/edwin/xterm.scm @@ -29,1432 +29,46 @@ USA. (declare (usual-integrations)) -(define-primitives - (x-change-property 7) - (x-close-all-displays 0) - (x-close-display 1) - (x-close-window 1) - (x-convert-selection 6) - (x-delete-property 3) - (x-display-descriptor 1) - (x-display-flush 1) - (x-display-get-default 3) - (x-display-get-size 2) - (x-display-process-events 2) - (x-display-sync 2) - (x-get-atom-name 2) - (x-get-selection-owner 2) - (x-get-window-property 7) - (x-intern-atom 3) - (x-max-request-size 1) - (x-open-display 1) - (x-select-input 3) - (x-send-selection-notify 6) - (x-set-selection-owner 4) - (x-window-andc-event-mask 2) - (x-window-beep 1) - (x-window-display 1) - (x-window-flush 1) - (x-window-id 1) - (x-window-map 1) - (x-window-or-event-mask 2) - (x-window-raise 1) - (x-window-set-event-mask 2) - (x-window-set-icon-name 2) - (x-window-set-input-focus 2) - (x-window-set-name 2) - (xterm-clear-rectangle! 6) - (xterm-draw-cursor 1) - (xterm-dump-rectangle 5) - (xterm-enable-cursor 2) - (xterm-erase-cursor 1) - (xterm-map-x-coordinate 2) - (xterm-map-x-size 2) - (xterm-map-y-coordinate 2) - (xterm-map-y-size 2) - (xterm-open-window 3) - (xterm-reconfigure 3) - (xterm-restore-contents 6) - (xterm-save-contents 5) - (xterm-scroll-lines-down 6) - (xterm-scroll-lines-up 6) - (xterm-set-size 3) - (xterm-write-char! 5) - (xterm-write-cursor! 3) - (xterm-write-substring! 7) - (xterm-x-size 1) - (xterm-y-size 1)) - -;; These constants must match "microcode/x11base.c" -(define-integrable event:process-output -2) -(define-integrable event:process-status -3) -(define-integrable event:inferior-thread-output -4) -(define-integrable event-type:button-down 0) -(define-integrable event-type:button-up 1) -(define-integrable event-type:configure 2) -(define-integrable event-type:enter 3) -(define-integrable event-type:focus-in 4) -(define-integrable event-type:focus-out 5) -(define-integrable event-type:key-press 6) -(define-integrable event-type:leave 7) -(define-integrable event-type:motion 8) -(define-integrable event-type:expose 9) -(define-integrable event-type:delete-window 10) -(define-integrable event-type:map 11) -(define-integrable event-type:unmap 12) -(define-integrable event-type:take-focus 13) -(define-integrable event-type:visibility 14) -(define-integrable event-type:selection-clear 15) -(define-integrable event-type:selection-notify 16) -(define-integrable event-type:selection-request 17) -(define-integrable event-type:property-notify 18) -(define-integrable number-of-event-types 19) - -;; This mask contains button-down, button-up, configure, focus-in, -;; key-press, expose, destroy, map, unmap, visibility, -;; selection-clear, selection-notify, selection-request, and -;; property-notify. -(define-integrable event-mask #x7de57) - -(define-structure (xterm-screen-state - (constructor make-xterm-screen-state (xterm display)) - (conc-name xterm-screen-state/)) - (xterm #f read-only #t) - (display #f read-only #t) - (redisplay-flag #t) - (selected? #t) - (name #f) - (icon-name #f) - (x-visibility 'VISIBLE) - (mapped? #f) - (unexposed? #t)) +;;;; An X display type that autoloads the x11-screen plugin. + +(define x-display-type + (make-display-type + 'X #t + (named-lambda (x11-screen-available?) + (and (let ((display (get-environment-variable "DISPLAY"))) + (and (string? display) + (not (string-null? display)))) + (let ((dirpath (system-library-directory-pathname "x11-screen/"))) + (and dirpath + (file-directory? dirpath))))) + (named-lambda (make-x11-screen #!optional geometry) + (load-option-quietly 'x11-screen) + (make-xterm-screen geometry)) + (named-lambda (get-x11-screen-input-operations screen) + screen + (get-xterm-input-operations)) + (named-lambda (with-x11-display-grabbed receiver) + (with-editor-interrupts-from-x receiver)) + (named-lambda (with-x11-interrupts-enabled thunk) + (with-x-interrupts-enabled thunk)) + (named-lambda (with-x11-interrupts-disabled thunk) + (with-x-interrupts-disabled thunk)))) -(define screen-list) - (define (make-xterm-screen #!optional geometry) - ;; Don't map the window until all of the data structures are in - ;; place. This guarantees that no events will be missed. - (let ((xterm - (open-window (null? screen-list) - (if (default-object? geometry) #f geometry)))) - (x-window-set-event-mask xterm event-mask) - (let ((screen - (make-screen (make-xterm-screen-state xterm - (x-window-display xterm)) - xterm-screen/beep - xterm-screen/clear-line! - xterm-screen/clear-rectangle! - xterm-screen/clear-screen! - xterm-screen/discard! - xterm-screen/enter! - xterm-screen/exit! - xterm-screen/flush! - xterm-screen/modeline-event! - #f - xterm-screen/scroll-lines-down! - xterm-screen/scroll-lines-up! - xterm-screen/wrap-update! - xterm-screen/write-char! - xterm-screen/write-cursor! - xterm-screen/write-substring! - 8 - (xterm-x-size xterm) - (xterm-y-size xterm)))) - (set! screen-list (cons screen screen-list)) - (update-visibility! screen) - (x-window-map xterm) - (x-window-flush xterm) - screen))) - -(define (open-window primary? geometry) - (let ((display (or (get-x-display) (error "Unable to open display."))) - (instance (if primary? "edwin" "edwinSecondary")) - (class "Emacs")) - (xterm-open-window display - (or geometry - (get-geometry display primary? instance class)) - (vector #f instance class)))) - -(define (get-geometry display primary? instance class) - (or (x-display-get-geometry display instance) - (let ((geometry (x-display-get-geometry display class))) - (and geometry - (if primary? geometry (strip-position-from-geometry geometry)))) - "80x40")) - -(define (x-display-get-geometry display key) - (or (x-display-get-default display key "geometry") - (x-display-get-default display key "Geometry"))) - -(define (strip-position-from-geometry geometry) - (let ((sign - (or (string-find-next-char geometry #\+) - (string-find-next-char geometry #\-)))) - (if sign - (string-head geometry sign) - geometry))) - -(define (x-root-window-size) - (x-display-get-size (or (get-x-display) (error "Unable to open display.")) - 0)) - -;;; According to the Xlib manual, we're not allowed to draw anything -;;; on the window until the first Expose event arrives. The manual -;;; says nothing about the relationship between this event and the -;;; MapNotify event associated with that mapping. We use the fields -;;; UNEXPOSED? and MAPPED? to track the arrival of those events. -;;; The screen's visibility remains 'UNMAPPED until both have arrived. -;;; Meanwhile, X-VISIBILITY tracks Visibility events. When the window -;;; is both exposed and mapped, VISIBILITY reflects X-VISIBILITY. - -(define (screen-x-visibility screen) - (xterm-screen-state/x-visibility (screen-state screen))) - -(define (set-screen-x-visibility! screen flag) - (set-xterm-screen-state/x-visibility! (screen-state screen) flag) - (update-visibility! screen)) - -(define (screen-mapped? screen) - (xterm-screen-state/mapped? (screen-state screen))) - -(define (set-screen-mapped?! screen flag) - (set-xterm-screen-state/mapped?! (screen-state screen) flag) - (update-visibility! screen)) - -(define (screen-unexposed? screen) - (xterm-screen-state/unexposed? (screen-state screen))) - -(define (set-screen-unexposed?! screen value) - (set-xterm-screen-state/unexposed?! (screen-state screen) value)) - -(define-integrable (screen-exposed? screen) - (not (screen-unexposed? screen))) - -(define (note-xterm-exposed xterm) - (let ((screen (xterm->screen xterm))) - (if screen - (let ((unexposed? (screen-unexposed? screen))) - (if unexposed? - (begin - (set-screen-unexposed?! screen #f) - (update-visibility! screen) - (if (eq? 'ENTERED unexposed?) - (xterm-screen/enter! screen)))))))) - -(define (update-visibility! screen) - (if (not (screen-deleted? screen)) - (set-screen-visibility! screen - (if (and (screen-mapped? screen) - (screen-exposed? screen)) - (screen-x-visibility screen) - 'UNMAPPED)))) - -(define (screen-xterm screen) - (xterm-screen-state/xterm (screen-state screen))) - -(define (xterm->screen xterm) - (let loop ((screens screen-list)) - (and (not (null? screens)) - (if (eq? xterm (screen-xterm (car screens))) - (car screens) - (loop (cdr screens)))))) - -(define (screen-display screen) - (xterm-screen-state/display (screen-state screen))) - -(define (screen-redisplay-flag screen) - (xterm-screen-state/redisplay-flag (screen-state screen))) - -(define (set-screen-redisplay-flag! screen flag) - (set-xterm-screen-state/redisplay-flag! (screen-state screen) flag)) - -(define (screen-selected? screen) - (xterm-screen-state/selected? (screen-state screen))) - -(define (set-screen-selected?! screen selected?) - (set-xterm-screen-state/selected?! (screen-state screen) selected?)) - -(define (screen-name screen) - (xterm-screen-state/name (screen-state screen))) - -(define (set-screen-name! screen name) - (set-xterm-screen-state/name! (screen-state screen) name)) - -(define (xterm-screen/set-name screen name) - (let ((name* (screen-name screen))) - (if (or (not name*) (not (string=? name name*))) - (begin - (set-screen-name! screen name) - (x-window-set-name (screen-xterm screen) name))))) - -(define (screen-icon-name screen) - (xterm-screen-state/icon-name (screen-state screen))) - -(define (set-screen-icon-name! screen name) - (set-xterm-screen-state/icon-name! (screen-state screen) name)) - -(define (xterm-screen/set-icon-name screen name) - (let ((name* (screen-icon-name screen))) - (if (or (not name*) (not (string=? name name*))) - (begin - (set-screen-icon-name! screen name) - (x-window-set-icon-name (screen-xterm screen) name))))) - -(define (xterm-screen/wrap-update! screen thunk) - (let ((finished? #f)) - (dynamic-wind - (lambda () - (xterm-enable-cursor (screen-xterm screen) #f)) - (lambda () - (let ((result (thunk))) - (set! finished? result) - result)) - (lambda () - (if (screen-selected? screen) - (let ((xterm (screen-xterm screen))) - (xterm-enable-cursor xterm #t) - (xterm-draw-cursor xterm))) - (if (and finished? (screen-redisplay-flag screen)) - (begin - (update-xterm-screen-names! screen) - (set-screen-redisplay-flag! screen #f))) - (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 #t)) - -(define (xterm-screen/enter! screen) - (if (screen-unexposed? screen) - (set-screen-unexposed?! screen 'ENTERED) - (begin - (set-screen-selected?! screen #t) - (let ((xterm (screen-xterm screen))) - (xterm-enable-cursor xterm #t) - (xterm-draw-cursor xterm)) - (xterm-screen/grab-focus! screen) - (xterm-screen/flush! screen)))) - -(define (xterm-screen/grab-focus! screen) - (and last-focus-time - (not (screen-deleted? screen)) - (screen-mapped? screen) - (begin - (x-window-set-input-focus (screen-xterm screen) last-focus-time) - #t))) - -(define (xterm-screen/exit! screen) - (set-screen-selected?! screen #f) - (let ((xterm (screen-xterm screen))) - (xterm-enable-cursor xterm #f) - (xterm-erase-cursor xterm)) - (xterm-screen/flush! screen)) - -(define (xterm-screen/scroll-lines-down! screen xl xu yl yu amount) - (xterm-scroll-lines-down (screen-xterm screen) xl xu yl yu amount) - 'UNCHANGED) - -(define (xterm-screen/scroll-lines-up! screen xl xu yl yu amount) - (xterm-scroll-lines-up (screen-xterm screen) xl xu yl yu amount) - 'UNCHANGED) - -(define (xterm-screen/beep screen) - (x-window-beep (screen-xterm screen)) - (xterm-screen/flush! screen)) - -(define (xterm-screen/flush! screen) - (x-display-flush (screen-display screen))) - -(define (xterm-screen/write-char! screen x y char highlight) - (xterm-write-char! (screen-xterm screen) x y char (if highlight 1 0))) - -(define (xterm-screen/write-cursor! screen x y) - (xterm-write-cursor! (screen-xterm screen) x y)) - -(define (xterm-screen/write-substring! screen x y string start end highlight) - (xterm-write-substring! (screen-xterm screen) x y string start end - (if highlight 1 0))) - -(define (xterm-screen/clear-line! screen x y first-unused-x) - (xterm-clear-rectangle! (screen-xterm screen) - x first-unused-x y (fix:1+ y) 0)) - -(define (xterm-screen/clear-rectangle! screen xl xu yl yu highlight) - (xterm-clear-rectangle! (screen-xterm screen) - xl xu yl yu (if highlight 1 0))) - -(define (xterm-screen/clear-screen! screen) - (xterm-clear-rectangle! (screen-xterm screen) - 0 (screen-x-size screen) 0 (screen-y-size screen) 0)) - -;;;; Event Handling + geometry + (error "Not yet autoloaded.")) (define (get-xterm-input-operations) - (let ((display x-display-data) - (queue x-display-events) - (pending-result #f) - (string #f) - (start 0) - (end 0)) - (let ((process-key-press-event - (lambda (event) - (set! last-focus-time (vector-ref event 5)) - (set! string (vector-ref event 2)) - (set! end (string-length string)) - (set! start end) - (cond ((fix:= end 0) - (x-make-special-key (vector-ref event 4) - (vector-ref event 3))) - ((fix:= end 1) - (let ((char - (merge-bucky-bits (string-ref string 0) - (vector-ref event 3)))) - (if (and signal-interrupts? (char=? char #\BEL)) - (begin - (signal-interrupt!) - #f) - char))) - (else - (let ((i - (and signal-interrupts? - (string-find-previous-char string #\BEL)))) - (if i - (begin - (set! start (fix:+ i 1)) - (signal-interrupt!) - (and (fix:< start end) - (let ((result (string-ref string start))) - (set! start (fix:+ start 1)) - result))) - (begin - (set! start 1) - (string-ref string 0))))))))) - (let ((process-event - (lambda (event) - (if (fix:= event-type:key-press (vector-ref event 0)) - (process-key-press-event event) - (process-special-event event)))) - (pce-event - (lambda (flag) - (make-input-event (if (eq? flag 'FORCE-RETURN) 'RETURN 'UPDATE) - update-screens! - #f)))) - (let ((get-next-event - (lambda (msec) - (let ((timeout (and msec (+ (real-time-clock) msec)))) - (let loop () - (let ((event (read-event queue display timeout))) - (cond ((or (not event) (input-event? event)) - event) - ((not (vector? event)) - (let ((flag (process-change-event event))) - (if flag - (pce-event flag) - (loop)))) - (else - (or (process-event event) - (loop)))))))))) - (let ((probe - (lambda (msec) - (let ((result (get-next-event msec))) - (if result - (set! pending-result result)) - result)))) - (values - (lambda () ;halt-update? - (or (fix:< start end) - (not (queue-empty? queue)))) - (lambda (msec) ;peek-no-hang - (or pending-result - (and (fix:< start end) - (string-ref string start)) - (probe msec))) - (lambda () ;peek - (or pending-result - (and (fix:< start end) - (string-ref string start)) - (probe #f))) - (lambda () ;read - (cond (pending-result - => (lambda (result) - (set! pending-result #f) - result)) - ((fix:< start end) - (let ((char (string-ref string start))) - (set! start (fix:+ start 1)) - char)) - (else - (or (get-next-event #f) - (error "#F returned from blocking read")))))))))))) - -(define (read-event queue display timeout) - (let* ((empty "empty") - (event* (with-thread-events-blocked - (lambda () - (if (queue-empty? queue) - empty - (dequeue!/unsafe queue))))) - (event (if (eq? event* empty) - (block-for-event display timeout) - event*))) - (if (and event trace-port) - (write-line event trace-port)) - event)) - -(define trace-port #f) - -(define (start-trace filename) - (stop-trace) - (set! trace-port (open-output-file filename)) - unspecific) - -(define (stop-trace) - (let ((port trace-port)) - (set! trace-port #f) - (if port (close-port port)))) - -(define (process-expose-event event) - (let ((xterm (vector-ref event 1))) - ;; If this is the first Expose event for this window, it - ;; requires special treatment. Element 6 of the event - ;; is 0 for Expose events and 1 for GraphicsExpose - ;; events. - (if (eq? 0 (vector-ref event 6)) - (note-xterm-exposed xterm)) - (xterm-dump-rectangle xterm - (vector-ref event 2) - (vector-ref event 3) - (vector-ref event 4) - (vector-ref event 5)))) - -(define (block-for-event display timeout) - display - (let ((queue x-display-events) - (output-available? #f) - (timed-out? #f) - (thread (current-thread)) - (timer) - (registrations)) - (let loop () - ;; IO events are not delivered when input lingers in port buffers. - ;; Incrementally drain the port before suspending. - (set! output-available? (accept-process-output)) - - (dynamic-wind - (lambda () - (set! timer - (and timeout - (register-time-event timeout - (lambda () - (set! timed-out? #t))))) - (set! registrations - (if output-available? - '() - (register-process-output-events - thread - (lambda (mode) - mode - (set! output-available? #t)))))) - (lambda () - (with-thread-events-blocked - (lambda () - - ;; Drain X event queue before suspending. Wait-for-event - ;; and throws from the previewer (aborts) may leave events - ;; in buffers. - (let drain () - (let ((event (x-display-process-events x-display-data 2))) - (if event - (begin (preview-event event queue) - (drain))))) - - (if (and (queue-empty? queue) - (not output-available?) - (not timed-out?) - (not (process-status-changes?)) - (not inferior-thread-changes?)) - (suspend-current-thread))))) - (lambda () - (if (eq? (current-thread) thread) - (begin - (if timer (deregister-time-event timer)) - (set! timer) - (for-each deregister-io-thread-event registrations) - (set! registrations))))) - - (or (with-thread-events-blocked - (lambda () - (and (not (queue-empty? queue)) - (dequeue!/unsafe queue)))) - (cond (timed-out? - #f) - ((process-status-changes?) - event:process-status) - (output-available? - event:process-output) - (inferior-thread-changes? - event:inferior-thread-output) - (else - (loop))))))) - -(define (preview-event-stream) - (with-thread-events-blocked - (lambda () - - (define (register!) - (set! previewer-registration - (register-io-thread-event (x-display-descriptor x-display-data) - 'READ (current-thread) preview-events)) - unspecific) - - (define (preview-events mode) - mode - (dynamic-wind - (lambda () unspecific) - (lambda () - (let loop () - (let ((event (x-display-process-events x-display-data 2))) - (if event - (begin (preview-event event x-display-events) - (loop)))))) - (lambda () - (if previewer-registration - (register!))))) - - (register!)))) - -(define (unpreview-event-stream) - (with-thread-events-blocked - (lambda () - (let ((registration previewer-registration)) - (set! previewer-registration #f) - (if registration - (deregister-io-thread-event registration)))))) - -(define (wait-for-event interval predicate process-event) - (let ((timeout (+ (real-time-clock) interval))) - (let loop () - (let ((event (x-display-process-events x-display-data 2))) - (if event - (if (and (vector? event) (predicate event)) - (or (process-event event) (loop)) - (begin (preview-event event x-display-events) (loop))) - ;; Busy loop! - (and (< (real-time-clock) timeout) - (loop))))))) - -(define (preview-event event queue) - (cond ((and signal-interrupts? - (vector? event) - (fix:= event-type:key-press (vector-ref event 0)) - (let ((string (vector-ref event 2))) - (if (fix:= 1 (string-length string)) - (char=? #\BEL - (merge-bucky-bits (string-ref string 0) - (vector-ref event 3))) - (string-find-next-char string #\BEL)))) - (clean-event-queue queue) - (signal-interrupt!)) - ((and (vector? event) - (fix:= event-type:expose (vector-ref event 0))) - (process-expose-event event)) - ((and (vector? event) - (or (fix:= event-type:map (vector-ref event 0)) - (fix:= event-type:unmap (vector-ref event 0)) - (fix:= event-type:visibility (vector-ref event 0)))) - (let ((result (process-special-event event))) - (if result - (enqueue!/unsafe queue result)))) - (else - (enqueue!/unsafe queue event)))) - -(define (clean-event-queue queue) - ;; Flush keyboard and mouse events from the input queue. Other - ;; events are harmless and must be processed regardless. - (do ((events (let loop () - (if (queue-empty? queue) - '() - (let ((event (dequeue!/unsafe queue))) - (if (and (vector? event) - (let ((type (vector-ref event 0))) - (or (fix:= type event-type:button-down) - (fix:= type event-type:button-up) - (fix:= type event-type:key-press) - (fix:= type event-type:motion)))) - (loop) - (cons event (loop)))))) - (cdr events))) - ((null? events)) - (enqueue!/unsafe queue (car events)))) - -(define (process-change-event event) - (cond ((fix:= event event:process-status) (handle-process-status-changes)) - ((fix:= event event:process-output) - (accept-process-output) - #t) - ((fix:= event event:inferior-thread-output) (accept-thread-output)) - (else (error "Illegal change event:" event)))) - -(define (process-special-event event) - (let ((handler (vector-ref event-handlers (vector-ref event 0)))) - (and handler - (if (vector-ref event 1) - (let ((screen (xterm->screen (vector-ref event 1)))) - (and screen - (handler screen event))) - (handler #f event))))) - -(define event-handlers - (make-vector number-of-event-types #f)) - -(define (define-event-handler event-type handler) - (vector-set! event-handlers event-type handler)) - -(define-event-handler event-type:button-down - (lambda (screen event) - (set! last-focus-time (vector-ref event 5)) - (if (eq? ignore-button-state 'IGNORE-BUTTON-DOWN) - (begin - (set! ignore-button-state 'IGNORE-BUTTON-UP) - #f) - (let ((xterm (screen-xterm screen))) - (make-input-event - 'BUTTON - execute-button-command - screen - (let ((n (vector-ref event 4))) - (make-down-button (fix:and n #x0FF) - (fix:lsh (fix:and n #xF00) -8))) - (xterm-map-x-coordinate xterm (vector-ref event 2)) - (xterm-map-y-coordinate xterm (vector-ref event 3))))))) - -(define-event-handler event-type:button-up - (lambda (screen event) - (set! last-focus-time (vector-ref event 5)) - (if (eq? ignore-button-state 'IGNORE-BUTTON-UP) - (begin - (set! ignore-button-state #f) - #f) - (let ((xterm (screen-xterm screen))) - (make-input-event - 'BUTTON - execute-button-command - screen - (let ((n (vector-ref event 4))) - (make-up-button (fix:and n #x0FF) - (fix:lsh (fix:and n #xF00) -8))) - (xterm-map-x-coordinate xterm (vector-ref event 2)) - (xterm-map-y-coordinate xterm (vector-ref event 3))))))) - -(define-event-handler event-type:configure - (lambda (screen event) - (make-input-event 'SET-SCREEN-SIZE - (lambda (screen event) - (let ((xterm (screen-xterm screen)) - (x-size (vector-ref event 2)) - (y-size (vector-ref event 3))) - (let ((x-size (xterm-map-x-size xterm x-size)) - (y-size (xterm-map-y-size xterm y-size))) - (xterm-reconfigure xterm x-size y-size) - (if (not (and (= x-size (screen-x-size screen)) - (= y-size (screen-y-size screen)))) - (begin - (set-screen-size! screen x-size y-size) - (update-screen! screen #t)))))) - screen event))) - -(define x-screen-ignore-focus-button? #f) - -(define-event-handler event-type:focus-in - (lambda (screen event) - event - (if x-screen-ignore-focus-button? - (set! ignore-button-state 'IGNORE-BUTTON-DOWN)) - (and (not (selected-screen? screen)) - (make-input-event 'SELECT-SCREEN - (lambda (screen) - (fluid-let ((last-focus-time #f)) - (select-screen screen))) - screen)))) - -(define-event-handler event-type:delete-window - (lambda (screen event) - event - (and (not (screen-deleted? screen)) - (make-input-event 'DELETE-SCREEN delete-screen! screen)))) - -;; Note that this handler is run in an interrupt (IO event). -(define-event-handler event-type:map - (lambda (screen event) - event - (and (not (screen-deleted? screen)) - (begin - (set-screen-mapped?! screen #t) - (screen-force-update screen) - (make-input-event 'UPDATE update-screen! screen #f))))) - -;; Note that this handler is run in an interrupt (IO event). -(define-event-handler event-type:unmap - (lambda (screen event) - event - (if (not (screen-deleted? screen)) - (set-screen-mapped?! screen #f)) - #f)) - -;; Note that this handler is run in an interrupt (IO event). -(define-event-handler event-type:visibility - (lambda (screen event) - (and (not (screen-deleted? screen)) - (let ((old-visibility (screen-x-visibility screen))) - (case (vector-ref event 2) - ((0) (set-screen-x-visibility! screen 'VISIBLE)) - ((1) (set-screen-x-visibility! screen 'PARTIALLY-OBSCURED)) - ((2) (set-screen-x-visibility! screen 'OBSCURED))) - (and (eq? old-visibility 'OBSCURED) - (begin - (screen-force-update screen) - (make-input-event 'UPDATE update-screen! screen #f))))))) - -(define-event-handler event-type:take-focus - (lambda (screen event) - (set! last-focus-time (vector-ref event 2)) - (make-input-event 'SELECT-SCREEN select-screen screen))) - -;;;; Atoms - -(define built-in-atoms - '#(#F - PRIMARY - SECONDARY - ARC - ATOM - BITMAP - CARDINAL - COLORMAP - CURSOR - CUT_BUFFER0 - CUT_BUFFER1 - CUT_BUFFER2 - CUT_BUFFER3 - CUT_BUFFER4 - CUT_BUFFER5 - CUT_BUFFER6 - CUT_BUFFER7 - DRAWABLE - FONT - INTEGER - PIXMAP - POINT - RECTANGLE - RESOURCE_MANAGER - RGB_COLOR_MAP - RGB_BEST_MAP - RGB_BLUE_MAP - RGB_DEFAULT_MAP - RGB_GRAY_MAP - RGB_GREEN_MAP - RGB_RED_MAP - STRING - VISUALID - WINDOW - WM_COMMAND - WM_HINTS - WM_CLIENT_MACHINE - WM_ICON_NAME - WM_ICON_SIZE - WM_NAME - WM_NORMAL_HINTS - WM_SIZE_HINTS - WM_ZOOM_HINTS - MIN_SPACE - NORM_SPACE - MAX_SPACE - END_SPACE - SUPERSCRIPT_X - SUPERSCRIPT_Y - SUBSCRIPT_X - SUBSCRIPT_Y - UNDERLINE_POSITION - UNDERLINE_THICKNESS - STRIKEOUT_ASCENT - STRIKEOUT_DESCENT - ITALIC_ANGLE - X_HEIGHT - QUAD_WIDTH - WEIGHT - POINT_SIZE - RESOLUTION - COPYRIGHT - NOTICE - FONT_NAME - FAMILY_NAME - FULL_NAME - CAP_HEIGHT - WM_CLASS - WM_TRANSIENT_FOR)) - -(define (symbol->x-atom display name soft?) - (or (hash-table-ref/default built-in-atoms-table name #f) - (let ((table (car (display/cached-atoms-tables display)))) - (or (hash-table-ref/default table name #f) - (let ((atom - (x-intern-atom display - (string-upcase (symbol->string name)) - soft?))) - (if (not (= atom 0)) - (hash-table-set! table name atom)) - atom))))) - -(define (x-atom->symbol display atom) - (if (< atom (vector-length built-in-atoms)) - (vector-ref built-in-atoms atom) - (let ((table (cdr (display/cached-atoms-tables display)))) - (or (hash-table-ref/default table atom #f) - (let ((symbol - (let ((string (x-get-atom-name display atom))) - (if (not (string? string)) - (error "X error (XGetAtomName):" string atom)) - (intern string)))) - (hash-table-set! table atom symbol) - symbol))))) - -(define built-in-atoms-table - (let ((n (vector-length built-in-atoms))) - (let ((table (make-strong-eq-hash-table n))) - (do ((i 0 (fix:+ i 1))) - ((fix:= i n)) - (hash-table-set! table (vector-ref built-in-atoms i) i)) - table))) - -(define display/cached-atoms-tables - (let ((table (make-key-weak-eq-hash-table))) - (lambda (display) - (or (hash-table-ref/default table display #f) - (let ((result - (cons (make-strong-eq-hash-table) - (make-strong-eqv-hash-table)))) - (hash-table-set! table display result) - result))))) - -;;;; Properties - -(define (get-xterm-property xterm property type delete?) - (get-window-property (x-window-display xterm) - (x-window-id xterm) - property - type - delete?)) - -(define (get-window-property display window property type delete?) - (let ((property (symbol->x-atom display property #f)) - (type-atom (symbol->x-atom display type #f))) - (let ((v (x-get-window-property display window property 0 0 #f type-atom))) - (and v - (vector-ref v 3) - (let ((data - (get-window-property-1 display window property delete? - (vector-ref v 0) - (vector-ref v 1) - (vector-ref v 2)))) - (if type - data - (cons (x-atom->symbol display (vector-ref v 0)) - data))))))) - -(define (get-window-property-1 display window property delete? - type format bytes) - (let ((read-once - (lambda (offset bytes n delete?) - (let ((v - (x-get-window-property display window property - (quotient offset 4) - (integer-ceiling n 4) - delete? type))) - (if (not (and v - (= type (vector-ref v 0)) - (= format (vector-ref v 1)) - (= (- bytes n) (vector-ref v 2)) - (vector-ref v 3) - (= n - (if (= format 8) - (string-length (vector-ref v 3)) - (* (vector-length (vector-ref v 3)) - (quotient format 8)))))) - (error "Window property changed:" v)) - (vector-ref v 3)))) - (qb (* (property-quantum display) 4))) - (if (<= bytes qb) - (read-once 0 bytes bytes delete?) - (let ((b/w (quotient format 8))) - (let ((result - (if (= b/w 1) - (make-string bytes) - (make-vector (quotient bytes b/w)))) - (copy! - (if (= b/w 1) - string-copy! - vector-copy!))) - (let loop ((offset 0) (bytes bytes)) - (if (<= bytes qb) - (copy! result - (quotient offset b/w) - (read-once offset bytes bytes delete?) - 0 - (quotient bytes b/w)) - (begin - (copy! result - (quotient offset b/w) - (read-once offset bytes qb #f) - 0 - (quotient qb b/w)) - (loop (+ offset qb) (- bytes qb))))) - result))))) - -(define (put-window-property display window property type format data) - (let ((put-1 - (let ((property (symbol->x-atom display property #f)) - (type (symbol->x-atom display type #f))) - (lambda (mode data) - (let ((status - (x-change-property display window property type format - mode data))) - (cond ((= status x-status:success) - #t) - ((= status x-status:bad-alloc) - (x-delete-property display window property) - #f) - (else - (error "X error (XChangeProperty):" status))))))) - (qw (property-quantum display)) - (i/w (quotient 32 format)) - (subpart (if (= format 8) substring subvector)) - (end (if (= format 8) (string-length data) (vector-length data))) - (mode:replace 0) - (mode:append 2)) - (let loop ((start 0) (nw (integer-ceiling end i/w)) (mode mode:replace)) - (if (<= nw qw) - (put-1 mode (if (= start 0) data (subpart data start end))) - (let ((end (+ start (* qw i/w)))) - (and (put-1 mode (subpart data start end)) - (loop end (- nw qw) mode:append))))))) - -(define (property-quantum display) - ;; The limit on the size of a property quantum is the maximum - ;; request size less the size of the largest header needed. The - ;; relevant packets are the GetProperty reply packet (header size 8) - ;; and the ChangeProperty request packet (header size 6). The magic - ;; number 8 is the larger of these two header sizes. - (fix:- (x-max-request-size display) 8)) - -(define (delete-xterm-property xterm property) - (delete-window-property (x-window-display xterm) - (x-window-id xterm) - property)) - -(define (delete-window-property display window property) - (x-delete-property display window (symbol->x-atom display property #f))) - -(define-integrable x-status:success 0) -(define-integrable x-status:bad-request 1) -(define-integrable x-status:bad-value 2) -(define-integrable x-status:bad-window 3) -(define-integrable x-status:bad-pixmap 4) -(define-integrable x-status:bad-atom 5) -(define-integrable x-status:bad-cursor 6) -(define-integrable x-status:bad-font 7) -(define-integrable x-status:bad-match 8) -(define-integrable x-status:bad-drawable 9) -(define-integrable x-status:bad-access 10) -(define-integrable x-status:bad-alloc 11) -(define-integrable x-status:bad-color 12) -(define-integrable x-status:bad-gc 13) -(define-integrable x-status:bad-id-choice 14) -(define-integrable x-status:bad-name 15) -(define-integrable x-status:bad-length 16) -(define-integrable x-status:bad-implementation 17) - -;;;; Selection Source - -(define-variable x-cut-to-clipboard - "If true, cutting text copies to the clipboard. -In either case, it is copied to the primary selection." - #t - boolean?) - -(define (os/interprogram-cut string context) - (if (eq? x-display-type (current-display-type)) - (let ((xterm (screen-xterm (selected-screen)))) - (let ((own-selection - (lambda (selection) - (own-selection (x-window-display xterm) - selection - (x-window-id xterm) - last-focus-time - string)))) - (own-selection 'PRIMARY) - (if (ref-variable x-cut-to-clipboard context) - (own-selection 'CLIPBOARD)))))) - -(define (own-selection display selection window time value) - (and (eqv? window - (let ((selection (symbol->x-atom display selection #f))) - (x-set-selection-owner display selection window time) - (x-get-selection-owner display selection))) - (begin - (hash-table-set! (display/selection-records display) - selection - (make-selection-record window time value)) - #t))) - -(define display/selection-records - (let ((table (make-key-weak-eq-hash-table))) - (lambda (display) - (or (hash-table-ref/default table display #f) - (let ((result (make-strong-eq-hash-table))) - (hash-table-set! table display result) - result))))) - -;;; In the next two procedures, we must allow TIME to be 0, even -;;; though the ICCCM forbids this, because existing clients use that -;;; value. An example of a broken client is GTK+ version 1.2.6. - -(define (display/selection-record display name time) - (let ((record - (hash-table-ref/default (display/selection-records display) name #f))) - (and record - (or (= 0 time) (<= (selection-record/time record) time)) - record))) - -(define (display/delete-selection-record! display name time) - (let ((records (display/selection-records display))) - (if (let ((record (hash-table-ref/default records name #f))) - (and record - (or (= 0 time) (<= (selection-record/time record) time)))) - (hash-table-delete! records name)))) - -(define-structure (selection-record (conc-name selection-record/)) - (window #f read-only #t) - (time #f read-only #t) - (value #f read-only #t)) - -(define-event-handler event-type:selection-request - (lambda (screen event) - screen - (let ((display x-display-data)) - (let ((requestor (selection-request/requestor event)) - (selection - (x-atom->symbol display (selection-request/selection event))) - (target - (x-atom->symbol display (selection-request/target event))) - (property - (x-atom->symbol display (selection-request/property event))) - (time (selection-request/time event))) - (let ((reply - (lambda (property) - (x-send-selection-notify display - requestor - (selection-request/selection event) - (selection-request/target event) - (symbol->x-atom display property #f) - time) - (x-display-flush display)))) - (if (let ((record (display/selection-record display selection time))) - (and record - property - (process-selection-request display requestor property - target time record #f))) - (reply property) - (reply #f))))) - #f)) - -(define-structure (selection-request (type vector) - (initial-offset 2) - (conc-name selection-request/)) - (requestor #f read-only #t) - (selection #f read-only #t) - (target #f read-only #t) - (property #f read-only #t) - (time #f read-only #t)) - -(define-event-handler event-type:selection-clear - (lambda (screen event) - screen - (let ((display x-display-data)) - (display/delete-selection-record! - display - (x-atom->symbol display (selection-clear/selection event)) - (selection-clear/time event))) - #f)) - -(define-structure (selection-clear (type vector) - (initial-offset 2) - (conc-name selection-clear/)) - (selection #f read-only #t) - (time #f read-only #t)) - -(define (process-selection-request display requestor property target time - record multiple?) - (let ((win - (lambda (format data) - (and (put-window-property display requestor property target format - data) - target)))) - (case target - ((STRING) - (win 8 (selection-record/value record))) - ((TARGETS) - (win 32 (atoms->property-data '(STRING TIMESTAMP) display))) - ((TIMESTAMP) - (win 32 (timestamp->property-data (selection-record/time record)))) - ((MULTIPLE) - (and multiple? - (let ((alist - (property-data->atom-alist - (or (get-window-property display requestor property - 'MULTIPLE #f) - (error "Missing MULTIPLE property:" property)) - display))) - (for-each (lambda (entry) - (set-car! entry - (process-selection-request display - requestor - (cdr entry) - (car entry) - time - record - #t))) - alist) - (win 32 (atom-alist->property-data alist display))))) - (else #f)))) - -(define (atoms->property-data names display) - (list->vector (map (lambda (name) (symbol->x-atom display name #f)) names))) - -(define (timestamp->property-data time) - (vector time)) - -(define (property-data->atom-alist data display) - (if (not (even? (vector-length data))) - (error:bad-range-argument data 'PROPERTY-DATA->ATOM-ALIST)) - (let loop ((atoms - (map (lambda (atom) (x-atom->symbol display atom)) - (vector->list data)))) - (if (null? atoms) - '() - (cons (cons (car atoms) (cadr atoms)) - (loop (cddr atoms)))))) - -(define (atom-alist->property-data alist display) - (atoms->property-data (let loop ((alist alist)) - (if (null? alist) - '() - (cons (caar alist) - (cons (cdar alist) - (loop (cdr alist)))))) - display)) - -;;;; Selection Sink - -(define-variable x-paste-from-clipboard - "If true, pasting text copies from the clipboard. -Otherwise, it is copied from the primary selection." - #t - boolean?) - -(define (os/interprogram-paste context) - (and (eq? x-display-type (current-display-type)) - (xterm/interprogram-paste (screen-xterm (selected-screen)) context))) - -(define (xterm/interprogram-paste xterm context) - (or (and (ref-variable x-paste-from-clipboard context) - (xterm/interprogram-paste-1 xterm 'CLIPBOARD)) - (xterm/interprogram-paste-1 xterm 'PRIMARY))) - -(define (xterm/interprogram-paste-1 xterm selection) - (with-thread-events-blocked - (lambda () - (let ((property '_EDWIN_TMP_) - (time last-focus-time)) - (cond ((display/selection-record (x-window-display xterm) - selection time) - => selection-record/value) - ((request-selection xterm selection 'STRING property time) - (receive-selection xterm property 'STRING time)) - ((request-selection xterm selection 'C_STRING property time) - (receive-selection xterm property 'C_STRING time)) - (else #f)))))) - -(define (request-selection xterm selection target property time) - (let ((display (x-window-display xterm)) - (window (x-window-id xterm))) - (let ((selection (symbol->x-atom display selection #f)) - (target (symbol->x-atom display target #f)) - (property (symbol->x-atom display property #f))) - (x-delete-property display window property) - (x-convert-selection display selection target property window time) - (x-display-flush display) - (eq? 'REQUEST-GRANTED - (wait-for-event x-selection-timeout - (lambda (event) - (fix:= event-type:selection-notify (vector-ref event 0))) - (lambda (event) - (and (= window (selection-notify/requestor event)) - (= selection (selection-notify/selection event)) - (= target (selection-notify/target event)) - (= time (selection-notify/time event)) - (if (= property (selection-notify/property event)) - 'REQUEST-GRANTED - 'REQUEST-DENIED)))))))) - -(define-structure (selection-notify (type vector) - (initial-offset 2) - (conc-name selection-notify/)) - (requestor #f read-only #t) - (selection #f read-only #t) - (target #f read-only #t) - (property #f read-only #t) - (time #f read-only #t)) - -(define (receive-selection xterm property target time) - (let ((value (get-xterm-property xterm property #f #t))) - (if (not value) - (error "Missing selection value.")) - (if (eq? 'INCR (car value)) - (receive-incremental-selection xterm property target time) - (and (eq? target (car value)) - (cdr value))))) - -(define (receive-incremental-selection xterm property target time) - ;; I have been unable to get this to work, after a day of hacking, - ;; and I don't have any idea why it won't work. Given that this - ;; will only be used for selections of size exceeding ~230kb, I'm - ;; going to leave it broken. -- cph - (x-window-flush xterm) - (let loop ((time time) (accum '())) - (let ((time - (wait-for-window-property-change xterm property time - x-property-state:new-value))) - (if (not time) - (error "Timeout waiting for PROPERTY-NOTIFY event.")) - (let ((value (get-xterm-property xterm property target #t))) - (if (not value) - (error "Missing property after PROPERTY-NOTIFY event.")) - (if (string-null? value) - (apply string-append (reverse! accum)) - (loop time (cons value accum))))))) - -(define (wait-for-window-property-change xterm property time state) - (wait-for-event x-selection-timeout - (lambda (event) - (fix:= event-type:property-notify (vector-ref event 0))) - (let ((property (symbol->x-atom (x-window-display xterm) property #f)) - (window (x-window-id xterm))) - (lambda (event) - (and (= window (property-notify/window event)) - (= property (property-notify/property event)) - (< time (property-notify/time event)) - (= state (property-notify/state event)) - (property-notify/time event)))))) - -(define-structure (property-notify (type vector) - (initial-offset 2) - (conc-name property-notify/)) - (window #f read-only #t) - (property #f read-only #t) - (time #f read-only #t) - (state #f read-only #t)) - -(define-integrable x-property-state:new-value 0) -(define-integrable x-property-state:delete 1) - -(define x-selection-timeout 5000) - -;;;; Interrupts - -(define signal-interrupts?) -(define last-focus-time) -(define previewer-registration) -(define ignore-button-state) + (error "Not yet autoloaded.")) (define (with-editor-interrupts-from-x receiver) - (fluid-let ((signal-interrupts? #t) - (last-focus-time #f) - (previewer-registration) - (ignore-button-state #f)) - (dynamic-wind - preview-event-stream - (lambda () (receiver (lambda (thunk) (thunk)) '())) - unpreview-event-stream))) + receiver + (error "Not yet autoloaded.")) (define (with-x-interrupts-enabled thunk) - (with-signal-interrupts #t thunk)) + thunk + (error "Not yet autoloaded.")) (define (with-x-interrupts-disabled thunk) - (with-signal-interrupts #f thunk)) - -(define (with-signal-interrupts enabled? thunk) - (let ((old)) - (dynamic-wind (lambda () - (set! old signal-interrupts?) - (set! signal-interrupts? enabled?) - unspecific) - thunk - (lambda () - (set! enabled? signal-interrupts?) - (set! signal-interrupts? old) - unspecific)))) - -(define (signal-interrupt!) - (editor-beep) - (temporary-message "Quit") - (^G-signal)) - -;;;; Initialization - -(define x-display-type) -(define x-display-data) -(define x-display-events) -(define x-display-name #f) - -(define (reset-x-display!) - (set! x-display-data #f) - (set! x-display-events) - unspecific) - -(define (get-x-display) - ;; X-OPEN-DISPLAY hangs, uninterruptibly, when the X server is - ;; running the login loop of xdm. Can this be fixed? - (or x-display-data - (and (begin - (load-library-object-file "prx11" #f) - (implemented-primitive-procedure? - (ucode-primitive x-open-display 1))) - (or x-display-name (get-environment-variable "DISPLAY")) - (let ((display - (x-open-display - (and x-display-name - (string-for-primitive x-display-name))))) - (set! x-display-data display) - (set! x-display-events (make-queue)) - display)))) - -(define (initialize-package!) - (set! screen-list '()) - (set! x-display-type - (make-display-type 'X - #t - get-x-display - make-xterm-screen - (lambda (screen) - screen ;ignore - (get-xterm-input-operations)) - with-editor-interrupts-from-x - with-x-interrupts-enabled - with-x-interrupts-disabled)) - (reset-x-display!) - (add-event-receiver! event:after-restore reset-x-display!) - unspecific) \ No newline at end of file + thunk + (error "Not yet autoloaded.")) \ No newline at end of file -- 2.25.1