From 432a7996e9eea2c9850ddcf4280bdc9966527a6a Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Thu, 9 Jun 2016 21:43:26 -0700 Subject: [PATCH] Punt microcode modules. --- src/berkeley-db/README | 5 + src/{runtime => berkeley-db}/berkeley-db.scm | 0 src/berkeley-db/configure.ac | 37 + src/{microcode => berkeley-db}/prdb4.c | 0 src/{microcode => berkeley-db}/prdb4.scm | 0 src/blowfish/README | 24 +- src/blowfish/blowfish.pkg | 5 +- src/blowfish/make.scm | 19 +- src/edwin/decls.scm | 8 +- src/edwin/ed-ffi.scm | 6 +- src/edwin/edwin.ldr | 7 +- src/edwin/edwin.pkg | 101 +- src/edwin/edwin.sf | 6 +- src/edwin/filcom.scm | 10 + src/edwin/fileio.scm | 6 +- src/edwin/key-x11.scm | 916 ------ src/edwin/kilcom.scm | 12 + src/edwin/nntp.scm | 10 +- src/edwin/xcom.scm | 346 --- src/edwin/xmodef.scm | 30 - src/edwin/xterm.scm | 1410 --------- src/gdbm/README | 21 +- src/gdbm/gdbm.pkg | 10 +- src/gdbm/make.scm | 2 +- src/imail/imail-mime.scm | 6 +- src/imail/imail.pkg | 1 + src/mcrypt/README | 27 +- src/mcrypt/make.scm | 26 +- src/mcrypt/mcrypt.pkg | 7 +- src/md5/README | 25 +- src/md5/make.scm | 14 +- src/md5/md5.pkg | 5 +- src/mhash/README | 27 +- src/mhash/make.scm | 34 +- src/mhash/mhash.pkg | 5 +- src/microcode/configure.ac | 271 -- src/microcode/liarc-ld.in | 2 +- src/microcode/makegen/Makefile.in.in | 39 +- src/microcode/makegen/files-optional.scm | 11 - src/microcode/ntutl/makefile | 12 +- src/microcode/ntutl/makefile.wcc | 8 +- src/microcode/prbfish.c | 299 -- src/microcode/prgdbm.c | 277 -- src/microcode/prmcrypt.c | 397 --- src/microcode/prmd5.c | 183 -- src/microcode/prmhash.c | 426 --- src/microcode/prx11.c | 54 - src/microcode/x11.h | 346 --- src/microcode/x11base.c | 2792 ------------------ src/microcode/x11color.c | 571 ---- src/microcode/x11graph.c | 1187 -------- src/microcode/x11term.c | 1021 ------- src/pgsql/README | 4 + src/pgsql/configure.ac | 49 + src/{microcode/prpgsql.c => pgsql/pgsql.c} | 0 src/pgsql/pgsql.pkg | 65 + src/{runtime => pgsql}/pgsql.scm | 0 src/runtime/Makefile-fragment | 4 +- src/runtime/blowfish.scm | 110 +- src/runtime/crypto.scm | 637 +--- src/runtime/ed-ffi.scm | 3 - src/runtime/gdbm.scm | 134 - src/runtime/krypt.scm | 9 +- src/runtime/make.scm | 1 - src/runtime/runtime.pkg | 229 +- src/runtime/x11graph.scm | 1030 ------- src/x11-screen/Makefile.am | 13 +- src/x11-screen/README | 19 +- src/x11-screen/compile.sh | 4 +- src/x11-screen/ed-ffi.scm | 4 +- src/x11-screen/make.scm | 64 +- src/x11-screen/x11-screen-check.sh | 4 +- src/x11-screen/x11-screen.pkg | 111 +- src/x11/README | 26 +- src/x11/make.scm | 111 +- src/x11/x11.pkg | 2 +- 76 files changed, 652 insertions(+), 13045 deletions(-) create mode 100644 src/berkeley-db/README rename src/{runtime => berkeley-db}/berkeley-db.scm (100%) create mode 100644 src/berkeley-db/configure.ac rename src/{microcode => berkeley-db}/prdb4.c (100%) rename src/{microcode => berkeley-db}/prdb4.scm (100%) delete mode 100644 src/edwin/key-x11.scm delete mode 100644 src/edwin/xcom.scm delete mode 100644 src/edwin/xmodef.scm delete mode 100644 src/edwin/xterm.scm delete mode 100644 src/microcode/prbfish.c delete mode 100644 src/microcode/prgdbm.c delete mode 100644 src/microcode/prmcrypt.c delete mode 100644 src/microcode/prmd5.c delete mode 100644 src/microcode/prmhash.c delete mode 100644 src/microcode/prx11.c delete mode 100644 src/microcode/x11.h delete mode 100644 src/microcode/x11base.c delete mode 100644 src/microcode/x11color.c delete mode 100644 src/microcode/x11graph.c delete mode 100644 src/microcode/x11term.c create mode 100644 src/pgsql/README create mode 100644 src/pgsql/configure.ac rename src/{microcode/prpgsql.c => pgsql/pgsql.c} (100%) create mode 100644 src/pgsql/pgsql.pkg rename src/{runtime => pgsql}/pgsql.scm (100%) delete mode 100644 src/runtime/gdbm.scm delete mode 100644 src/runtime/x11graph.scm diff --git a/src/berkeley-db/README b/src/berkeley-db/README new file mode 100644 index 000000000..a404bc9d1 --- /dev/null +++ b/src/berkeley-db/README @@ -0,0 +1,5 @@ +The BERKELEY-DB option. + +This plugin is incomplete. The accompanying files are just chunks of +code for the old microcode module prdb4 as cut out of microcode/ and +runtime/. diff --git a/src/runtime/berkeley-db.scm b/src/berkeley-db/berkeley-db.scm similarity index 100% rename from src/runtime/berkeley-db.scm rename to src/berkeley-db/berkeley-db.scm diff --git a/src/berkeley-db/configure.ac b/src/berkeley-db/configure.ac new file mode 100644 index 000000000..f5623434b --- /dev/null +++ b/src/berkeley-db/configure.ac @@ -0,0 +1,37 @@ + +AC_ARG_WITH([db-4], + AS_HELP_STRING([--with-db-4], + [Use Berkeley DB v4 library if available [[yes]]])) +: ${with_db_4='yes'} + + +dnl DB v4 support +if test "${with_db_4}" != no; then + if test "${with_db_4}" != yes; then + CPPFLAGS="${CPPFLAGS} -I${with_db_4}/include" + LDFLAGS="${LDFLAGS} -L${with_db_4}/lib" + fi + AC_CHECK_HEADER([db.h], + [ + AC_DEFINE([HAVE_DB_H], [1], + [Define to 1 if you have the header file.]) + AC_MSG_CHECKING([for db_create in -ldb-4]) + save_LIBS=${LIBS} + LIBS="${LIBS} -ldb-4" + AC_LINK_IFELSE( + [AC_LANG_PROGRAM( + [[#include ]], + [[db_create (0, 0, 0)]])], + [ + AC_MSG_RESULT([yes]) + AC_DEFINE([HAVE_LIBDB_4], [1], + [Define to 1 if you have the `db-4' library (-ldb-4).]) + MODULE_LIBS="-ldb-4 ${MODULE_LIBS}" + MODULE_BASES="${MODULE_BASES} prdb4" + ], + [ + AC_MSG_RESULT([no]) + ]) + LIBS=${save_LIBS} + ]) +fi diff --git a/src/microcode/prdb4.c b/src/berkeley-db/prdb4.c similarity index 100% rename from src/microcode/prdb4.c rename to src/berkeley-db/prdb4.c diff --git a/src/microcode/prdb4.scm b/src/berkeley-db/prdb4.scm similarity index 100% rename from src/microcode/prdb4.scm rename to src/berkeley-db/prdb4.scm diff --git a/src/blowfish/README b/src/blowfish/README index 3d283be3c..3ca0db084 100644 --- a/src/blowfish/README +++ b/src/blowfish/README @@ -1,17 +1,21 @@ The BLOWFISH option. -This is a drop-in replacement for the bfish microcode module and -runtime/blowfish.scm. It is not part of the core build and can be -built outside the core build tree in the customary way: +This plugin creates a (blowfish) package. It is built in the +customary GNU way: ./configure [--with-openssl=directory]... make all check install -The install target copies a shared library shim and compiled Scheme -files into the system library path, and re-writes the optiondb.scm -found there. You can override the default command name "mit-scheme" -(and thus the system library path) by setting MIT_SCHEME_EXE. +To load: -To use: (load-option 'BLOWFISH) and import the bindings you want. -They are not exported to the global environment because they would -conflict with the exports from (runtime blowfish). + (load-option 'BLOWFISH) + +To import into a CREF package set, add this to your .pkg file: + + (global-definitions blowfish/) + + (define-package (your package name) + (parent (your package parent)) + (import (blowfish) + blowfish-set-key + ...)) diff --git a/src/blowfish/blowfish.pkg b/src/blowfish/blowfish.pkg index e31f55421..f9131b850 100644 --- a/src/blowfish/blowfish.pkg +++ b/src/blowfish/blowfish.pkg @@ -29,8 +29,9 @@ USA. (define-package (blowfish) (files "blowfish") (parent ()) - ;; You'll have to import these from (global-definitions blowfish/). - ;; They are currently bound in () by exports from (runtime blowfish). + ;; These are "exported" to (runtime blowfish) during load-option. + ;; (blowfish global) gets them just so that CREF will report any + ;; that go missing. (export (blowfish global) blowfish-cbc blowfish-cfb64 diff --git a/src/blowfish/make.scm b/src/blowfish/make.scm index f47223977..80041e731 100644 --- a/src/blowfish/make.scm +++ b/src/blowfish/make.scm @@ -6,4 +6,21 @@ (lambda () (load-package-set "blowfish"))) -(add-subsystem-identification! "Blowfish" '(0 1)) \ No newline at end of file +(add-subsystem-identification! "Blowfish" '(0 1)) + +;; "Export" these to the (runtime blowfish) package bindings. +(let ((runtime (->environment '(runtime blowfish))) + (blowfish (->environment '(blowfish)))) + (for-each + (lambda (name) + (environment-assign! runtime name (environment-lookup blowfish name))) + '(blowfish-cbc + blowfish-cfb64 + blowfish-ecb + blowfish-encrypt-port + blowfish-file? + blowfish-ofb64 + blowfish-set-key + compute-blowfish-init-vector + read-blowfish-file-header + write-blowfish-file-header))) \ No newline at end of file diff --git a/src/edwin/decls.scm b/src/edwin/decls.scm index 65ee8377e..df13dc6db 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" @@ -99,8 +98,7 @@ USA. "utils" "win32" "winren" - "xform" - "xterm")) + "xform")) (sf-edwin "tterm" "termcap") (let ((includes '("struct" "comman" "modes" "buffer" "edtstr"))) (let loop ((files includes) (includes '())) @@ -230,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 96f5db0ff..5e3bb9376 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)) @@ -186,7 +185,4 @@ USA. ("window" (edwin window)) ("winout" (edwin window-output-port)) ("winren" (edwin)) - ("xcom" (edwin x-commands)) - ("xform" (edwin class-macros transform-instance-variables)) - ("xmodef" (edwin)) - ("xterm" (edwin screen x-screen)))) \ No newline at end of file + ("xform" (edwin class-macros transform-instance-variables)))) \ No newline at end of file diff --git a/src/edwin/edwin.ldr b/src/edwin/edwin.ldr index 012df60cd..e3a97fb2e 100644 --- a/src/edwin/edwin.ldr +++ b/src/edwin/edwin.ldr @@ -169,11 +169,7 @@ USA. (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 "key-x11" (->environment '(EDWIN X-KEYS))))) + (->environment '(EDWIN WIN32-KEYS))))) (load-case 'OS-TYPE '((UNIX . "process") @@ -183,7 +179,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 b299c5faf..2fc216a48 100644 --- a/src/edwin/edwin.pkg +++ b/src/edwin/edwin.pkg @@ -29,6 +29,9 @@ USA. (global-definitions "../runtime/runtime") (global-definitions "../xml/xml") (global-definitions "../sos/sos") +(global-definitions md5/) +(global-definitions blowfish/) +(global-definitions gdbm/) (define-package (edwin) (files "utils" @@ -1045,7 +1048,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 )) @@ -1059,102 +1061,7 @@ USA. edwin-command$dired-do-compress)) (extend-package (edwin process) - (files "process")) - - (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!))) + (files "process"))) ((nt) (global-definitions "../win32/win32") diff --git a/src/edwin/edwin.sf b/src/edwin/edwin.sf index 9b92cc7c9..455f586d2 100644 --- a/src/edwin/edwin.sf +++ b/src/edwin/edwin.sf @@ -26,11 +26,15 @@ USA. (load-option 'CREF) (load-option 'SOS) +(load-option 'XML) +(load-option 'MD5) +(load-option 'BLOWFISH) +(load-option 'GDBM) (if (not (name->package '(EDWIN))) (let ((package-set (package-set-pathname "edwin"))) (if (not (file-exists? package-set)) - (cref/generate-trivial-constructor "edwin")) + (cref/generate-trivial-constructor "edwin" #f)) (construct-packages-from-file (fasload package-set)))) (if (lexical-unreferenceable? (->environment '(EDWIN CLASS-CONSTRUCTOR)) diff --git a/src/edwin/filcom.scm b/src/edwin/filcom.scm index 2d2826707..7e35d98fc 100644 --- a/src/edwin/filcom.scm +++ b/src/edwin/filcom.scm @@ -654,6 +654,16 @@ Prefix arg means treat the plaintext file as binary data." (lambda (from to binary-plaintext?) (blowfish-decrypt-file from to binary-plaintext? #f))) +(define blowfish-available? + (let ((available? #f)) + (named-lambda (blowfish-available?) + (or available? + (let ((val (ignore-errors (lambda () (load-option 'blowfish))))) + (and (not (condition? val)) + (begin + (set! available? #t) + #t))))))) + (define (guarantee-blowfish-available) (if (not (blowfish-available?)) (editor-error "Blowfish encryption not supported on this system."))) diff --git a/src/edwin/fileio.scm b/src/edwin/fileio.scm index 0f5ef1323..dfa65e8ba 100644 --- a/src/edwin/fileio.scm +++ b/src/edwin/fileio.scm @@ -40,8 +40,10 @@ filename suffix \".bf\"." (define ((read/write-encrypted-file? write?) group pathname) (and (ref-variable enable-encrypted-files group) (equal? "bf" (pathname-type pathname)) - (md5-available?) - (blowfish-available?) + (ignore-errors (lambda () (load-option 'md5)) + (lambda (condition) condition #f)) + (ignore-errors (lambda () (load-option 'blowfish)) + (lambda (condition) condition #f)) (or write? (blowfish-file? pathname)) #t)) diff --git a/src/edwin/key-x11.scm b/src/edwin/key-x11.scm deleted file mode 100644 index 686773f7e..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 - 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 2d8568219..79621da60 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/nntp.scm b/src/edwin/nntp.scm index bd63a8194..73a20ce16 100644 --- a/src/edwin/nntp.scm +++ b/src/edwin/nntp.scm @@ -38,7 +38,15 @@ USA. (declare (usual-integrations)) -(load-option 'GDBM) +(define gdbm-available? + (let ((available? #f)) + (named-lambda (gdbm-available?) + (or available? + (let ((val (ignore-errors (lambda () (load-option 'GDBM))))) + (and (not (condition? val)) + (begin + (set! available? #t) + #t))))))) ;;;; NNTP Connection diff --git a/src/edwin/xcom.scm b/src/edwin/xcom.scm deleted file mode 100644 index ed7f54e6c..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 - 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-append 'EDWIN-COMMAND$X- name) - ,(close-syntax (symbol-append '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-append 'EDWIN-VARIABLE$X-SCREEN- name) - ,(close-syntax (symbol-append '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 90ee58513..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 - 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 deleted file mode 100644 index ca7a04845..000000000 --- a/src/edwin/xterm.scm +++ /dev/null @@ -1,1410 +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 - 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 Terminal -;;; Package: (edwin screen x-screen) - -(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)) - -(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 - -(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 (block?) - (let loop () - (let ((event (read-event queue display block?))) - (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 (block?) - (let ((result (get-next-event block?))) - (if result - (set! pending-result result)) - result))) - (guarantee-result - (lambda () - (or (get-next-event #t) - (error "#F returned from blocking read"))))) - (values - (lambda () ;halt-update? - (or pending-result - (fix:< start end) - (probe 'IN-UPDATE))) - (lambda (timeout) ;peek-no-hang - (keyboard-peek-busy-no-hang - (lambda () - (or pending-result - (and (fix:< start end) - (string-ref string start)) - (probe #f))) - timeout)) - (lambda () ;peek - (or pending-result - (if (fix:< start end) - (string-ref string start) - (let ((result (guarantee-result))) - (set! pending-result result) - result)))) - (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 - (guarantee-result))))))))))) - -(define (read-event queue display block?) - (preview-events display queue) - (let ((event - (if (queue-empty? queue) - (if (eq? 'IN-UPDATE block?) - #f - (read-event-1 display block?)) - (dequeue!/unsafe queue)))) - (if (and event trace-port) - (write-line event trace-port)) - event)) - -(define (preview-events display queue) - (let loop () - (let ((event (x-display-process-events display 2))) - (if event - (begin (preview-event event queue) - (loop)))))) - -(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 (read-event-1 display block?) - ;; Now consider other (non-X) events. - (if (eq? '#T block?) - (let loop () - (let ((event (block-for-event display))) - (or event - (loop)))) - (cond (inferior-thread-changes? - event:inferior-thread-output) - ((process-output-available?) - event:process-output) - ((process-status-changes?) - event:process-status) - (else #f)))) - -(define (block-for-event display) - (let ((x-events-available? #f) - (output-available? #f) - (registrations)) - (dynamic-wind - (lambda () - (let ((thread (current-thread))) - (set! registrations - (cons - (register-io-thread-event - (x-display-descriptor display) 'READ - thread (lambda (mode) - mode - (set! x-events-available? #t))) - (register-process-output-events - thread (lambda (mode) - mode - (set! output-available? #t))))))) - (lambda () - (let loop () - (with-thread-events-blocked - (lambda () - (if (and (not x-events-available?) - (not output-available?) - (not (process-status-changes?)) - (not inferior-thread-changes?)) - (suspend-current-thread)))) - (cond (x-events-available? - (let ((queue x-display-events)) - (preview-events display queue) - (if (queue-empty? queue) - #f - (dequeue!/unsafe queue)))) - ((process-status-changes?) - event:process-status) - (output-available? - event:process-output) - (inferior-thread-changes? - event:inferior-thread-output) - (else - (loop))))) - (lambda () - (for-each deregister-io-thread-event registrations) - (set! registrations))))) - -(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)) - ((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)))) - -(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))))) - -(define-event-handler event-type:unmap - (lambda (screen event) - event - (if (not (screen-deleted? screen)) - (set-screen-mapped?! screen #f)) - #f)) - -(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/get built-in-atoms-table name #f) - (let ((table (car (display/cached-atoms-tables display)))) - (or (hash-table/get table name #f) - (let ((atom - (x-intern-atom display - (string-upcase (symbol-name name)) - soft?))) - (if (not (= atom 0)) - (hash-table/put! 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/get 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/put! 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/put! table (vector-ref built-in-atoms i) i)) - table))) - -(define display/cached-atoms-tables - (let ((table (make-weak-eq-hash-table))) - (lambda (display) - (or (hash-table/get table display #f) - (let ((result - (cons (make-strong-eq-hash-table) - (make-strong-eqv-hash-table)))) - (hash-table/put! 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)))) - (move! - (if (= b/w 1) - substring-move-right! - subvector-move-right!))) - (let loop ((offset 0) (bytes bytes)) - (if (<= bytes qb) - (move! (read-once offset bytes bytes delete?) - 0 (quotient bytes b/w) - result (quotient offset b/w)) - (begin - (move! (read-once offset bytes qb #f) 0 (quotient qb b/w) - result (quotient offset 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/put! (display/selection-records display) - selection - (make-selection-record window time value)) - #t))) - -(define display/selection-records - (let ((table (make-weak-eq-hash-table))) - (lambda (display) - (or (hash-table/get table display #f) - (let ((result (make-strong-eq-hash-table))) - (hash-table/put! 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/get (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/get records name #f))) - (and record - (or (= 0 time) (<= (selection-record/time record) time)))) - (hash-table/remove! 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 ignore-button-state) - -(define (with-editor-interrupts-from-x receiver) - (fluid-let ((signal-interrupts? #t) - (last-focus-time #f) - (ignore-button-state #f)) - (receiver (lambda (thunk) (thunk)) '()))) - -(define (with-x-interrupts-enabled thunk) - (with-signal-interrupts #t thunk)) - -(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 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 diff --git a/src/gdbm/README b/src/gdbm/README index 026692005..f49a22d20 100644 --- a/src/gdbm/README +++ b/src/gdbm/README @@ -1,17 +1,16 @@ The GDBM option. -This is a drop-in replacement for the gdbm microcode module and -runtime/gdbm.scm. It is not part of the core build and can be built -outside the core build tree in the customary way: +This plugin creates a (gdbm) package, a drop-in replacement for the +obsolete (runtime gdbm) package. It is built in the customary GNU +way: - ./configure [--with-openssl=directory]... + ./configure ... make all check install -The install target copies a shared library shim and compiled Scheme -files into the system library path and re-writes the optiondb.scm -found there. You can override the default command name "mit-scheme" -(and thus the system library path) by setting MIT_SCHEME_EXE. +To load: -To use: (load-option 'GDBM2) and import the bindings you want. They -are not exported to the global environment because they would conflict -with the exports from (runtime gdbm). + (load-option 'GDBM) + +To import into a CREF package set, add this to your .pkg file: + + (global-definitions gdbm/) diff --git a/src/gdbm/gdbm.pkg b/src/gdbm/gdbm.pkg index 145b271b5..1c92f44fa 100644 --- a/src/gdbm/gdbm.pkg +++ b/src/gdbm/gdbm.pkg @@ -30,9 +30,7 @@ USA. (files "gdbm") (parent ()) (initialization (initialize-package!)) - ;; You'll have to import these from (global-definitions gdbm/). - ;; They are currently bound in () by exports from (runtime gdbm). - (export (gdbm global) + (export () gdbm-close gdbm-delete gdbm-exists? @@ -53,8 +51,4 @@ USA. gdbm_reader gdbm_replace gdbm_wrcreat - gdbm_writer)) - -(define-package (gdbm global) - ;; Just to get cref to analyze whether all exports are defined. - ) \ No newline at end of file + gdbm_writer)) \ No newline at end of file diff --git a/src/gdbm/make.scm b/src/gdbm/make.scm index 797efbb58..c704d7a19 100644 --- a/src/gdbm/make.scm +++ b/src/gdbm/make.scm @@ -6,4 +6,4 @@ (lambda () (load-package-set "gdbm"))) -(add-subsystem-identification! "GDBM2" '(0 1)) \ No newline at end of file +(add-subsystem-identification! "GDBM" '(0 1)) \ No newline at end of file diff --git a/src/imail/imail-mime.scm b/src/imail/imail-mime.scm index a2bb0172c..5fa69b508 100644 --- a/src/imail/imail-mime.scm +++ b/src/imail/imail-mime.scm @@ -370,8 +370,10 @@ USA. (mime:get-content-description header-fields) (mime:get-content-transfer-encoding header-fields) (- end start) - (ignore-errors (lambda () (md5-substring string start end)) - (lambda (condition) condition #f)) + (ignore-errors (lambda () + (load-option 'md5) + (md5-substring string start end)) + (lambda (condition) condition #f)) (mime:get-content-disposition header-fields) (mime:get-content-language header-fields)))) diff --git a/src/imail/imail.pkg b/src/imail/imail.pkg index 18073d46d..aee9305af 100644 --- a/src/imail/imail.pkg +++ b/src/imail/imail.pkg @@ -30,6 +30,7 @@ USA. (global-definitions "../sos/sos") (global-definitions "../edwin/edwin") (global-definitions "../star-parser/parser") +(global-definitions md5/) (define-package (edwin imail) (files "imail-util" diff --git a/src/mcrypt/README b/src/mcrypt/README index 7a73aaf9a..a50afd58c 100644 --- a/src/mcrypt/README +++ b/src/mcrypt/README @@ -1,18 +1,21 @@ The MCRYPT option. -This is a drop-in replacement for the mcrypt microcode module and the -mcrypt-* procedures in runtime/crypto.scm. It is not part of the core -build and can be built outside the core build tree in the customary -way: +This plugin creates an (mcrypt) package. It is built in the customary +GNU way: - ./configure + ./configure ... make all check install -The install target copies a shared library shim and compiled Scheme -files into the system library path and re-writes the optiondb.scm -found there. You can override the default command name "mit-scheme" -(and thus the system library path) by setting MIT_SCHEME_EXE. +To load: -To use: (load-option 'MCRYPT) and import the bindings you want. They -are not exported to the global environment because they would conflict -with the exports from (runtime crypto). + (load-option 'MCRYPT) + +To import into a CREF package set, add this to your .pkg file: + + (global-definitions mcrypt/) + + (define-package (your package name) + (parent (your package parent)) + (import (mcrypt) + guarantee-mcrypt-context + ...)) diff --git a/src/mcrypt/make.scm b/src/mcrypt/make.scm index 3769afb04..4105021bb 100644 --- a/src/mcrypt/make.scm +++ b/src/mcrypt/make.scm @@ -6,4 +6,28 @@ (lambda () (load-package-set "mcrypt"))) -(add-subsystem-identification! "mcrypt" '(0 1)) \ No newline at end of file +(add-subsystem-identification! "mcrypt" '(0 1)) + +;; "Export" these to the (runtime crypto) package bindings. +(let ((crypto (->environment '(runtime crypto))) + (mcrypt (->environment '(mcrypt)))) + (for-each + (lambda (name) + (environment-assign! crypto name (environment-lookup mcrypt name))) + '(mcrypt-algorithm-name + mcrypt-algorithm-names + mcrypt-block-algorithm-mode? + mcrypt-block-algorithm? + mcrypt-block-mode? + mcrypt-context? + mcrypt-encrypt + mcrypt-encrypt-port + mcrypt-end + mcrypt-init + mcrypt-init-vector-size + mcrypt-key-size + mcrypt-mode-name + mcrypt-mode-names + mcrypt-open-module + mcrypt-self-test + mcrypt-supported-key-sizes))) \ No newline at end of file diff --git a/src/mcrypt/mcrypt.pkg b/src/mcrypt/mcrypt.pkg index f536f003c..734fd3302 100644 --- a/src/mcrypt/mcrypt.pkg +++ b/src/mcrypt/mcrypt.pkg @@ -29,10 +29,9 @@ USA. (define-package (mcrypt) (files "mcrypt") (parent ()) - - ;; You'll have to import these from package (mcrypt). They are - ;; currently bound in () by exports from package (runtime crypto). - ;; Note that CREF will need "(global-definitions mcrypt/)". + ;; These are "exported" to (runtime crypto) during load-option. + ;; (mcrypt global) gets them just so that CREF will report any that + ;; go missing. (export (mcrypt global) mcrypt-algorithm-name mcrypt-algorithm-names diff --git a/src/md5/README b/src/md5/README index d3a4fdda3..1da8a7916 100644 --- a/src/md5/README +++ b/src/md5/README @@ -1,18 +1,21 @@ The MD5 option. -This is a drop-in replacement for the md5 microcode module and the -md5-* procedures in runtime/crypto.scm. It is not part of the core -build and can be built outside the core build tree in the customary -way: +This plugin creates an (md5) package. It is built in the customary +GNU way: ./configure [--with-openssl=directory]... make all check install -The install target copies a shared library shim and compiled Scheme -files into the system library path, and re-writes the optiondb.scm -found there. You can override the default command name "mit-scheme" -(and thus the system library path) by setting MIT_SCHEME_EXE. +To load: -To use: (load-option 'MD5) and import the bindings you want. They are -not exported to the global environment because they would conflict -with the exports from (runtime crypto). + (load-option 'MD5) + +To import into a CREF package set, add this to your .pkg file: + + (global-definitions md5/) + + (define-package (your package name) + (parent (your package parent)) + (import (md5) + guarantee-md5-context + ...)) diff --git a/src/md5/make.scm b/src/md5/make.scm index b84c650c3..fef938874 100644 --- a/src/md5/make.scm +++ b/src/md5/make.scm @@ -6,4 +6,16 @@ (lambda () (load-package-set "md5"))) -(add-subsystem-identification! "MD5" '(0 1)) \ No newline at end of file +(add-subsystem-identification! "MD5" '(0 1)) + +;; "Export" these to the (runtime crypto) package bindings. +(let ((crypto (->environment '(runtime crypto))) + (md5 (->environment '(md5)))) + (for-each + (lambda (name) + (environment-assign! crypto name (environment-lookup md5 name))) + '(md5-file + md5-string + md5-substring + md5-sum->hexadecimal + md5-sum->number))) \ No newline at end of file diff --git a/src/md5/md5.pkg b/src/md5/md5.pkg index a9a5e4e2d..b0ee1a60c 100644 --- a/src/md5/md5.pkg +++ b/src/md5/md5.pkg @@ -29,8 +29,9 @@ USA. (define-package (md5) (files "md5") (parent ()) - ;; You'll have to import these from (global-definitions md5/). They - ;; are currently bound in () by exports from (runtime crypto). + ;; These are "exported" to (runtime crypto) during load-option. + ;; (md5 global) gets them just so that CREF will report any that go + ;; missing. (export (md5 global) md5-file md5-string diff --git a/src/mhash/README b/src/mhash/README index f83f43d52..fc01080d8 100644 --- a/src/mhash/README +++ b/src/mhash/README @@ -1,18 +1,21 @@ The MHASH option. -This is a drop-in replacement for the mhash microcode module and the -mhash-* procedures in runtime/crypto.scm. It is not part of the core -build and can be built outside the core build tree in the customary -way: +This plugin creates an (mhash) package. It is built in the customary +GNU way: - ./configure [--with-mhash=directory]... + ./configure ... make all check install -The install target copies a shared library shim and compiled Scheme -files into the system library path, and re-writes the optiondb.scm -found there. You can override the default command name "mit-scheme" -(and thus the system library path) by setting MIT_SCHEME_EXE. +To load: -To use: (load-option 'MHASH) and import the bindings you want. They -are not exported to the global environment because they would conflict -with the exports from (runtime crypto). + (load-option 'MHASH) + +To import into a CREF package set, add this to your .pkg file: + + (global-definitions mhash/) + + (define-package (your package name) + (parent (your package parent)) + (import (mhash) + guarantee-mhash-hmac-context + ...)) diff --git a/src/mhash/make.scm b/src/mhash/make.scm index 9f2d5000f..d6e478fae 100644 --- a/src/mhash/make.scm +++ b/src/mhash/make.scm @@ -1,9 +1,39 @@ #| -*-Scheme-*- |# -;;;; Load the mhash option. +;;;; Load the MHASH option. (with-working-directory-pathname (directory-pathname (current-load-pathname)) (lambda () (load-package-set "mhash"))) -(add-subsystem-identification! "mhash" '(0 1)) \ No newline at end of file +(add-subsystem-identification! "mhash" '(0 1)) + +;; "Export" these to the (runtime crypto) package bindings. +(let ((crypto (->environment '(runtime crypto))) + (mhash (->environment '(mhash)))) + (for-each + (lambda (name) + (environment-assign! crypto name (environment-lookup mhash name))) + '(make-mhash-keygen-type + mhash-context? + mhash-end + mhash-file + mhash-get-block-size + mhash-hmac-end + mhash-hmac-init + mhash-hmac-update + mhash-init + mhash-keygen + mhash-keygen-max-key-size + mhash-keygen-salt-size + mhash-keygen-type-names + mhash-keygen-type? + mhash-keygen-uses-count? + mhash-keygen-uses-hash-algorithm + mhash-keygen-uses-salt? + mhash-string + mhash-substring + mhash-sum->hexadecimal + mhash-sum->number + mhash-type-names + mhash-update))) \ No newline at end of file diff --git a/src/mhash/mhash.pkg b/src/mhash/mhash.pkg index 183f3162f..b1285a172 100644 --- a/src/mhash/mhash.pkg +++ b/src/mhash/mhash.pkg @@ -30,8 +30,9 @@ USA. (files "mhash") (parent ()) (initialization (initialize-package!)) - ;; You'll have to import these from (global-definitions mhash/). - ;; They are currently bound in () by exports from (runtime crypto). + ;; These are "exported" to (runtime crypto) during load-option. + ;; (mhash global) gets them just so that CREF will report any that + ;; go missing. (export (mhash global) make-mhash-keygen-type mhash-context? diff --git a/src/microcode/configure.ac b/src/microcode/configure.ac index 42d8a5670..09806080c 100644 --- a/src/microcode/configure.ac +++ b/src/microcode/configure.ac @@ -134,36 +134,6 @@ AC_ARG_ENABLE([native-code], [Support native compiled code if available [[yes]]])) : ${enable_native_code='yes'} -AC_ARG_WITH([openssl], - AS_HELP_STRING([--with-openssl], - [Use OpenSSL crypto library if available [[yes]]])) -: ${with_openssl='yes'} - -AC_ARG_WITH([mhash], - AS_HELP_STRING([--with-mhash], - [Use mhash library if available [[yes]]])) -: ${with_mhash='yes'} - -AC_ARG_WITH([mcrypt], - AS_HELP_STRING([--with-mcrypt], - [Use mcrypt library if available [[yes]]])) -: ${with_mcrypt='yes'} - -AC_ARG_WITH([gdbm], - AS_HELP_STRING([--with-gdbm], - [Use gdbm library if available [[yes]]])) -: ${with_gdbm='yes'} - -AC_ARG_WITH([db-4], - AS_HELP_STRING([--with-db-4], - [Use Berkeley DB v4 library if available [[yes]]])) -: ${with_db_4='yes'} - -AC_ARG_WITH([libpq], - AS_HELP_STRING([--with-libpq], - [Use PostgreSQL libpq library if available [[yes]]])) -: ${with_libpq='yes'} - AC_ARG_WITH([termcap], AS_HELP_STRING([--with-termcap], [Use a termcap library if available [[yes]]])) @@ -185,18 +155,8 @@ GC_HEAD_FILES="gccode.h cmpgc.h cmpintmd-config.h cmpintmd.h" OPTIONAL_BASES= OPTIONAL_SOURCES= OPTIONAL_OBJECTS= -PRBFISH_LIBS= -PRMD5_LIBS= SCHEME_DEFS=-DMIT_SCHEME SCHEME_LDFLAGS= -MODULE_BASES= -MODULE_AUX_BASES= -MODULE_LIBS= -MODULE_TARGETS= -MODULE_RULES=/dev/null -MODULE_CFLAGS= -MODULE_LDFLAGS= -MODULE_LOADER= LIARC_VARS=/dev/null LIARC_RULES=/dev/null AUX_PROGRAMS= @@ -362,15 +322,6 @@ darwin*) CFLAGS="${CFLAGS} ${MACOSX_CFLAGS} -frounding-math" LDFLAGS="${LDFLAGS} ${MACOSX_CFLAGS} -Wl,-syslibroot,${MACOSX_SYSROOT}" LDFLAGS="${LDFLAGS} -framework CoreFoundation" - MODULE_LDFLAGS="${MODULE_LDFLAGS} -bundle" - if test "${with_module_loader}" != no; then - if test "${with_module_loader}" = yes; then - MODULE_LOADER='${SCHEME_EXE}' - else - MODULE_LOADER="${with_module_loader}" - fi - MODULE_LDFLAGS="${MODULE_LDFLAGS} -bundle_loader ${MODULE_LOADER}" - fi AUX_PROGRAMS="${AUX_PROGRAMS} macosx-starter" ;; netbsd*) @@ -396,8 +347,6 @@ if test "${DO_GCC_TESTS}" = yes; then if test "${GNU_LD}" = yes; then SCHEME_LDFLAGS="${SCHEME_LDFLAGS} -export-dynamic" fi - MODULE_CFLAGS="-fPIC ${MODULE_CFLAGS}" - MODULE_LDFLAGS="${MODULE_LDFLAGS} -shared -fPIC" AC_MSG_CHECKING([for ELF binaries]) AC_EGREP_CPP([yes], [ @@ -834,195 +783,6 @@ no) ;; esac -dnl The OpenSSL crypto library provides support for blowfish and MD5. -if test "${with_openssl}" != no; then - if test "${with_openssl}" != yes; then - CPPFLAGS="${CPPFLAGS} -I${with_openssl}/include" - LDFLAGS="${LDFLAGS} -L${with_openssl}/lib" - fi - FOUND= - AC_CHECK_HEADERS([openssl/blowfish.h openssl/md5.h], - [ - AC_CHECK_LIB([crypto], [BF_set_key], - [ - AC_DEFINE([HAVE_LIBCRYPTO], [1], - [Define to 1 if you have the `crypto' library (-lcrypto).]) - FOUND=yes - ]) - ]) - if test -n "${FOUND}"; then - MODULE_LIBS="-lcrypto ${MODULE_LIBS}" - MODULE_BASES="${MODULE_BASES} prbfish prmd5" - PRBFISH_LIBS="-lcrypto" - PRMD5_LIBS="-lcrypto" - fi -fi - -dnl These libraries might not be installed, so take care generating -dnl file dependencies using "makegen/makegen.scm" when called on -dnl "makegen/files-optional.scm". To wit, "prmhash.c" & "prmcrypt.c" -dnl must conditionalize their dependencies on & , -dnl respectively, to avoid warnings in "Makefile.deps" and its embeds. -dnl Finally, note that "prmd5.c" is similarly conditionalized as well. - -dnl The mhash library provides MD5 support. It can be loaded in addition -dnl to other MD5 libraries and provides a rich set of hashes. -if test "${with_mhash}" != no; then - if test "${with_mhash}" != yes; then - CPPFLAGS="${CPPFLAGS} -I${with_mhash}/include" - LDFLAGS="${LDFLAGS} -L${with_mhash}/lib" - fi - AC_CHECK_HEADER([mhash.h], - [ - AC_DEFINE([HAVE_MHASH_H], [1], - [Define to 1 if you have the header file.]) - AC_CHECK_LIB([mhash], [mhash_count], - [ - AC_DEFINE([HAVE_LIBMHASH], [1], - [Define to 1 if you have the `mhash' library (-lmhash).]) - if test ${enable_debugging} != no; then - LIBS="-lmhash ${LIBS}" - fi - MODULE_LIBS="-lmhash ${MODULE_LIBS}" - MODULE_BASES="${MODULE_BASES} prmhash" - if test "x${PRMD5_LIBS}" = x; then - PRMD5_LIBS="-lmhash" - fi - ]) - ]) -fi - -dnl The mcrypt library provides blowfish, but its CFB mode is 8 bit. -dnl We have been using 64-bit CFB, so this isn't really compatible. -dnl But mcrypt provides many ciphers and can be loaded in addition. -if test "${with_mcrypt}" != no; then - if test "${with_mcrypt}" != yes; then - CPPFLAGS="${CPPFLAGS} -I${with_mcrypt}/include" - LDFLAGS="${LDFLAGS} -L${with_mcrypt}/lib" - fi - AC_CHECK_HEADER([mcrypt.h], - [ - AC_DEFINE([HAVE_MCRYPT_H], [1], - [Define to 1 if you have the header file.]) - AC_CHECK_LIB([mcrypt], [mcrypt_generic_init], - [ - AC_DEFINE([HAVE_LIBMCRYPT], [1], - [Define to 1 if you have the `mcrypt' library (-lmcrypt).]) - MODULE_LIBS="-lmcrypt ${MODULE_LIBS}" - MODULE_BASES="${MODULE_BASES} prmcrypt" - ]) - ]) -fi - -dnl gdbm support -if test "${with_gdbm}" != no; then - if test "${with_gdbm}" != yes; then - CPPFLAGS="${CPPFLAGS} -I${with_gdbm}/include" - LDFLAGS="${LDFLAGS} -L${with_gdbm}/lib" - fi - AC_CHECK_HEADER([gdbm.h], - [ - AC_DEFINE([HAVE_GDBM_H], [1], - [Define to 1 if you have the header file.]) - AC_CHECK_LIB([gdbm], [gdbm_open], - [ - AC_DEFINE([HAVE_LIBGDBM], [1], - [Define to 1 if you have the `gdbm' library (-lgdbm).]) - MODULE_LIBS="-lgdbm ${MODULE_LIBS}" - MODULE_BASES="${MODULE_BASES} prgdbm" - ]) - ]) -fi - -dnl DB v4 support -if test "${with_db_4}" != no; then - if test "${with_db_4}" != yes; then - CPPFLAGS="${CPPFLAGS} -I${with_db_4}/include" - LDFLAGS="${LDFLAGS} -L${with_db_4}/lib" - fi - AC_CHECK_HEADER([db.h], - [ - AC_DEFINE([HAVE_DB_H], [1], - [Define to 1 if you have the header file.]) - AC_MSG_CHECKING([for db_create in -ldb-4]) - save_LIBS=${LIBS} - LIBS="${LIBS} -ldb-4" - AC_LINK_IFELSE( - [AC_LANG_PROGRAM( - [[#include ]], - [[db_create (0, 0, 0)]])], - [ - AC_MSG_RESULT([yes]) - AC_DEFINE([HAVE_LIBDB_4], [1], - [Define to 1 if you have the `db-4' library (-ldb-4).]) - MODULE_LIBS="-ldb-4 ${MODULE_LIBS}" - MODULE_BASES="${MODULE_BASES} prdb4" - ], - [ - AC_MSG_RESULT([no]) - ]) - LIBS=${save_LIBS} - ]) -fi - -dnl PostgreSQL support -if test "${with_libpq}" != no; then - if test "${with_libpq}" != yes; then - libpq_inc=${with_libpq}/include - libpq_lib=${with_libpq}/lib - else - AC_PATH_PROG([PG_CONFIG], [pg_config]) - if test "x${PG_CONFIG}" != x; then - libpq_inc=`${PG_CONFIG} --includedir 2>/dev/null` - libpq_lib=`${PG_CONFIG} --libdir 2>/dev/null` - else - if test -d /usr/include/postgresql; then - libpq_inc=/usr/include/postgresql - else - libpq_inc=/usr/include - fi - libpq_lib=/usr/lib - fi - fi - if test "x${libpq_inc}" != x; then - if test "${libpq_inc}" != /usr/include; then - CPPFLAGS="${CPPFLAGS} -I${libpq_inc}" - fi - fi - if test "x${libpq_lib}" != x; then - if test "${libpq_lib}" != /usr/lib; then - LDFLAGS="${LDFLAGS} -L${libpq_lib}" - fi - fi - AC_CHECK_HEADER([libpq-fe.h], - [ - AC_DEFINE([HAVE_LIBPQ_FE_H], [1], - [Define to 1 if you have the header file.]) - AC_CHECK_LIB([pq], [PQconnectdb], - [ - AC_DEFINE([HAVE_LIBPQ], [1], - [Define to 1 if you have the `pq' library (-lpq).]) - MODULE_LIBS="-lpq ${MODULE_LIBS}" - MODULE_BASES="${MODULE_BASES} prpgsql" - ]) - ]) -fi - -dnl Add support for X if present. -if test "${no_x}" != yes; then - if test "x${x_includes}" != x; then - FOO=-I`echo ${x_includes} | sed -e "s/:/ -I/g"` - CPPFLAGS="${CPPFLAGS} ${FOO}" - fi - if test "x${x_libraries}" != x; then - FOO=-L`echo ${x_libraries} | sed -e "s/:/ -L/g"` - LDFLAGS="${LDFLAGS} ${FOO}" - fi - MODULE_LIBS="-lX11 ${MODULE_LIBS}" - MODULE_BASES="${MODULE_BASES} prx11" - MODULE_AUX_BASES="${MODULE_AUX_BASES} x11base x11color x11graph x11term" -fi - dnl Check for dynamic loader support. AC_CHECK_FUNC([dlopen], [], @@ -1089,41 +849,14 @@ for base in ${OPTIONAL_BASES}; do OPTIONAL_OBJECTS="${OPTIONAL_OBJECTS} ${base}.o" done -if test "x${MODULE_BASES}" != x; then - MODULE_RULES=config-rules.module - rm -f ${MODULE_RULES} - for BASE in ${MODULE_BASES}; do - MODULE_TARGETS="${MODULE_TARGETS} ${BASE}.so" - MODULE_AUX_BASES="${MODULE_AUX_BASES} ${BASE}" - done - for BASE in ${MODULE_AUX_BASES}; do - echo >> ${MODULE_RULES} - echo ${BASE}.o: ${BASE}.c >> ${MODULE_RULES} - echo " " '$(COMPILE_MODULE)' -c '$*.c' >> ${MODULE_RULES} - done -fi -if test "x${MODULE_TARGETS}" != x; then - if test ! -e ../lib/lib; then mkdir ../lib/lib; fi - for BASE in ${MODULE_TARGETS}; do - ln -sf ../../microcode/${BASE} ../lib/lib/${BASE} - done -fi - AC_SUBST([AS_FLAGS]) AC_SUBST([GC_HEAD_FILES]) AC_SUBST([M4_FLAGS]) AC_SUBST([M4]) AC_SUBST([OPTIONAL_SOURCES]) AC_SUBST([OPTIONAL_OBJECTS]) -AC_SUBST([PRBFISH_LIBS]) -AC_SUBST([PRMD5_LIBS]) AC_SUBST([SCHEME_DEFS]) AC_SUBST([SCHEME_LDFLAGS]) -AC_SUBST([MODULE_TARGETS]) -AC_SUBST_FILE([MODULE_RULES]) -AC_SUBST([MODULE_CFLAGS]) -AC_SUBST([MODULE_LDFLAGS]) -AC_SUBST([MODULE_LOADER]) AC_SUBST_FILE([LIARC_VARS]) AC_SUBST_FILE([LIARC_RULES]) AC_SUBST([AUX_PROGRAMS]) @@ -1141,7 +874,3 @@ rm -f makegen-cc echo "#!/bin/sh" > makegen-cc echo exec gcc -MM -MG -DMIT_SCHEME ${CPPFLAGS} '"${1}"' >> makegen-cc chmod +x makegen-cc - -if test ${MODULE_RULES} != /dev/null; then - rm -f ${MODULE_RULES} -fi diff --git a/src/microcode/liarc-ld.in b/src/microcode/liarc-ld.in index 5a0f1fd85..a0d17e952 100644 --- a/src/microcode/liarc-ld.in +++ b/src/microcode/liarc-ld.in @@ -34,6 +34,6 @@ shift SCHEME_EXE=`dirname ${0}`/scheme -CMD="@CCLD@ @LDFLAGS@ @MODULE_LDFLAGS@ -o ${OUT} ${@}" +CMD="@CCLD@ @LDFLAGS@ -o ${OUT} ${@}" echo "${CMD}" eval "${CMD}" diff --git a/src/microcode/makegen/Makefile.in.in b/src/microcode/makegen/Makefile.in.in index 23be62010..4051be761 100644 --- a/src/microcode/makegen/Makefile.in.in +++ b/src/microcode/makegen/Makefile.in.in @@ -101,16 +101,6 @@ STD_OBJECTS = @(write-objects "files-core")@ \ GC_HEAD_FILES = @GC_HEAD_FILES@ OPTIONAL_SOURCES = @OPTIONAL_SOURCES@ OPTIONAL_OBJECTS = @OPTIONAL_OBJECTS@ -PRBFISH_LIBS = @PRBFISH_LIBS@ -PRMD5_LIBS = @PRMD5_LIBS@ - -MODULE_TARGETS = @MODULE_TARGETS@ -MODULE_CFLAGS = @MODULE_CFLAGS@ -MODULE_LDFLAGS = @MODULE_LDFLAGS@ -MODULE_LOADER = @MODULE_LOADER@ -COMPILE_MODULE = $(COMPILE) -DCOMPILE_AS_MODULE $(MODULE_CFLAGS) -LINK_MODULE = $(LINK) $(MODULE_LDFLAGS) -MODULE_LIBS = -lc # **** Rules for C back end (part 1, variables) **** @@ -119,7 +109,7 @@ MODULE_LIBS = -lc # **** Program definitions **** aux_PROGRAMS = @AUX_PROGRAMS@ -aux_LIBS = $(MODULE_TARGETS) +aux_LIBS = aux_DATA = @AUX_DATA@ EXTRA_PROGRAMS = findprim @@ -192,33 +182,6 @@ extract-liarc-decls: extract-liarc-decls.o macosx-starter: macosx-starter.o $(LINK) macosx-starter.o -prbfish.so: prbfish.o @MODULE_LOADER@ - $(LINK_MODULE) prbfish.o $(PRBFISH_LIBS) $(MODULE_LIBS) - -prmd5.so: prmd5.o @MODULE_LOADER@ - $(LINK_MODULE) prmd5.o $(PRMD5_LIBS) $(MODULE_LIBS) - -prmhash.so: prmhash.o @MODULE_LOADER@ - $(LINK_MODULE) prmhash.o -lmhash $(MODULE_LIBS) - -prmcrypt.so: prmcrypt.o @MODULE_LOADER@ - $(LINK_MODULE) prmcrypt.o -lmcrypt $(MODULE_LIBS) - -prgdbm.so: prgdbm.o @MODULE_LOADER@ - $(LINK_MODULE) prgdbm.o -lgdbm $(MODULE_LIBS) - -prdb4.so: prdb4.o @MODULE_LOADER@ - $(LINK_MODULE) prdb4.o -ldb-4 $(MODULE_LIBS) - -prpgsql.so: prpgsql.o @MODULE_LOADER@ - $(LINK_MODULE) prpgsql.o -lpq $(MODULE_LIBS) - -prx11.so: prx11.o x11base.o x11color.o x11graph.o x11term.o @MODULE_LOADER@ - $(LINK_MODULE) prx11.o x11base.o x11color.o x11graph.o x11term.o \ - -lX11 $(MODULE_LIBS) - -@MODULE_RULES@ - tags: TAGS TAGS: ./Tags.sh diff --git a/src/microcode/makegen/files-optional.scm b/src/microcode/makegen/files-optional.scm index 0dac0eea7..e4c45cc4d 100644 --- a/src/microcode/makegen/files-optional.scm +++ b/src/microcode/makegen/files-optional.scm @@ -28,21 +28,10 @@ USA. "cmpint" "comutl" -"prbfish" -"prgdbm" -"prmcrypt" -"prmd5" -"prmhash" -"prpgsql" "pruxdld" "pruxffi" -"prx11" "svm1-interp" "tterm" "termcap" "terminfo" "tparam" -"x11base" -"x11color" -"x11graph" -"x11term" diff --git a/src/microcode/ntutl/makefile b/src/microcode/ntutl/makefile index 727cd5436..02a561354 100644 --- a/src/microcode/ntutl/makefile +++ b/src/microcode/ntutl/makefile @@ -27,10 +27,6 @@ #### Makefile for Scheme under Win32 compiled by Microsoft Visual C++. !include -#USER_PRIM_SOURCES = prbfish.c prgdbm.c prmd5.c prpgsql.c -#USER_PRIM_OBJECTS = prbfish.obj prgdbm.obj prmd5.obj prpgsql.obj -#USER_LIBS = blowfish.lib gdbm.lib md5.lib pq.lib - # **** Microsoft supplies their assembler as a separate product, and # **** we don't currently have a copy, so use the Watcom assembler. # Assembler options. @@ -268,8 +264,8 @@ BCHSOURCES = $(CORE_SOURCES) $(BCH_GC_SOURCES) BCHOBJECTS = $(CORE_OBJECTS) $(BCH_GC_OBJECTS) $(NT_OBJECTS) \ $(OS_PRIM_OBJECTS) bchdef.obj -SCHEME_SOURCES = $(USER_PRIM_SOURCES) missing.c -SCHEME_OBJECTS = $(USER_PRIM_OBJECTS) missing.obj +SCHEME_SOURCES = missing.c +SCHEME_OBJECTS = missing.obj SCHEME_LIB = $(USER_LIBS) scheme: scheme.exe @@ -501,10 +497,6 @@ utils.obj: utils.c $(SCHEME_H) $(PRIMS_H) $(HISTORY_H) \ vector.obj: vector.c $(SCHEME_H) $(PRIMS_H) wind.obj: wind.c $(OBSTACK_H) $(DSTACK_H) $(OUTF_H) -prbfish.obj: prbfish.c $(SCHEME_H) $(PRIMS_H) -prgdbm.obj: prgdbm.c $(SCHEME_H) $(PRIMS_H) $(OS_H) -prmd5.obj: prmd5.c $(SCHEME_H) $(PRIMS_H) -prpgsql.obj: prpgsql.c $(SCHEME_H) $(PRIMS_H) $(USRDEF_H) $(OS_H) prosenv.obj: prosenv.c $(SCHEME_H) $(PRIMS_H) $(OSENV_H) $(OSTOP_H) $(LIMITS_H) prosfile.obj: prosfile.c $(SCHEME_H) $(PRIMS_H) $(OSFILE_H) prosfs.obj: prosfs.c $(SCHEME_H) $(PRIMS_H) $(OSFILE_H) $(OSFS_H) $(OSIO_H) diff --git a/src/microcode/ntutl/makefile.wcc b/src/microcode/ntutl/makefile.wcc index 686c6a53a..590378f6e 100644 --- a/src/microcode/ntutl/makefile.wcc +++ b/src/microcode/ntutl/makefile.wcc @@ -27,9 +27,7 @@ #### Makefile for Scheme under Win32 compiled by Watcom C/C++ ### This makefile is meant to be used with Watcom make. -USER_PRIM_SOURCES = # prbfish.c prgdbm.c prmd5.c prpgsql.c -USER_PRIM_OBJECTS = # prbfish.obj prgdbm.obj prmd5.obj prpgsql.obj -USER_LIBS = library wsock32.lib #,blowfish.lib,gdbm.lib,md5.lib,pq.lib +USER_LIBS = library wsock32.lib CC = wcc386 M4 = m4 @@ -290,8 +288,8 @@ utils.obj & vector.obj & wind.obj -SOURCES = $(CORE_SOURCES) $(USER_PRIM_SOURCES) -OBJECTS = $(CORE_OBJECTS) $(USER_PRIM_OBJECTS) usrdef.obj +SOURCES = $(CORE_SOURCES) +OBJECTS = $(CORE_OBJECTS) usrdef.obj SCHEME_LIB = $(USER_LIBS) scheme : scheme.exe .SYMBOLIC diff --git a/src/microcode/prbfish.c b/src/microcode/prbfish.c deleted file mode 100644 index 8464a3d33..000000000 --- a/src/microcode/prbfish.c +++ /dev/null @@ -1,299 +0,0 @@ -/* -*-C-*- - -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 - 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. - -*/ - -/* Interface to Blowfish library */ - -#include "scheme.h" -#include "prims.h" - -#if defined(HAVE_LIBCRYPTO) && defined(HAVE_OPENSSL_BLOWFISH_H) -# include -#else -# ifdef HAVE_BLOWFISH_H -# include -# endif -#endif - -/* This interface uses the Blowfish library from SSLeay. */ - -DEFINE_PRIMITIVE ("BLOWFISH-SET-KEY", Prim_blowfish_set_key, 1, 1, - "(STRING)\n\ -Generate a Blowfish key from STRING.\n\ -STRING must be 72 bytes or less in length.\n\ -For text-string keys, use MD5 on the text, and pass the digest here.") -{ - SCHEME_OBJECT string; - SCHEME_OBJECT result; - PRIMITIVE_HEADER (1); - - CHECK_ARG (1, STRING_P); - string = (ARG_REF (1)); - if ((STRING_LENGTH (string)) > 72) - error_bad_range_arg (1); - result = (allocate_string (sizeof (BF_KEY))); - BF_set_key (((BF_KEY *) (STRING_POINTER (result))), - (STRING_LENGTH (string)), - (STRING_BYTE_PTR (string))); - PRIMITIVE_RETURN (result); -} - -static BF_KEY * -key_arg (unsigned int arg) -{ - CHECK_ARG (arg, STRING_P); - if ((STRING_LENGTH (ARG_REF (arg))) != (sizeof (BF_KEY))) - error_bad_range_arg (arg); - return ((BF_KEY *) (STRING_BYTE_PTR (ARG_REF (arg)))); -} - -static unsigned char * -init_vector_arg (unsigned int arg) -{ - CHECK_ARG (arg, STRING_P); - if ((STRING_LENGTH (ARG_REF (arg))) != 8) - error_bad_range_arg (arg); - return (STRING_BYTE_PTR (ARG_REF (arg))); -} - -DEFINE_PRIMITIVE ("BLOWFISH-ECB", Prim_blowfish_ecb, 4, 4, - "(INPUT OUTPUT KEY-VECTOR ENCRYPT?)\n\ -Apply Blowfish in Electronic Code Book mode.\n\ -INPUT is an 8-byte string.\n\ -OUTPUT is an 8-byte string.\n\ -KEY is a Blowfish key.\n\ -ENCRYPT? says whether to encrypt (#T) or decrypt (#F).") -{ - SCHEME_OBJECT input_text; - SCHEME_OBJECT output_text; - PRIMITIVE_HEADER (4); - - CHECK_ARG (1, STRING_P); - input_text = (ARG_REF (1)); - if ((STRING_LENGTH (input_text)) != 8) - error_bad_range_arg (1); - CHECK_ARG (2, STRING_P); - output_text = (ARG_REF (2)); - if ((STRING_LENGTH (output_text)) != 8) - error_bad_range_arg (2); - BF_ecb_encrypt ((STRING_BYTE_PTR (input_text)), - (STRING_BYTE_PTR (output_text)), - (key_arg (3)), - ((BOOLEAN_ARG (4)) ? BF_ENCRYPT : BF_DECRYPT)); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("BLOWFISH-CBC-V2", Prim_blowfish_cbc, 5, 5, - "(INPUT OUTPUT KEY INIT-VECTOR ENCRYPT?)\n\ -Apply Blowfish in Cipher Block Chaining mode.\n\ -INPUT is a string whose length is a multiple of 8 bytes.\n\ -OUTPUT is a string whose length is the same as INPUT.\n\ -KEY is a Blowfish key.\n\ -INIT-VECTOR is an 8-byte string; it is modified after each call.\n\ - The value from any call may be passed in to a later call.\n\ -ENCRYPT? says whether to encrypt (#T) or decrypt (#F).") -{ - SCHEME_OBJECT input_text; - SCHEME_OBJECT output_text; - PRIMITIVE_HEADER (5); - - CHECK_ARG (1, STRING_P); - input_text = (ARG_REF (1)); - if (((STRING_LENGTH (input_text)) % 8) != 0) - error_bad_range_arg (1); - CHECK_ARG (2, STRING_P); - output_text = (ARG_REF (2)); - if ((output_text == input_text) - || ((STRING_LENGTH (output_text)) != (STRING_LENGTH (input_text)))) - error_bad_range_arg (2); - BF_cbc_encrypt ((STRING_BYTE_PTR (input_text)), - (STRING_BYTE_PTR (output_text)), - (STRING_LENGTH (input_text)), - (key_arg (3)), - (init_vector_arg (4)), - ((BOOLEAN_ARG (5)) ? BF_ENCRYPT : BF_DECRYPT)); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("BLOWFISH-CFB64-SUBSTRING-V2", Prim_blowfish_cfb64_substring, 9, 9, - "(INPUT ISTART IEND OUTPUT OSTART KEY INIT-VECTOR NUM ENCRYPT?)\n\ -Apply Blowfish in Cipher Feed-Back mode.\n\ -(INPUT,ISTART,IEND) is an arbitrary substring.\n\ -OUTPUT is a string as large as the input substring.\n\ -OSTART says where to start writing to the output string.\n\ -KEY is a Blowfish key.\n\ -INIT-VECTOR is an 8-byte string; it is modified after each call.\n\ - The value from any call may be passed in to a later call.\n\ - The initial value must be unique for each message/key pair.\n\ -NUM is a digit from 0 to 7 inclusive; it is the low 3 bits of the\n\ - number of bytes that have previously been processed in this stream.\n\ -ENCRYPT? says whether to encrypt (#T) or decrypt (#F).\n\ -Returned value is the new value of NUM.") -{ - SCHEME_OBJECT input_text; - unsigned long istart; - unsigned long iend; - unsigned long ilen; - SCHEME_OBJECT output_text; - unsigned long ostart; - int num; - PRIMITIVE_HEADER (9); - - CHECK_ARG (1, STRING_P); - input_text = (ARG_REF (1)); - { - unsigned long l = (STRING_LENGTH (input_text)); - istart = (arg_ulong_index_integer (2, l)); - iend = (arg_integer_in_range (3, istart, (l + 1))); - } - ilen = (iend - istart); - CHECK_ARG (4, STRING_P); - output_text = (ARG_REF (4)); - ostart = (arg_ulong_index_integer (5, (STRING_LENGTH (output_text)))); - if ((output_text == input_text) - && (ostart < iend) - && (istart < (ostart + ilen))) - error_bad_range_arg (4); - num = (arg_index_integer (8, 8)); - BF_cfb64_encrypt ((STRING_BYTE_PTR (input_text)), - (STRING_BYTE_PTR (output_text)), - ilen, - (key_arg (6)), - (init_vector_arg (7)), - (&num), - ((BOOLEAN_ARG (9)) ? BF_ENCRYPT : BF_DECRYPT)); - PRIMITIVE_RETURN (long_to_integer (num)); -} - -DEFINE_PRIMITIVE ("BLOWFISH-OFB64-SUBSTRING", Prim_blowfish_ofb64_substring, 8, 8, - "(INPUT ISTART IEND OUTPUT OSTART KEY INIT-VECTOR NUM)\n\ -Apply Blowfish in Output Feed-Back mode.\n\ -(INPUT,ISTART,IEND) is an arbitrary substring.\n\ -OUTPUT is a string as large as the input substring.\n\ -OSTART says where to start writing to the output string.\n\ -KEY is a Blowfish key.\n\ -INIT-VECTOR is an 8-byte string; it is modified after each call.\n\ - The value from any call may be passed in to a later call.\n\ - The initial value must be unique for each message/key pair.\n\ -NUM is a digit from 0 to 7 inclusive; it is the low 3 bits of the\n\ - number of bytes that have previously been processed in this stream.\n\ -Returned value is the new value of NUM.") -{ - SCHEME_OBJECT input_text; - unsigned long istart; - unsigned long iend; - unsigned long ilen; - SCHEME_OBJECT output_text; - unsigned long ostart; - int num; - PRIMITIVE_HEADER (8); - - CHECK_ARG (1, STRING_P); - input_text = (ARG_REF (1)); - { - unsigned long l = (STRING_LENGTH (input_text)); - istart = (arg_ulong_index_integer (2, l)); - iend = (arg_integer_in_range (3, istart, (l + 1))); - } - ilen = (iend - istart); - CHECK_ARG (4, STRING_P); - output_text = (ARG_REF (4)); - ostart = (arg_ulong_index_integer (5, (STRING_LENGTH (output_text)))); - if ((output_text == input_text) - && (ostart < iend) - && (istart < (ostart + ilen))) - error_bad_range_arg (4); - num = (arg_index_integer (8, 8)); - BF_ofb64_encrypt ((STRING_LOC (input_text, istart)), - (STRING_LOC (output_text, ostart)), - ilen, - (key_arg (6)), - (init_vector_arg (7)), - (&num)); - PRIMITIVE_RETURN (long_to_integer (num)); -} - -#ifdef COMPILE_AS_MODULE - -const char * -dload_initialize_file (void) -{ - declare_primitive - ("BLOWFISH-SET-KEY", Prim_blowfish_set_key, 1, 1, - "(STRING)\n\ -Generate a Blowfish key from STRING.\n\ -STRING must be 72 bytes or less in length.\n\ -For text-string keys, use MD5 on the text, and pass the digest here."); - declare_primitive - ("BLOWFISH-ECB", Prim_blowfish_ecb, 4, 4, - "(INPUT OUTPUT KEY-VECTOR ENCRYPT?)\n\ -Apply Blowfish in Electronic Code Book mode.\n\ -INPUT is an 8-byte string.\n\ -OUTPUT is an 8-byte string.\n\ -KEY is a Blowfish key.\n\ -ENCRYPT? says whether to encrypt (#T) or decrypt (#F)."); - declare_primitive - ("BLOWFISH-CBC-V2", Prim_blowfish_cbc, 5, 5, - "(INPUT OUTPUT KEY INIT-VECTOR ENCRYPT?)\n\ -Apply Blowfish in Cipher Block Chaining mode.\n\ -INPUT is a string whose length is a multiple of 8 bytes.\n\ -OUTPUT is a string whose length is the same as INPUT.\n\ -KEY is a Blowfish key.\n\ -INIT-VECTOR is an 8-byte string; it is modified after each call.\n\ - The value from any call may be passed in to a later call.\n\ -ENCRYPT? says whether to encrypt (#T) or decrypt (#F)."); - declare_primitive - ("BLOWFISH-CFB64-SUBSTRING-V2", Prim_blowfish_cfb64_substring, 9, 9, - "(INPUT ISTART IEND OUTPUT OSTART KEY INIT-VECTOR NUM ENCRYPT?)\n\ -Apply Blowfish in Cipher Feed-Back mode.\n\ -\(INPUT,ISTART,IEND) is an arbitrary substring.\n\ -OUTPUT is a string as large as the input substring.\n\ -OSTART says where to start writing to the output string.\n\ -KEY is a Blowfish key.\n\ -INIT-VECTOR is an 8-byte string; it is modified after each call.\n\ - The value from any call may be passed in to a later call.\n\ - The initial value must be unique for each message/key pair.\n\ -NUM is a digit from 0 to 7 inclusive; it is the low 3 bits of the\n\ - number of bytes that have previously been processed in this stream.\n\ -ENCRYPT? says whether to encrypt (#T) or decrypt (#F).\n\ -Returned value is the new value of NUM."); - declare_primitive - ("BLOWFISH-OFB64-SUBSTRING", Prim_blowfish_ofb64_substring, 8, 8, - "(INPUT ISTART IEND OUTPUT OSTART KEY INIT-VECTOR NUM)\n\ -Apply Blowfish in Output Feed-Back mode.\n\ -(INPUT,ISTART,IEND) is an arbitrary substring.\n\ -OUTPUT is a string as large as the input substring.\n\ -OSTART says where to start writing to the output string.\n\ -KEY is a Blowfish key.\n\ -INIT-VECTOR is an 8-byte string; it is modified after each call.\n\ - The value from any call may be passed in to a later call.\n\ - The initial value must be unique for each message/key pair.\n\ -NUM is a digit from 0 to 7 inclusive; it is the low 3 bits of the\n\ - number of bytes that have previously been processed in this stream.\n\ -Returned value is the new value of NUM."); - return "#prbfish"; -} - -#endif /* COMPILE_AS_MODULE */ diff --git a/src/microcode/prgdbm.c b/src/microcode/prgdbm.c deleted file mode 100644 index 515c8fb32..000000000 --- a/src/microcode/prgdbm.c +++ /dev/null @@ -1,277 +0,0 @@ -/* -*-C-*- - -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 - 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. - -*/ - -/* Interface to the gdbm database library */ - -#include "scheme.h" -#include "prims.h" -#include "os.h" - -#ifdef HAVE_GDBM_H -# include -#endif - -/* Allocation Tables */ - -struct allocation_table -{ - void ** items; - int length; -}; - -static void -allocation_table_initialize (struct allocation_table * table) -{ - (table -> length) = 0; -} - -static unsigned int -allocate_table_index (struct allocation_table * table, void * item) -{ - unsigned int length = (table -> length); - unsigned int new_length; - void ** items = (table -> items); - void ** new_items; - void ** scan; - void ** end; - if (length == 0) - { - new_length = 4; - new_items = (OS_malloc ((sizeof (void *)) * new_length)); - } - else - { - scan = items; - end = (scan + length); - while (scan < end) - if ((*scan++) == 0) - { - (*--scan) = item; - return (scan - items); - } - new_length = (length * 2); - new_items = (OS_realloc (items, ((sizeof (void *)) * new_length))); - } - scan = (new_items + length); - end = (new_items + new_length); - (*scan++) = item; - while (scan < end) - (*scan++) = 0; - (table -> items) = new_items; - (table -> length) = new_length; - return (length); -} - -static void * -allocation_item_arg (unsigned int arg, struct allocation_table * table) -{ - unsigned int index = (arg_ulong_index_integer (arg, (table -> length))); - void * item = ((table -> items) [index]); - if (item == 0) - error_bad_range_arg (arg); - return (item); -} - -static struct allocation_table dbf_table; - -#define DBF_VAL(dbf) \ - (ulong_to_integer (allocate_table_index ((&dbf_table), ((void *) (dbf))))) - -#define DBF_ARG(arg) \ - ((GDBM_FILE) (allocation_item_arg ((arg), (&dbf_table)))) - -#define GDBM_ERROR_VAL() \ - (char_pointer_to_string (gdbm_strerror (gdbm_errno))) - -#define VOID_GDBM_CALL(expression) \ - (((expression) == 0) ? SHARP_F : (GDBM_ERROR_VAL ())) - -static datum -arg_datum (int arg) -{ - datum d; - CHECK_ARG (arg, STRING_P); - (d . dptr) = (STRING_POINTER (ARG_REF (arg))); - (d . dsize) = (STRING_LENGTH (ARG_REF (arg))); - return (d); -} - -static SCHEME_OBJECT -datum_to_object (datum d) -{ - if (d . dptr) - { - SCHEME_OBJECT result = (allocate_string (d . dsize)); - const char * scan_d = (d . dptr); - const char * end_d = (scan_d + (d . dsize)); - char * scan_result = (STRING_POINTER (result)); - while (scan_d < end_d) - (*scan_result++) = (*scan_d++); - free (d . dptr); - return (result); - } - else - return (SHARP_F); -} - -static void -gdbm_fatal_error (const char * msg) -{ - outf_error ("\ngdbm: %s\n", msg); - outf_flush_error (); - error_external_return (); -} - -DEFINE_PRIMITIVE ("GDBM-OPEN", Prim_gdbm_open, 4, 4, 0) -{ - static int initialization_done = 0; - PRIMITIVE_HEADER (4); - if (!initialization_done) - { - allocation_table_initialize (&dbf_table); - initialization_done = 1; - } - { - GDBM_FILE dbf = (gdbm_open ((STRING_ARG (1)), - (arg_integer (2)), - (arg_integer (3)), - (arg_integer (4)), - gdbm_fatal_error)); - PRIMITIVE_RETURN ((dbf == 0) ? (GDBM_ERROR_VAL ()) : (DBF_VAL (dbf))); - } -} - -DEFINE_PRIMITIVE ("GDBM-CLOSE", Prim_gdbm_close, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - gdbm_close (DBF_ARG (1)); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("GDBM-STORE", Prim_gdbm_store, 4, 4, 0) -{ - PRIMITIVE_HEADER (4); - { - int result = (gdbm_store ((DBF_ARG (1)), - (arg_datum (2)), - (arg_datum (3)), - (arg_integer (4)))); - PRIMITIVE_RETURN - ((result < 0) ? (GDBM_ERROR_VAL ()) : (BOOLEAN_TO_OBJECT (!result))); - } -} - -DEFINE_PRIMITIVE ("GDBM-FETCH", Prim_gdbm_fetch, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - PRIMITIVE_RETURN - (datum_to_object (gdbm_fetch ((DBF_ARG (1)), (arg_datum (2))))); -} - -DEFINE_PRIMITIVE ("GDBM-EXISTS", Prim_gdbm_exists, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - PRIMITIVE_RETURN - (BOOLEAN_TO_OBJECT (gdbm_exists ((DBF_ARG (1)), (arg_datum (2))))); -} - -DEFINE_PRIMITIVE ("GDBM-DELETE", Prim_gdbm_delete, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - PRIMITIVE_RETURN - (((gdbm_delete ((DBF_ARG (1)), (arg_datum (2)))) == 0) - ? SHARP_T - : (gdbm_errno == GDBM_ITEM_NOT_FOUND) - ? SHARP_F - : (GDBM_ERROR_VAL ())); -} - -DEFINE_PRIMITIVE ("GDBM-FIRSTKEY", Prim_gdbm_firstkey, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - PRIMITIVE_RETURN (datum_to_object (gdbm_firstkey (DBF_ARG (1)))); -} - -DEFINE_PRIMITIVE ("GDBM-NEXTKEY", Prim_gdbm_nextkey, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - PRIMITIVE_RETURN - (datum_to_object (gdbm_nextkey ((DBF_ARG (1)), (arg_datum (2))))); -} - -DEFINE_PRIMITIVE ("GDBM-REORGANIZE", Prim_gdbm_reorganize, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - PRIMITIVE_RETURN (VOID_GDBM_CALL (gdbm_reorganize (DBF_ARG (1)))); -} - -DEFINE_PRIMITIVE ("GDBM-SYNC", Prim_gdbm_sync, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - gdbm_sync (DBF_ARG (1)); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("GDBM-VERSION", Prim_gdbm_version, 0, 0, 0) -{ - PRIMITIVE_HEADER (0); - PRIMITIVE_RETURN (char_pointer_to_string (gdbm_version)); -} - -DEFINE_PRIMITIVE ("GDBM-SETOPT", Prim_gdbm_setopt, 3, 3, 0) -{ - PRIMITIVE_HEADER (3); - { - int value = (arg_integer (3)); - PRIMITIVE_RETURN - (VOID_GDBM_CALL (gdbm_setopt ((DBF_ARG (1)), - (arg_integer (2)), - (&value), - (sizeof (int))))); - } -} - -#ifdef COMPILE_AS_MODULE - -char * -dload_initialize_file (void) -{ - declare_primitive ("GDBM-OPEN", Prim_gdbm_open, 4, 4, 0); - declare_primitive ("GDBM-CLOSE", Prim_gdbm_close, 1, 1, 0); - declare_primitive ("GDBM-STORE", Prim_gdbm_store, 4, 4, 0); - declare_primitive ("GDBM-FETCH", Prim_gdbm_fetch, 2, 2, 0); - declare_primitive ("GDBM-EXISTS", Prim_gdbm_exists, 2, 2, 0); - declare_primitive ("GDBM-DELETE", Prim_gdbm_delete, 2, 2, 0); - declare_primitive ("GDBM-FIRSTKEY", Prim_gdbm_firstkey, 1, 1, 0); - declare_primitive ("GDBM-NEXTKEY", Prim_gdbm_nextkey, 2, 2, 0); - declare_primitive ("GDBM-REORGANIZE", Prim_gdbm_reorganize, 1, 1, 0); - declare_primitive ("GDBM-SYNC", Prim_gdbm_sync, 1, 1, 0); - declare_primitive ("GDBM-VERSION", Prim_gdbm_version, 0, 0, 0); - declare_primitive ("GDBM-SETOPT", Prim_gdbm_setopt, 3, 3, 0); - return ("#prgdbm"); -} - -#endif /* COMPILE_AS_MODULE */ diff --git a/src/microcode/prmcrypt.c b/src/microcode/prmcrypt.c deleted file mode 100644 index 20c37b5e8..000000000 --- a/src/microcode/prmcrypt.c +++ /dev/null @@ -1,397 +0,0 @@ -/* -*-C-*- - -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 - 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. - -*/ - -/* Interface to mcrypt library */ - -#include "scheme.h" -#include "prims.h" -#include "usrdef.h" -#include "os.h" - -/* If mcrypt.h unavailable, ignore it. This helps - "makegen/makegen.scm" work properly on systems lacking this - library. */ -#ifdef HAVE_MCRYPT_H -# include -#endif - -static SCHEME_OBJECT -cp2s (char * cp) -{ - if (cp == 0) - return (SHARP_F); - else - { - SCHEME_OBJECT s = (char_pointer_to_string (cp)); - mcrypt_free (cp); - return (s); - } -} - -static size_t context_table_length = 0; -static MCRYPT * context_table = 0; - -static size_t -search_context_table (MCRYPT context) -{ - size_t i; - for (i = 0; (i < context_table_length); i += 1) - if ((context_table[i]) == context) - break; - return (i); -} - -static size_t -allocate_context_entry (void) -{ - size_t i = (search_context_table (0)); - if (i < context_table_length) - return (i); - if (i == 0) - { - context_table_length = 256; - context_table - = (OS_malloc ((sizeof (MCRYPT)) * context_table_length)); - } - else - { - context_table_length *= 2; - context_table - = (OS_realloc (context_table, - ((sizeof (MCRYPT)) * context_table_length))); - } - { - size_t j; - for (j = i; (j < context_table_length); j += 1) - (context_table[j]) = 0; - } - return (i); -} - -static SCHEME_OBJECT -store_context (MCRYPT context) -{ - if (context == MCRYPT_FAILED) - return (SHARP_F); - { - size_t i = (allocate_context_entry ()); - (context_table[i]) = context; - return (ulong_to_integer (i)); - } -} - -static void -forget_context (size_t index) -{ - (context_table[index]) = 0; -} - -static size_t -arg_context_index (unsigned int arg) -{ - unsigned long n = (arg_ulong_index_integer (arg, context_table_length)); - if ((context_table[n]) == 0) - error_bad_range_arg (arg); - return (n); -} - -static MCRYPT -arg_context (unsigned int arg) -{ - return (context_table [arg_context_index (arg)]); -} - -DEFINE_PRIMITIVE ("MCRYPT_MODULE_OPEN", Prim_mcrypt_module_open, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - PRIMITIVE_RETURN - (store_context - (mcrypt_module_open ((STRING_ARG (1)), 0, (STRING_ARG (2)), 0))); -} - -DEFINE_PRIMITIVE ("MCRYPT_GENERIC_INIT", Prim_mcrypt_generic_init, 3, 3, 0) -{ - PRIMITIVE_HEADER (3); - CHECK_ARG (2, STRING_P); - PRIMITIVE_RETURN - (long_to_integer - (mcrypt_generic_init ((arg_context (1)), - (STRING_POINTER (ARG_REF (2))), - (STRING_LENGTH (ARG_REF (2))), - (STRING_ARG (3))))); -} - -DEFINE_PRIMITIVE ("MCRYPT_GENERIC", Prim_mcrypt_generic, 4, 4, 0) -{ - PRIMITIVE_HEADER (4); - CHECK_ARG (2, STRING_P); - { - SCHEME_OBJECT string = (ARG_REF (2)); - unsigned long l = (STRING_LENGTH (string)); - unsigned long start = (arg_ulong_index_integer (3, l)); - unsigned long end = (arg_integer_in_range (4, start, (l + 1))); - PRIMITIVE_RETURN - (long_to_integer - (mcrypt_generic ((arg_context (1)), - (STRING_LOC (string, start)), - (end - start)))); - } -} - -DEFINE_PRIMITIVE ("MDECRYPT_GENERIC", Prim_mdecrypt_generic, 4, 4, 0) -{ - PRIMITIVE_HEADER (4); - CHECK_ARG (2, STRING_P); - { - SCHEME_OBJECT string = (ARG_REF (2)); - unsigned long l = (STRING_LENGTH (string)); - unsigned long start = (arg_ulong_index_integer (3, l)); - unsigned long end = (arg_integer_in_range (4, start, (l + 1))); - PRIMITIVE_RETURN - (long_to_integer - (mdecrypt_generic ((arg_context (1)), - (STRING_LOC (string, start)), - (end - start)))); - } -} - -DEFINE_PRIMITIVE ("MCRYPT_GENERIC_END", Prim_mcrypt_generic_end, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - { - size_t index = (arg_context_index (1)); - int result = (mcrypt_generic_end (context_table[index])); - forget_context (index); - PRIMITIVE_RETURN (long_to_integer (result)); - } -} - -#define CONTEXT_OPERATION(name, cvt_val) \ -{ \ - PRIMITIVE_HEADER (1); \ - PRIMITIVE_RETURN (cvt_val (name (arg_context (1)))); \ -} - -DEFINE_PRIMITIVE ("MCRYPT_ENC_SELF_TEST", Prim_mcrypt_enc_self_test, 1, 1, 0) - CONTEXT_OPERATION (mcrypt_enc_self_test, long_to_integer) - -DEFINE_PRIMITIVE ("MCRYPT_ENC_IS_BLOCK_ALGORITHM_MODE", Prim_mcrypt_enc_is_block_algorithm_mode, 1, 1, 0) - CONTEXT_OPERATION (mcrypt_enc_is_block_algorithm_mode, BOOLEAN_TO_OBJECT) - -DEFINE_PRIMITIVE ("MCRYPT_ENC_IS_BLOCK_ALGORITHM", Prim_mcrypt_enc_is_block_algorithm, 1, 1, 0) - CONTEXT_OPERATION (mcrypt_enc_is_block_algorithm, BOOLEAN_TO_OBJECT) - -DEFINE_PRIMITIVE ("MCRYPT_ENC_IS_BLOCK_MODE", Prim_mcrypt_enc_is_block_mode, 1, 1, 0) - CONTEXT_OPERATION (mcrypt_enc_is_block_mode, BOOLEAN_TO_OBJECT) - -DEFINE_PRIMITIVE ("MCRYPT_ENC_GET_KEY_SIZE", Prim_mcrypt_enc_get_key_size, 1, 1, 0) - CONTEXT_OPERATION (mcrypt_enc_get_key_size, long_to_integer) - -DEFINE_PRIMITIVE ("MCRYPT_ENC_GET_IV_SIZE", Prim_mcrypt_enc_get_iv_size, 1, 1, 0) - CONTEXT_OPERATION (mcrypt_enc_get_iv_size, long_to_integer) - -DEFINE_PRIMITIVE ("MCRYPT_ENC_GET_ALGORITHMS_NAME", Prim_mcrypt_enc_get_algorithms_name, 1, 1, 0) - CONTEXT_OPERATION (mcrypt_enc_get_algorithms_name, cp2s) - -DEFINE_PRIMITIVE ("MCRYPT_ENC_GET_MODES_NAME", Prim_mcrypt_enc_get_modes_name, 1, 1, 0) - CONTEXT_OPERATION (mcrypt_enc_get_modes_name, cp2s) - -#define MODULE_OPERATION(name, cvt_val) \ -{ \ - PRIMITIVE_HEADER (1); \ - PRIMITIVE_RETURN (cvt_val (name ((STRING_ARG (1)), 0))); \ -} - -DEFINE_PRIMITIVE ("MCRYPT_MODULE_SELF_TEST", Prim_mcrypt_module_self_test, 1, 1, 0) - MODULE_OPERATION (mcrypt_module_self_test, long_to_integer) - -DEFINE_PRIMITIVE ("MCRYPT_MODULE_IS_BLOCK_ALGORITHM_MODE", Prim_mcrypt_module_is_block_algorithm_mode, 1, 1, 0) - MODULE_OPERATION (mcrypt_module_is_block_algorithm_mode, BOOLEAN_TO_OBJECT) - -DEFINE_PRIMITIVE ("MCRYPT_MODULE_IS_BLOCK_ALGORITHM", Prim_mcrypt_module_is_block_algorithm, 1, 1, 0) - MODULE_OPERATION (mcrypt_module_is_block_algorithm, BOOLEAN_TO_OBJECT) - -DEFINE_PRIMITIVE ("MCRYPT_MODULE_IS_BLOCK_MODE", Prim_mcrypt_module_is_block_mode, 1, 1, 0) - MODULE_OPERATION (mcrypt_module_is_block_mode, BOOLEAN_TO_OBJECT) - -DEFINE_PRIMITIVE ("MCRYPT_MODULE_GET_ALGO_BLOCK_SIZE", Prim_mcrypt_module_get_algo_block_size, 1, 1, 0) - MODULE_OPERATION (mcrypt_module_get_algo_block_size, long_to_integer) - -DEFINE_PRIMITIVE ("MCRYPT_MODULE_GET_ALGO_KEY_SIZE", Prim_mcrypt_module_get_algo_key_size, 1, 1, 0) - MODULE_OPERATION (mcrypt_module_get_algo_key_size, long_to_integer) - -struct deallocate_list_arg -{ - char ** elements; - int n_elements; -}; - -static void -deallocate_list (void * environment) -{ - struct deallocate_list_arg * a = environment; - if ((a -> elements) != 0) - mcrypt_free_p ((a -> elements), (a -> n_elements)); -} - -#define LIST_ITEMS(name) \ -{ \ - PRIMITIVE_HEADER (0); \ - { \ - struct deallocate_list_arg a; \ - (a . elements) = (name (0, (& (a . n_elements)))); \ - transaction_begin (); \ - transaction_record_action (tat_always, deallocate_list, (&a)); \ - if ((a . n_elements) < 0) \ - error_external_return (); \ - { \ - char ** scan = (a . elements); \ - char ** end = (scan + (a . n_elements)); \ - SCHEME_OBJECT sa = (make_vector ((a . n_elements), SHARP_F, 1)); \ - SCHEME_OBJECT * scan_sa = (VECTOR_LOC (sa, 0)); \ - while (scan < end) \ - (*scan_sa++) = (char_pointer_to_string (*scan++)); \ - transaction_commit (); \ - PRIMITIVE_RETURN (sa); \ - } \ - } \ -} - -DEFINE_PRIMITIVE ("MCRYPT_LIST_ALGORITHMS", Prim_mcrypt_list_algorithms, 0, 0, 0) - LIST_ITEMS (mcrypt_list_algorithms) - -DEFINE_PRIMITIVE ("MCRYPT_LIST_MODES", Prim_mcrypt_list_modes, 0, 0, 0) - LIST_ITEMS (mcrypt_list_modes) - -static void -deallocate_key_sizes (void * environment) -{ - if (environment != 0) - mcrypt_free (environment); -} - -static SCHEME_OBJECT -convert_key_sizes (int * sizes, int n_sizes) -{ - transaction_begin (); - transaction_record_action (tat_always, deallocate_key_sizes, sizes); - if (n_sizes < 0) - error_external_return (); - if (n_sizes == 0) - { - transaction_commit (); - return (SHARP_F); - } - { - SCHEME_OBJECT sa = (make_vector (n_sizes, FIXNUM_ZERO, 1)); - SCHEME_OBJECT * scan_sa = (VECTOR_LOC (sa, 0)); - int * scan = sizes; - int * end = (scan + n_sizes); - while (scan < end) - (*scan_sa++) = (long_to_integer (*scan++)); - transaction_commit (); - return (sa); - } -} - -DEFINE_PRIMITIVE ("MCRYPT_ENC_GET_SUPPORTED_KEY_SIZES", Prim_mcrypt_enc_get_supported_key_sizes, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - { - int n_sizes; - int * sizes - = (mcrypt_enc_get_supported_key_sizes ((arg_context (1)), (&n_sizes))); - PRIMITIVE_RETURN (convert_key_sizes (sizes, n_sizes)); - } -} - -DEFINE_PRIMITIVE ("MCRYPT_MODULE_GET_ALGO_SUPPORTED_KEY_SIZES", Prim_mcrypt_module_get_algo_supported_key_sizes, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - { - int n_sizes; - int * sizes - = (mcrypt_module_get_algo_supported_key_sizes - ((STRING_ARG (1)), 0, (&n_sizes))); - PRIMITIVE_RETURN (convert_key_sizes (sizes, n_sizes)); - } -} - -#ifdef COMPILE_AS_MODULE - -char * -dload_initialize_file (void) -{ - declare_primitive - ("MCRYPT_MODULE_OPEN", Prim_mcrypt_module_open, 2, 2, 0); - declare_primitive - ("MCRYPT_GENERIC_INIT", Prim_mcrypt_generic_init, 3, 3, 0); - declare_primitive - ("MCRYPT_GENERIC", Prim_mcrypt_generic, 4, 4, 0); - declare_primitive - ("MDECRYPT_GENERIC", Prim_mdecrypt_generic, 4, 4, 0); - declare_primitive - ("MCRYPT_GENERIC_END", Prim_mcrypt_generic_end, 1, 1, 0); - declare_primitive - ("MCRYPT_ENC_SELF_TEST", Prim_mcrypt_enc_self_test, 1, 1, 0); - declare_primitive - ("MCRYPT_ENC_IS_BLOCK_ALGORITHM_MODE", Prim_mcrypt_enc_is_block_algorithm_mode, 1, 1, 0); - declare_primitive - ("MCRYPT_ENC_IS_BLOCK_ALGORITHM", Prim_mcrypt_enc_is_block_algorithm, 1, 1, 0); - declare_primitive - ("MCRYPT_ENC_IS_BLOCK_MODE", Prim_mcrypt_enc_is_block_mode, 1, 1, 0); - declare_primitive - ("MCRYPT_ENC_GET_KEY_SIZE", Prim_mcrypt_enc_get_key_size, 1, 1, 0); - declare_primitive - ("MCRYPT_ENC_GET_IV_SIZE", Prim_mcrypt_enc_get_iv_size, 1, 1, 0); - declare_primitive - ("MCRYPT_ENC_GET_ALGORITHMS_NAME", Prim_mcrypt_enc_get_algorithms_name, 1, 1, 0); - declare_primitive - ("MCRYPT_ENC_GET_MODES_NAME", Prim_mcrypt_enc_get_modes_name, 1, 1, 0); - declare_primitive - ("MCRYPT_MODULE_SELF_TEST", Prim_mcrypt_module_self_test, 1, 1, 0); - declare_primitive - ("MCRYPT_MODULE_IS_BLOCK_ALGORITHM_MODE", Prim_mcrypt_module_is_block_algorithm_mode, 1, 1, 0); - declare_primitive - ("MCRYPT_MODULE_IS_BLOCK_ALGORITHM", Prim_mcrypt_module_is_block_algorithm, 1, 1, 0); - declare_primitive - ("MCRYPT_MODULE_IS_BLOCK_MODE", Prim_mcrypt_module_is_block_mode, 1, 1, 0); - declare_primitive - ("MCRYPT_MODULE_GET_ALGO_BLOCK_SIZE", Prim_mcrypt_module_get_algo_block_size, 1, 1, 0); - declare_primitive - ("MCRYPT_MODULE_GET_ALGO_KEY_SIZE", Prim_mcrypt_module_get_algo_key_size, 1, 1, 0); - declare_primitive - ("MCRYPT_LIST_ALGORITHMS", Prim_mcrypt_list_algorithms, 0, 0, 0); - declare_primitive - ("MCRYPT_LIST_MODES", Prim_mcrypt_list_modes, 0, 0, 0); - declare_primitive - ("MCRYPT_ENC_GET_SUPPORTED_KEY_SIZES", Prim_mcrypt_enc_get_supported_key_sizes, 1, 1, 0); - declare_primitive - ("MCRYPT_MODULE_GET_ALGO_SUPPORTED_KEY_SIZES", Prim_mcrypt_module_get_algo_supported_key_sizes, 1, 1, 0); - return "#prmcrypt"; -} - -#endif /* COMPILE_AS_MODULE */ diff --git a/src/microcode/prmd5.c b/src/microcode/prmd5.c deleted file mode 100644 index f3ffc38c1..000000000 --- a/src/microcode/prmd5.c +++ /dev/null @@ -1,183 +0,0 @@ -/* -*-C-*- - -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 - 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. - -*/ - -/* Interface to MD5 library */ - -#include "scheme.h" -#include "prims.h" - -#if defined(HAVE_LIBCRYPTO) && defined(HAVE_OPENSSL_MD5_H) -# include -#else -# ifdef HAVE_MD5_H -# include -# endif -#endif - -#ifdef HAVE_LIBCRYPTO -# define MD5_INIT MD5_Init -# define MD5_UPDATE MD5_Update -# define MD5_FINAL MD5_Final -#else -# define MD5_INIT MD5Init -# define MD5_UPDATE MD5Update -# define MD5_FINAL MD5Final -# define MD5_DIGEST_LENGTH 16 -#endif - -DEFINE_PRIMITIVE ("MD5", Prim_md5, 1, 1, - "(STRING)\n\ -Generate an MD5 digest of string.\n\ -The digest is returned as a 16-byte string.") -{ - PRIMITIVE_HEADER (1); - CHECK_ARG (1, STRING_P); - { - SCHEME_OBJECT string = (ARG_REF (1)); - SCHEME_OBJECT result = (allocate_string (16)); - unsigned char * scan_result = (STRING_BYTE_PTR (result)); - MD5_CTX context; -#ifdef HAVE_LIBCRYPTO - unsigned char digest [MD5_DIGEST_LENGTH]; -#endif - unsigned char * scan_digest; - unsigned char * end_digest; - - MD5_INIT (&context); - MD5_UPDATE ((&context), - (STRING_POINTER (string)), - (STRING_LENGTH (string))); -#ifdef HAVE_LIBCRYPTO - MD5_FINAL (digest, (&context)); - scan_digest = digest; -#else - MD5_FINAL (&context); - scan_digest = (context . digest); -#endif - end_digest = (scan_digest + MD5_DIGEST_LENGTH); - while (scan_digest < end_digest) - (*scan_result++) = (*scan_digest++); - PRIMITIVE_RETURN (result); - } -} - -DEFINE_PRIMITIVE ("MD5-INIT", Prim_md5_init, 0, 0, - "()\n\ -Create and return an MD5 digest context.") -{ - PRIMITIVE_HEADER (0); - { - SCHEME_OBJECT context = (allocate_string (sizeof (MD5_CTX))); - MD5_INIT ((MD5_CTX *) (STRING_POINTER (context))); - PRIMITIVE_RETURN (context); - } -} - -static MD5_CTX * -md5_context_arg (int arg) -{ - CHECK_ARG (arg, STRING_P); - if ((STRING_LENGTH (ARG_REF (arg))) != (sizeof (MD5_CTX))) - error_bad_range_arg (arg); - return ((MD5_CTX *) (STRING_POINTER (ARG_REF (arg)))); -} - -DEFINE_PRIMITIVE ("MD5-UPDATE", Prim_md5_update, 4, 4, - "(CONTEXT STRING START END)\n\ -Update CONTEXT with the contents of the substring (STRING,START,END).") -{ - PRIMITIVE_HEADER (4); - CHECK_ARG (2, STRING_P); - { - SCHEME_OBJECT string = (ARG_REF (2)); - unsigned long end - = (arg_ulong_index_integer (4, ((STRING_LENGTH (string)) + 1))); - unsigned long start = (arg_ulong_index_integer (3, (end + 1))); - MD5_UPDATE ((md5_context_arg (1)), - (STRING_LOC (string, start)), - (end - start)); - PRIMITIVE_RETURN (UNSPECIFIC); - } -} - -DEFINE_PRIMITIVE ("MD5-FINAL", Prim_md5_final, 1, 1, - "(CONTEXT)\n\ -Finalize CONTEXT and return the digest as a 16-byte string.") -{ - PRIMITIVE_HEADER (1); - { - MD5_CTX * context = (md5_context_arg (1)); -#ifdef HAVE_LIBCRYPTO - unsigned char digest [MD5_DIGEST_LENGTH]; - MD5_FINAL (digest, context); -#else - MD5_FINAL (context); -#endif - { - SCHEME_OBJECT result = (allocate_string (MD5_DIGEST_LENGTH)); - unsigned char * scan_result = (STRING_BYTE_PTR (result)); -#ifdef HAVE_LIBCRYPTO - unsigned char * scan_digest = digest; -#else - unsigned char * scan_digest = (context -> digest); -#endif - unsigned char * end_digest = (scan_digest + MD5_DIGEST_LENGTH); - while (scan_digest < end_digest) - (*scan_result++) = (*scan_digest++); - PRIMITIVE_RETURN (result); - } - } -} - -#ifdef COMPILE_AS_MODULE - -const char * -dload_initialize_file (void) -{ - declare_primitive - ("MD5", Prim_md5, 1, 1, - "(STRING)\n\ -Generate an MD5 digest of string.\n\ -The digest is returned as a 16-byte string."); - - declare_primitive - ("MD5-INIT", Prim_md5_init, 0, 0, - "()\n\ -Create and return an MD5 digest context."); - - declare_primitive - ("MD5-UPDATE", Prim_md5_update, 4, 4, - "(CONTEXT STRING START END)\n\ -Update CONTEXT with the contents of the substring (STRING,START,END)."); - - declare_primitive - ("MD5-FINAL", Prim_md5_final, 1, 1, - "(CONTEXT)\n\ -Finalize CONTEXT and return the digest as a 16-byte string."); - return "#prmd5"; -} - -#endif /* COMPILE_AS_MODULE */ diff --git a/src/microcode/prmhash.c b/src/microcode/prmhash.c deleted file mode 100644 index 7a01cc49a..000000000 --- a/src/microcode/prmhash.c +++ /dev/null @@ -1,426 +0,0 @@ -/* -*-C-*- - -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 - 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. - -*/ - -/* Interface to mhash library */ - -#include "scheme.h" -#include "prims.h" -#include "usrdef.h" -#include "os.h" - -/* If mhash.h unavailable, ignore it. This helps - "makegen/makegen.scm" work properly on systems lacking this - library. */ -#ifdef HAVE_MHASH_H -# include -#endif - -#define UNARY_OPERATION(name, get_arg, cvt_val) \ -{ \ - PRIMITIVE_HEADER (1); \ - PRIMITIVE_RETURN (cvt_val (name (get_arg (1)))); \ -} - -static SCHEME_OBJECT -cp2s (void * cp) -{ - if (cp == 0) - return (SHARP_F); - else - { - SCHEME_OBJECT s = (char_pointer_to_string (cp)); - free (cp); - return (s); - } -} - -typedef struct -{ - MHASH context; - hashid id; -} context_entry; - -static size_t context_table_length = 0; -static context_entry * context_table = 0; - -static size_t -search_context_table (MHASH context) -{ - size_t i; - for (i = 0; (i < context_table_length); i += 1) - if (((context_table[i]) . context) == context) - break; - return (i); -} - -static size_t -allocate_context_entry (void) -{ - size_t i = (search_context_table (0)); - if (i < context_table_length) - return (i); - if (i == 0) - { - context_table_length = 256; - context_table - = (OS_malloc ((sizeof (context_entry)) * context_table_length)); - } - else - { - context_table_length *= 2; - context_table - = (OS_realloc (context_table, - ((sizeof (context_entry)) * context_table_length))); - } - { - size_t j; - for (j = i; (j < context_table_length); j += 1) - ((context_table[j]) . context) = 0; - } - return (i); -} - -static SCHEME_OBJECT -store_context (MHASH context, hashid id) -{ - if (context == MHASH_FAILED) - return (SHARP_F); - { - size_t i = (allocate_context_entry ()); - ((context_table[i]) . context) = context; - ((context_table[i]) . id) = id; - return (ulong_to_integer (i)); - } -} - -static void -forget_context (size_t index) -{ - ((context_table[index]) . context) = 0; -} - -static size_t -arg_context_index (unsigned int arg) -{ - unsigned long n = (arg_ulong_index_integer (arg, context_table_length)); - if (((context_table[n]) . context) == 0) - error_bad_range_arg (arg); - return (n); -} - -static MHASH -arg_context (unsigned int arg) -{ - return ((context_table [arg_context_index (arg)]) . context); -} - -static size_t hashid_count; -static hashid * hashid_map = 0; - -static void -initialize_hashid_map (void) -{ - if (hashid_map == 0) - { - size_t i = 0; - size_t j = 0; - hashid_count = (mhash_count ()); - hashid_map = (OS_malloc ((sizeof (hashid)) * hashid_count)); - while (i <= hashid_count) - { - if ((mhash_get_block_size (i)) != 0) - (hashid_map[j++]) = ((hashid) i); - i += 1; - } - } -} - -static hashid -arg_hashid (unsigned int arg) -{ - initialize_hashid_map (); - return (hashid_map [arg_ulong_index_integer (arg, hashid_count)]); -} - -DEFINE_PRIMITIVE ("MHASH_COUNT", Prim_mhash_count, 0, 0, 0) -{ - PRIMITIVE_HEADER (0); - initialize_hashid_map (); - PRIMITIVE_RETURN (ulong_to_integer (hashid_count)); -} - -DEFINE_PRIMITIVE ("MHASH_GET_BLOCK_SIZE", Prim_mhash_get_block_size, 1, 1, 0) - UNARY_OPERATION (mhash_get_block_size, arg_hashid, ulong_to_integer) -DEFINE_PRIMITIVE ("MHASH_GET_HASH_PBLOCK", Prim_mhash_get_hash_pblock, 1, 1, 0) - UNARY_OPERATION (mhash_get_hash_pblock, arg_hashid, ulong_to_integer) -DEFINE_PRIMITIVE ("MHASH_GET_HASH_NAME", Prim_mhash_get_hash_name, 1, 1, 0) - UNARY_OPERATION (mhash_get_hash_name, arg_hashid, cp2s) - -DEFINE_PRIMITIVE ("MHASH_INIT", Prim_mhash_init, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - { - hashid id = (arg_hashid (1)); - PRIMITIVE_RETURN (store_context ((mhash_init (id)), id)); - } -} - -DEFINE_PRIMITIVE ("MHASH_HMAC_INIT", Prim_mhash_hmac_init, 3, 3, 0) -{ - PRIMITIVE_HEADER (3); - CHECK_ARG (2, STRING_P); - { - hashid id = (arg_hashid (1)); - SCHEME_OBJECT key = (ARG_REF (2)); - PRIMITIVE_RETURN - (store_context ((mhash_hmac_init (id, - (STRING_POINTER (key)), - (STRING_LENGTH (key)), - (arg_ulong_integer (3)))), - id)); - } -} - -DEFINE_PRIMITIVE ("MHASH", Prim_mhash, 4, 4, 0) -{ - PRIMITIVE_HEADER (4); - CHECK_ARG (2, STRING_P); - { - SCHEME_OBJECT string = (ARG_REF (2)); - unsigned long end - = (arg_ulong_index_integer (4, ((STRING_LENGTH (string)) + 1))); - unsigned long start = (arg_ulong_index_integer (3, (end + 1))); - mhash ((arg_context (1)), (STRING_LOC (string, start)), (end - start)); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("MHASH_END", Prim_mhash_end, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - { - size_t index = (arg_context_index (1)); - MHASH context = ((context_table[index]) . context); - hashid id = ((context_table[index]) . id); - size_t block_size = (mhash_get_block_size (id)); - /* Must allocate string _before_ calling mhash_end. */ - SCHEME_OBJECT sd = (allocate_string (block_size)); - void * digest = (mhash_end (context)); - forget_context (index); - memcpy ((STRING_POINTER (sd)), digest, block_size); - free (digest); - PRIMITIVE_RETURN (sd); - } -} - -DEFINE_PRIMITIVE ("MHASH_HMAC_END", Prim_mhash_hmac_end, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - { - size_t index = (arg_context_index (1)); - MHASH context = ((context_table[index]) . context); - hashid id = ((context_table[index]) . id); - size_t block_size = (mhash_get_block_size (id)); - /* Must allocate string _before_ calling mhash_hmac_end. */ - SCHEME_OBJECT sd = (allocate_string (block_size)); - void * digest = (mhash_hmac_end (context)); - forget_context (index); - memcpy ((STRING_POINTER (sd)), digest, block_size); - free (digest); - PRIMITIVE_RETURN (sd); - } -} - -static size_t keygenid_count; -static keygenid * keygenid_map = 0; - -static void -initialize_keygenid_map (void) -{ - if (keygenid_map == 0) - { - size_t i = 0; - size_t j = 0; - keygenid_count = (mhash_keygen_count ()); - keygenid_map = (OS_malloc ((sizeof (keygenid)) * keygenid_count)); - while (j < keygenid_count) - { - void * name = (mhash_get_keygen_name (i)); - if (name != 0) - { - (keygenid_map[j++]) = ((keygenid) i); - free (name); - } - i += 1; - } - } -} - -static keygenid -arg_keygenid (unsigned int arg) -{ - initialize_keygenid_map (); - return (keygenid_map [arg_ulong_index_integer (arg, keygenid_count)]); -} - -DEFINE_PRIMITIVE ("MHASH_KEYGEN_COUNT", Prim_mhash_keygen_count, 0, 0, 0) -{ - PRIMITIVE_HEADER (0); - initialize_keygenid_map (); - PRIMITIVE_RETURN (ulong_to_integer (keygenid_count)); -} - -DEFINE_PRIMITIVE ("MHASH_GET_KEYGEN_NAME", Prim_mhash_get_keygen_name, 1, 1, 0) - UNARY_OPERATION (mhash_get_keygen_name, arg_keygenid, cp2s) -DEFINE_PRIMITIVE ("MHASH_KEYGEN_USES_SALT", Prim_mhash_keygen_uses_salt, 1, 1, 0) - UNARY_OPERATION (mhash_keygen_uses_salt, arg_keygenid, BOOLEAN_TO_OBJECT) -DEFINE_PRIMITIVE ("MHASH_KEYGEN_USES_COUNT", Prim_mhash_keygen_uses_count, 1, 1, 0) - UNARY_OPERATION (mhash_keygen_uses_count, arg_keygenid, BOOLEAN_TO_OBJECT) -DEFINE_PRIMITIVE ("MHASH_KEYGEN_USES_HASH_ALGORITHM", Prim_mhash_keygen_uses_hash_algorithm, 1, 1, 0) - UNARY_OPERATION (mhash_keygen_uses_hash_algorithm, arg_keygenid, long_to_integer) -DEFINE_PRIMITIVE ("MHASH_GET_KEYGEN_SALT_SIZE", Prim_mhash_get_keygen_salt_size, 1, 1, 0) - UNARY_OPERATION (mhash_get_keygen_salt_size, arg_keygenid, ulong_to_integer) -DEFINE_PRIMITIVE ("MHASH_GET_KEYGEN_MAX_KEY_SIZE", Prim_mhash_get_keygen_max_key_size, 1, 1, 0) - UNARY_OPERATION (mhash_get_keygen_max_key_size, arg_keygenid, ulong_to_integer) - -DEFINE_PRIMITIVE ("MHASH_KEYGEN", Prim_mhash_keygen, 4, 4, 0) -{ - /* keygen-id #(salt count hashid ...) keyword passphrase */ - PRIMITIVE_HEADER (4); - CHECK_ARG (2, VECTOR_P); - CHECK_ARG (3, STRING_P); - CHECK_ARG (4, STRING_P); - { - keygenid id = (arg_keygenid (1)); - SCHEME_OBJECT parameters = (ARG_REF (2)); - SCHEME_OBJECT keyword = (ARG_REF (3)); - SCHEME_OBJECT passphrase = (ARG_REF (4)); - unsigned int n_algs = (mhash_keygen_uses_hash_algorithm (id)); - SCHEME_OBJECT salt; - SCHEME_OBJECT count; - KEYGEN cparms; - { - size_t max_key_size = (mhash_get_keygen_max_key_size (id)); - if ((max_key_size != 0) && ((STRING_LENGTH (keyword)) > max_key_size)) - error_bad_range_arg (4); - } - if ((VECTOR_LENGTH (parameters)) != (2 + n_algs)) - error_bad_range_arg (2); - salt = (VECTOR_REF (parameters, 0)); - count = (VECTOR_REF (parameters, 1)); - if (mhash_keygen_uses_salt (id)) - { - if (!STRING_P (salt)) - error_bad_range_arg (2); - { - size_t salt_size = (mhash_get_keygen_salt_size (id)); - if ((salt_size != 0) && ((STRING_LENGTH (salt)) != salt_size)) - error_bad_range_arg (2); - } - (cparms . salt) = (STRING_BYTE_PTR (salt)); - (cparms . salt_size) = (STRING_LENGTH (salt)); - } - else if (salt != SHARP_F) - error_bad_range_arg (2); - if (mhash_keygen_uses_count (id)) - { - if (!integer_to_ulong_p (count)) - error_bad_range_arg (2); - (cparms . count) = (integer_to_ulong (count)); - } - else if (count != SHARP_F) - error_bad_range_arg (2); - { - unsigned int i; - initialize_hashid_map (); - for (i = 0; (i < n_algs); i += 1) - { - SCHEME_OBJECT a = (VECTOR_REF (parameters, (2 + i))); - if (!integer_to_ulong_p (a)) - error_bad_range_arg (2); - { - unsigned long ia = (integer_to_ulong (a)); - if (ia < hashid_count) - ((cparms . hash_algorithm) [i]) = (hashid_map[ia]); - else - error_bad_range_arg (2); - } - } - } - PRIMITIVE_RETURN - (BOOLEAN_TO_OBJECT - ((mhash_keygen_ext (id, cparms, - (STRING_POINTER (keyword)), - (STRING_LENGTH (keyword)), - (STRING_BYTE_PTR (passphrase)), - (STRING_LENGTH (passphrase)))) - == 0)); - } -} - -#ifdef COMPILE_AS_MODULE - -char * -dload_initialize_file (void) -{ - declare_primitive - ("MHASH_COUNT", Prim_mhash_count, 0, 0, 0); - declare_primitive - ("MHASH_GET_BLOCK_SIZE", Prim_mhash_get_block_size, 1, 1, 0); - declare_primitive - ("MHASH_GET_HASH_PBLOCK", Prim_mhash_get_hash_pblock, 1, 1, 0); - declare_primitive - ("MHASH_GET_HASH_NAME", Prim_mhash_get_hash_name, 1, 1, 0); - declare_primitive - ("MHASH_INIT", Prim_mhash_init, 1, 1, 0); - declare_primitive - ("MHASH_HMAC_INIT", Prim_mhash_hmac_init, 3, 3, 0); - declare_primitive - ("MHASH", Prim_mhash, 4, 4, 0); - declare_primitive - ("MHASH_END", Prim_mhash_end, 1, 1, 0); - declare_primitive - ("MHASH_HMAC_END", Prim_mhash_hmac_end, 1, 1, 0); - declare_primitive - ("MHASH_KEYGEN_COUNT", Prim_mhash_keygen_count, 0, 0, 0); - declare_primitive - ("MHASH_GET_KEYGEN_NAME", Prim_mhash_get_keygen_name, 1, 1, 0); - declare_primitive - ("MHASH_KEYGEN_USES_SALT", Prim_mhash_keygen_uses_salt, 1, 1, 0); - declare_primitive - ("MHASH_KEYGEN_USES_COUNT", Prim_mhash_keygen_uses_count, 1, 1, 0); - declare_primitive - ("MHASH_KEYGEN_USES_HASH_ALGORITHM", Prim_mhash_keygen_uses_hash_algorithm, 1, 1, 0); - declare_primitive - ("MHASH_GET_KEYGEN_SALT_SIZE", Prim_mhash_get_keygen_salt_size, 1, 1, 0); - declare_primitive - ("MHASH_GET_KEYGEN_MAX_KEY_SIZE", Prim_mhash_get_keygen_max_key_size, 1, 1, 0); - declare_primitive - ("MHASH_KEYGEN", Prim_mhash_keygen, 4, 4, 0); - return "#prmd5"; -} - -#endif /* COMPILE_AS_MODULE */ diff --git a/src/microcode/prx11.c b/src/microcode/prx11.c deleted file mode 100644 index 058e98a22..000000000 --- a/src/microcode/prx11.c +++ /dev/null @@ -1,54 +0,0 @@ -/* -*-C-*- - -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 - 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. - -*/ - -#ifdef COMPILE_AS_MODULE - -#include "scheme.h" - -extern void dload_initialize_x11base (void); -extern void dload_initialize_x11color (void); -extern void dload_initialize_x11graph (void); -extern void dload_initialize_x11term (void); - -const char * -dload_initialize_file (void) -{ - dload_initialize_x11base (); - dload_initialize_x11color (); - dload_initialize_x11graph (); - dload_initialize_x11term (); - return ("#prx11"); -} - -extern void dload_finalize_x11base (void); - -void -dload_finalize_file (void) -{ - dload_finalize_x11base (); -} - -#endif /* defined (COMPILE_AS_MODULE) */ diff --git a/src/microcode/x11.h b/src/microcode/x11.h deleted file mode 100644 index 7fc974034..000000000 --- a/src/microcode/x11.h +++ /dev/null @@ -1,346 +0,0 @@ -/* -*-C-*- - -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 - 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. - -*/ - -#ifndef SCHEME_X11_H -#define SCHEME_X11_H - -#include -#include -#include -#include -#include - -struct xdisplay -{ - unsigned int allocation_index; - Display * display; - unsigned int server_ping_timer; - Atom wm_protocols; - Atom wm_delete_window; - Atom wm_take_focus; - XEvent cached_event; - char cached_event_p; - - /* X key events have 8-bit modifier masks, three bits of which are - defined to be Shift, Lock, and Control, identified with ShiftMask, - LockMask, and ControlMask; and five bits of which are unspecified - named only mod1 to mod5. Which ones mean Meta, Super, Hyper, &c., - vary from system to system, however, so, on initializing the display - record, we grovel through some tables (XGetKeyboardMapping and - XGetModifierMapping) to find which ones the various modifier - keysyms are assigned to, and cache them here. - - Scheme knows about Shift, Control, Meta, Super, and Hyper. Of - these, only Meta, Super, and Hyper are identified by numbered - modifier masks. All other modifiers are ignored. */ - int modifier_mask_meta; - int modifier_mask_super; - int modifier_mask_hyper; - - /* The type of window manager we have. If we move FRAME_OUTER_WINDOW - to x/y 0/0, some window managers (type A) puts the window manager - decorations outside the screen and FRAME_OUTER_WINDOW exactly at 0/0. - Other window managers (type B) puts the window including decorations - at 0/0, so FRAME_OUTER_WINDOW is a bit below 0/0. - Record the type of WM in use so we can compensate for type A WMs. */ - enum - { - X_WMTYPE_UNKNOWN, - X_WMTYPE_A, - X_WMTYPE_B - } wm_type; -}; - -#define XD_ALLOCATION_INDEX(xd) ((xd) -> allocation_index) -#define XD_DISPLAY(xd) ((xd) -> display) -#define XD_SERVER_PING_TIMER(xd) ((xd) -> server_ping_timer) -#define XD_WM_PROTOCOLS(xd) ((xd) -> wm_protocols) -#define XD_WM_DELETE_WINDOW(xd) ((xd) -> wm_delete_window) -#define XD_WM_TAKE_FOCUS(xd) ((xd) -> wm_take_focus) -#define XD_CACHED_EVENT(xd) ((xd) -> cached_event) -#define XD_CACHED_EVENT_P(xd) ((xd) -> cached_event_p) -#define XD_MODIFIER_MASK_SHIFT(xd) (ShiftMask) -#define XD_MODIFIER_MASK_CONTROL(xd) (ControlMask) -#define XD_MODIFIER_MASK_LOCK(xd) (LockMask) -#define XD_MODIFIER_MASK_META(xd) ((xd) -> modifier_mask_meta) -#define XD_MODIFIER_MASK_SUPER(xd) ((xd) -> modifier_mask_super) -#define XD_MODIFIER_MASK_HYPER(xd) ((xd) -> modifier_mask_hyper) -#define XD_WM_TYPE(xd) ((xd) -> wm_type) -#define XD_TO_OBJECT(xd) (LONG_TO_UNSIGNED_FIXNUM (XD_ALLOCATION_INDEX (xd))) - -#define X_MODIFIER_MASK_SHIFT_P(modifier_mask, xd) \ - ((modifier_mask) & (XD_MODIFIER_MASK_SHIFT (xd))) -#define X_MODIFIER_MASK_CONTROL_P(modifier_mask, xd) \ - ((modifier_mask) & (XD_MODIFIER_MASK_CONTROL (xd))) -#define X_MODIFIER_MASK_LOCK_P(modifier_mask, xd) \ - ((modifier_mask) & (XD_MODIFIER_MASK_LOCK (xd))) -#define X_MODIFIER_MASK_META_P(modifier_mask, xd) \ - ((modifier_mask) & (XD_MODIFIER_MASK_META (xd))) -#define X_MODIFIER_MASK_SUPER_P(modifier_mask, xd) \ - ((modifier_mask) & (XD_MODIFIER_MASK_SUPER (xd))) -#define X_MODIFIER_MASK_HYPER_P(modifier_mask, xd) \ - ((modifier_mask) & (XD_MODIFIER_MASK_HYPER (xd))) - -extern struct xdisplay * x_display_arg (unsigned int arg); - -struct drawing_attributes -{ - /* Width of the borders, in pixels. */ - int border_width; - int internal_border_width; - - /* The primary font. */ - XFontStruct * font; - - /* Standard pixel values. */ - unsigned long background_pixel; - unsigned long foreground_pixel; - unsigned long border_pixel; - unsigned long cursor_pixel; - unsigned long mouse_pixel; -}; - -/* This incomplete type definition is needed because the scope of the - implicit definition in the following typedefs is incorrect. */ -struct xwindow; - -typedef void (*x_deallocator_t) (struct xwindow *); -typedef void (*x_event_processor_t) (struct xwindow *, XEvent *); -typedef SCHEME_OBJECT (*x_coordinate_map_t) - (struct xwindow *, unsigned int); -typedef void (*x_update_normal_hints_t) (struct xwindow *); - -struct xwindow_methods -{ - /* Deallocation procedure to do window-specific deallocation. */ - x_deallocator_t deallocator; - - /* Procedure to call on each received event. */ - x_event_processor_t event_processor; - - /* Procedures to map coordinates to Scheme objects. */ - x_coordinate_map_t x_coordinate_map; - x_coordinate_map_t y_coordinate_map; - - /* Procedure that is called to inform the window manager of - adjustments to the window's internal border or font. */ - x_update_normal_hints_t update_normal_hints; -}; - -struct xwindow -{ - unsigned int allocation_index; - Window window; - struct xdisplay * xd; - - /* Dimensions of the drawing region in pixels. */ - unsigned int x_size; - unsigned int y_size; - - /* The clip rectangle. */ - unsigned int clip_x; - unsigned int clip_y; - unsigned int clip_width; - unsigned int clip_height; - - struct drawing_attributes attributes; - - /* Standard graphics contexts. */ - GC normal_gc; - GC reverse_gc; - GC cursor_gc; - - /* The mouse cursor. */ - Cursor mouse_cursor; - - struct xwindow_methods methods; - - unsigned long event_mask; - - /* Geometry parameters for window-manager decoration window. */ - int wm_decor_x; - int wm_decor_y; - unsigned int wm_decor_pixel_width; - unsigned int wm_decor_pixel_height; - unsigned int wm_decor_border_width; - - /* The latest move we made to the window. Saved so we can - compensate for type A WMs (see wm_type above). */ - int expected_x; - int expected_y; - - /* Nonzero if we have made a move and need to check if the WM placed - us at the right position. */ - int check_expected_move_p; - - /* The offset we need to add to compensate for type A WMs. */ - int move_offset_x; - int move_offset_y; -}; - -#define XW_ALLOCATION_INDEX(xw) ((xw) -> allocation_index) -#define XW_XD(xw) ((xw) -> xd) -#define XW_WINDOW(xw) ((xw) -> window) -#define XW_X_SIZE(xw) ((xw) -> x_size) -#define XW_Y_SIZE(xw) ((xw) -> y_size) -#define XW_CLIP_X(xw) ((xw) -> clip_x) -#define XW_CLIP_Y(xw) ((xw) -> clip_y) -#define XW_CLIP_WIDTH(xw) ((xw) -> clip_width) -#define XW_CLIP_HEIGHT(xw) ((xw) -> clip_height) -#define XW_BORDER_WIDTH(xw) (((xw) -> attributes) . border_width) -#define XW_INTERNAL_BORDER_WIDTH(xw) \ - (((xw) -> attributes) . internal_border_width) -#define XW_FONT(xw) (((xw) -> attributes) . font) -#define XW_BACKGROUND_PIXEL(xw) (((xw) -> attributes) . background_pixel) -#define XW_FOREGROUND_PIXEL(xw) (((xw) -> attributes) . foreground_pixel) -#define XW_BORDER_PIXEL(xw) (((xw) -> attributes) . border_pixel) -#define XW_CURSOR_PIXEL(xw) (((xw) -> attributes) . cursor_pixel) -#define XW_MOUSE_PIXEL(xw) (((xw) -> attributes) . mouse_pixel) -#define XW_NORMAL_GC(xw) ((xw) -> normal_gc) -#define XW_REVERSE_GC(xw) ((xw) -> reverse_gc) -#define XW_CURSOR_GC(xw) ((xw) -> cursor_gc) -#define XW_MOUSE_CURSOR(xw) ((xw) -> mouse_cursor) -#define XW_DEALLOCATOR(xw) (((xw) -> methods) . deallocator) -#define XW_EVENT_PROCESSOR(xw) (((xw) -> methods) . event_processor) -#define XW_X_COORDINATE_MAP(xw) (((xw) -> methods) . x_coordinate_map) -#define XW_Y_COORDINATE_MAP(xw) (((xw) -> methods) . y_coordinate_map) -#define XW_UPDATE_NORMAL_HINTS(xw) (((xw) -> methods) . update_normal_hints) -#define XW_EVENT_MASK(xw) ((xw) -> event_mask) -#define XW_WM_DECOR_X(xw) ((xw) -> wm_decor_x) -#define XW_WM_DECOR_Y(xw) ((xw) -> wm_decor_y) -#define XW_WM_DECOR_PIXEL_WIDTH(xw) ((xw) -> wm_decor_pixel_width) -#define XW_WM_DECOR_PIXEL_HEIGHT(xw) ((xw) -> wm_decor_pixel_height) -#define XW_WM_DECOR_BORDER_WIDTH(xw) ((xw) -> wm_decor_border_width) -#define XW_EXPECTED_X(xw) ((xw) -> expected_x) -#define XW_EXPECTED_Y(xw) ((xw) -> expected_y) -#define XW_CHECK_EXPECTED_MOVE_P(xw) ((xw) -> check_expected_move_p) -#define XW_MOVE_OFFSET_X(xw) ((xw) -> move_offset_x) -#define XW_MOVE_OFFSET_Y(xw) ((xw) -> move_offset_y) - -#define XW_TO_OBJECT(xw) (LONG_TO_UNSIGNED_FIXNUM (XW_ALLOCATION_INDEX (xw))) -#define XW_DISPLAY(xw) (XD_DISPLAY (XW_XD (xw))) -#define XW_WM_TYPE(xw) (XD_WM_TYPE (XW_XD (xw))) - -#define FONT_WIDTH(f) (((f) -> max_bounds) . width) -#define FONT_HEIGHT(f) (((f) -> ascent) + ((f) -> descent)) -#define FONT_BASE(f) ((f) -> ascent) - -extern struct xwindow * x_window_arg (unsigned int arg); - -struct ximage -{ - unsigned int allocation_index; - XImage * image; -}; - -#define XI_ALLOCATION_INDEX(xi) ((xi) -> allocation_index) -#define XI_IMAGE(xi) ((xi) -> image) -#define X_IMAGE_TO_OBJECT(image) \ - (LONG_TO_UNSIGNED_FIXNUM (allocate_x_image (image))) - -extern struct ximage * x_image_arg (unsigned int arg); -extern unsigned int allocate_x_image (XImage * image); -extern void deallocate_x_image (struct ximage * xi); - -struct xvisual -{ - unsigned int allocation_index; - Visual * visual; -}; - -#define XV_ALLOCATION_INDEX(xv) ((xv) -> allocation_index) -#define XV_VISUAL(xv) ((xv) -> visual) -#define X_VISUAL_TO_OBJECT(visual) \ - (LONG_TO_UNSIGNED_FIXNUM (allocate_x_visual (visual))) - -extern struct xvisual * x_visual_arg (unsigned int arg); -extern unsigned int allocate_x_visual (Visual * visual); -extern void deallocate_x_visual (struct xvisual * xv); - -struct xcolormap -{ - unsigned int allocation_index; - Colormap colormap; - struct xdisplay * xd; -}; - -#define XCM_ALLOCATION_INDEX(xcm) ((xcm) -> allocation_index) -#define XCM_COLORMAP(xcm) ((xcm) -> colormap) -#define XCM_XD(xcm) ((xcm) -> xd) -#define X_COLORMAP_TO_OBJECT(colormap, xd) \ - (LONG_TO_UNSIGNED_FIXNUM (allocate_x_colormap ((colormap), (xd)))) -#define XCM_DISPLAY(xcm) (XD_DISPLAY (XCM_XD (xcm))) - -extern struct xcolormap * x_colormap_arg (unsigned int arg); -extern unsigned int allocate_x_colormap - (Colormap colormap, struct xdisplay * xd); -extern void deallocate_x_colormap (struct xcolormap * xcm); - -extern int x_debug; - -extern void * x_malloc (unsigned int size); -extern void * x_realloc (void * ptr, unsigned int size); - -extern const char * x_get_default - (Display * display, - const char * resource_name, - const char * resource_class, - const char * property_name, - const char * property_class, - const char * sdefault); - -extern void x_default_attributes - (Display * display, - const char * resource_name, - const char * resource_class, - struct drawing_attributes * attributes); - -extern struct xwindow * x_make_window - (struct xdisplay * xd, - Window window, - int x_size, - int y_size, - struct drawing_attributes * attributes, - struct xwindow_methods * methods, - unsigned int size); - -extern void xw_set_wm_input_hint (struct xwindow * xw, int input_hint); -extern void xw_set_wm_name (struct xwindow * xw, const char * name); -extern void xw_set_wm_icon_name (struct xwindow * xw, const char * name); - -extern void x_decode_window_map_arg - (SCHEME_OBJECT map_arg, - const char ** resource_class, - const char ** resource_name, - int * map_p); - -extern void xw_make_window_map - (struct xwindow * xw, - const char * resource_name, - const char * resource_class, - int map_p); - -#endif /* defined (SCHEME_X11_H) */ diff --git a/src/microcode/x11base.c b/src/microcode/x11base.c deleted file mode 100644 index 427c2e189..000000000 --- a/src/microcode/x11base.c +++ /dev/null @@ -1,2792 +0,0 @@ -/* -*-C-*- - -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 - 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. - -*/ - -/* Common X11 support. */ - -#include "scheme.h" -#include "prims.h" -#include "ux.h" -#include "osio.h" -#include "x11.h" -#include -#include - -extern void block_signals (void); -extern void unblock_signals (void); - -#ifndef X_DEFAULT_FONT -# define X_DEFAULT_FONT "fixed" -#endif - -int x_debug = 0; -static int initialization_done = 0; -static const char * x_default_font = 0; - -#define INITIALIZE_ONCE() \ -{ \ - if (!initialization_done) \ - initialize_once (); \ -} - -static void initialize_once (void); - -static void move_window (struct xwindow *, int, int); -static void check_expected_move (struct xwindow *); - -void * -x_malloc (unsigned int size) -{ - void * result = (UX_malloc (size)); - if (result == 0) - error_external_return (); - return (result); -} - -void * -x_realloc (void * ptr, unsigned int size) -{ - void * result = (UX_realloc (ptr, size)); - if (result == 0) - error_external_return (); - return (result); -} - -/* Allocation Tables */ - -struct allocation_table -{ - void ** items; - int length; -}; - -static struct allocation_table x_display_table; -static struct allocation_table x_window_table; -static struct allocation_table x_image_table; -static struct allocation_table x_visual_table; -static struct allocation_table x_colormap_table; - -static void -allocation_table_initialize (struct allocation_table * table) -{ - (table->length) = 0; -} - -static unsigned int -allocate_table_index (struct allocation_table * table, void * item) -{ - unsigned int length = (table->length); - unsigned int new_length; - void ** items = (table->items); - void ** new_items; - void ** scan; - void ** end; - if (length == 0) - { - new_length = 4; - new_items = (x_malloc ((sizeof (void *)) * new_length)); - } - else - { - scan = items; - end = (scan + length); - while (scan < end) - if ((*scan++) == 0) - { - (*--scan) = item; - return (scan - items); - } - new_length = (length * 2); - new_items = (x_realloc (items, ((sizeof (void *)) * new_length))); - } - scan = (new_items + length); - end = (new_items + new_length); - (*scan++) = item; - while (scan < end) - (*scan++) = 0; - (table->items) = new_items; - (table->length) = new_length; - return (length); -} - -static void * -allocation_item_arg (unsigned int arg, struct allocation_table * table) -{ - unsigned int index = (arg_index_integer (arg, (table->length))); - void * item = ((table->items) [index]); - if (item == 0) - error_bad_range_arg (arg); - return (item); -} - -struct xdisplay * -x_display_arg (unsigned int arg) -{ - INITIALIZE_ONCE (); - return (allocation_item_arg (arg, (&x_display_table))); -} - -struct xwindow * -x_window_arg (unsigned int arg) -{ - INITIALIZE_ONCE (); - return (allocation_item_arg (arg, (&x_window_table))); -} - -static struct xwindow * -x_window_to_xw (Display * display, Window window) -{ - struct xwindow ** scan = ((struct xwindow **) (x_window_table.items)); - struct xwindow ** end = (scan + (x_window_table.length)); - while (scan < end) - { - struct xwindow * xw = (*scan++); - if ((xw != 0) - && ((XW_DISPLAY (xw)) == display) - && ((XW_WINDOW (xw)) == window)) - return (xw); - } - return (0); -} - -struct ximage * -x_image_arg (unsigned int arg) -{ - INITIALIZE_ONCE (); - return (allocation_item_arg (arg, (&x_image_table))); -} - -unsigned int -allocate_x_image (XImage * image) -{ - struct ximage * xi = (x_malloc (sizeof (struct ximage))); - unsigned int index = (allocate_table_index ((&x_image_table), xi)); - (XI_ALLOCATION_INDEX (xi)) = index; - (XI_IMAGE (xi)) = image; - return (index); -} - -void -deallocate_x_image (struct ximage * xi) -{ - ((x_image_table.items) [XI_ALLOCATION_INDEX (xi)]) = 0; - free (xi); -} - -struct xvisual * -x_visual_arg (unsigned int arg) -{ - INITIALIZE_ONCE (); - return (allocation_item_arg (arg, (&x_visual_table))); -} - -unsigned int -allocate_x_visual (Visual * visual) -{ - struct xvisual * xv = (x_malloc (sizeof (struct xvisual))); - unsigned int index = (allocate_table_index ((&x_visual_table), xv)); - (XV_ALLOCATION_INDEX (xv)) = index; - (XV_VISUAL (xv)) = visual; - return (index); -} - -void -deallocate_x_visual (struct xvisual * xv) -{ - ((x_visual_table.items) [XV_ALLOCATION_INDEX (xv)]) = 0; - free (xv); -} - -struct xcolormap * -x_colormap_arg (unsigned int arg) -{ - INITIALIZE_ONCE (); - return (allocation_item_arg (arg, (&x_colormap_table))); -} - -unsigned int -allocate_x_colormap (Colormap colormap, struct xdisplay * xd) -{ - struct xcolormap * xcm = (x_malloc (sizeof (struct xcolormap))); - unsigned int index = (allocate_table_index ((&x_colormap_table), xcm)); - (XCM_ALLOCATION_INDEX (xcm)) = index; - (XCM_COLORMAP (xcm)) = colormap; - (XCM_XD (xcm)) = xd; - return (index); -} - -void -deallocate_x_colormap (struct xcolormap * xcm) -{ - ((x_colormap_table.items) [XCM_ALLOCATION_INDEX (xcm)]) = 0; - free (xcm); -} - -/* Error Handlers */ - -static int -x_io_error_handler (Display * display) -{ - fprintf (stderr, "\nX IO Error\n"); - fflush (stderr); - termination_eof (); - return (0); -} - -typedef struct -{ - char message [2048]; - char terminate_p; - unsigned char code; -} x_error_info_t; - -static x_error_info_t x_error_info; - -static int -x_error_handler (Display * display, XErrorEvent * error_event) -{ - (x_error_info.code) = (error_event->error_code); - XGetErrorText (display, - (error_event->error_code), - (x_error_info.message), - (sizeof (x_error_info.message))); - if (x_error_info.terminate_p) - { - fprintf (stderr, "\nX Error: %s\n", (x_error_info.message)); - fprintf (stderr, " Request code: %d\n", - (error_event->request_code)); - fprintf (stderr, " Error serial: %lx\n", (error_event->serial)); - fflush (stderr); - termination_eof (); - } - return (0); -} - -static void -unbind_x_error_info (void * storage) -{ - x_error_info = (* ((x_error_info_t *) storage)); -} - -static void * -push_x_error_info (Display * display) -{ - void * handle; - x_error_info_t * storage; - - XSync (display, False); - handle = dstack_position; - storage = (dstack_alloc (sizeof (x_error_info_t))); - (*storage) = x_error_info; - ((x_error_info.message) [0]) = '\0'; - (x_error_info.terminate_p) = 0; - (x_error_info.code) = 0; - dstack_protect (unbind_x_error_info, storage); - return (handle); -} - -static void -pop_x_error_info (void * handle) -{ - dstack_set_position (handle); -} - -static unsigned char -x_error_code (Display * display) -{ - XSync (display, False); - return (x_error_info.code); -} - -static int -any_x_errors_p (Display * display) -{ - return ((x_error_code (display)) != 0); -} - -/* Defaults and Attributes */ - -static int -x_decode_color (Display * display, - Colormap color_map, - const char * color_name, - unsigned long * color_return) -{ - XColor cdef; - if ((XParseColor (display, color_map, color_name, (&cdef))) - && (XAllocColor (display, color_map, (&cdef)))) - { - (*color_return) = (cdef.pixel); - return (1); - } - return (0); -} - -Colormap -xw_color_map (struct xwindow * xw) -{ - XWindowAttributes a; - if (! (XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&a)))) - error_external_return (); - return (a.colormap); -} - -static unsigned long -arg_window_color (unsigned int arg, Display * display, struct xwindow * xw) -{ - unsigned long result; - SCHEME_OBJECT object = (ARG_REF (arg)); - if (INTEGER_P (object)) - { - if (! (integer_to_ulong_p (object))) - error_bad_range_arg (arg); - result = (integer_to_ulong (object)); - } - else if (! (x_decode_color - (display, (xw_color_map (xw)), (STRING_ARG (arg)), (&result)))) - error_bad_range_arg (arg); - return (result); -} - -static void -x_set_mouse_colors (Display * display, - Colormap color_map, - Cursor mouse_cursor, - unsigned long mouse_pixel, - unsigned long background_pixel) -{ - XColor mouse_color; - XColor background_color; - (mouse_color.pixel) = mouse_pixel; - XQueryColor (display, color_map, (&mouse_color)); - (background_color.pixel) = background_pixel; - XQueryColor (display, color_map, (&background_color)); - XRecolorCursor (display, mouse_cursor, (&mouse_color), (&background_color)); -} - -const char * -x_get_default (Display * display, - const char * resource_name, - const char * resource_class, - const char * property_name, - const char * property_class, - const char * sdefault) -{ - const char * result = (XGetDefault (display, resource_name, property_name)); - if (result != 0) - return (result); - result = (XGetDefault (display, resource_class, property_name)); - if (result != 0) - return (result); - result = (XGetDefault (display, resource_name, property_class)); - if (result != 0) - return (result); - result = (XGetDefault (display, resource_class, property_class)); - if (result != 0) - return (result); - return (sdefault); -} - -static unsigned long -x_default_color (Display * display, - const char * resource_name, - const char * resource_class, - const char * property_name, - const char * property_class, - unsigned long default_color) -{ - const char * color_name - = (x_get_default (display, resource_name, resource_class, - property_name, property_class, 0)); - unsigned long result; - return - (((color_name != 0) - && (x_decode_color (display, - (DefaultColormap (display, - (DefaultScreen (display)))), - color_name, - (&result)))) - ? result - : default_color); -} - -void -x_default_attributes (Display * display, - const char * resource_name, - const char * resource_class, - struct drawing_attributes * attributes) -{ - int screen_number = (DefaultScreen (display)); - (attributes->font) - = (XLoadQueryFont (display, - ((x_default_font != 0) - ? x_default_font - : (x_get_default (display, - resource_name, resource_class, - "font", "Font", - X_DEFAULT_FONT))))); - if ((attributes->font) == 0) - error_external_return (); - { - const char * s - = (x_get_default (display, - resource_name, resource_class, - "borderWidth", "BorderWidth", - 0)); - (attributes->border_width) = ((s == 0) ? 0 : (atoi (s))); - } - { - const char * s - = (x_get_default (display, - resource_name, resource_class, - "internalBorder", "BorderWidth", - 0)); - (attributes->internal_border_width) - = ((s == 0) ? (attributes->border_width) : (atoi (s))); - } - { - unsigned long white_pixel = (WhitePixel (display, screen_number)); - unsigned long black_pixel = (BlackPixel (display, screen_number)); - unsigned long foreground_pixel; - (attributes->background_pixel) - = (x_default_color (display, - resource_name, resource_class, - "background", "Background", - white_pixel)); - foreground_pixel - = (x_default_color (display, - resource_name, resource_class, - "foreground", "Foreground", - black_pixel)); - (attributes->foreground_pixel) = foreground_pixel; - (attributes->border_pixel) - = (x_default_color (display, - resource_name, resource_class, - "borderColor", "BorderColor", - foreground_pixel)); - (attributes->cursor_pixel) - = (x_default_color (display, - resource_name, resource_class, - "cursorColor", "Foreground", - foreground_pixel)); - (attributes->mouse_pixel) - = (x_default_color (display, - resource_name, resource_class, - "pointerColor", "Foreground", - foreground_pixel)); - } -} - -static int -get_wm_decor_geometry (struct xwindow * xw) -{ - Display * display = (XW_DISPLAY (xw)); - Window decor = (XW_WINDOW (xw)); - void * handle = (push_x_error_info (display)); - Window root; - unsigned int depth; - - { - Window parent; - Window * children; - unsigned int n_children; - while (1) - { - if ((!XQueryTree (display, decor, - (&root), (&parent), (&children), (&n_children))) - || (any_x_errors_p (display))) - { - pop_x_error_info (handle); - error_external_return (); - } - if (children != 0) - XFree (children); - if (parent == root) - break; - decor = parent; - } - } - if ((!XGetGeometry (display, - decor, - (&root), - (& (XW_WM_DECOR_X (xw))), - (& (XW_WM_DECOR_Y (xw))), - (& (XW_WM_DECOR_PIXEL_WIDTH (xw))), - (& (XW_WM_DECOR_PIXEL_HEIGHT (xw))), - (& (XW_WM_DECOR_BORDER_WIDTH (xw))), - (&depth))) - || (any_x_errors_p (display))) - { - pop_x_error_info (handle); - error_external_return (); - } - pop_x_error_info (handle); - /* Return true iff the window has been reparented by the WM. */ - return (decor != (XW_WINDOW (xw))); -} - -/* Open/Close Windows */ - -#define MAKE_GC(gc, fore, back) \ -{ \ - XGCValues gcv; \ - (gcv.font) = fid; \ - (gcv.foreground) = (fore); \ - (gcv.background) = (back); \ - (gc) = \ - (XCreateGC (display, \ - window, \ - (GCFont | GCForeground | GCBackground), \ - (& gcv))); \ -} - -struct xwindow * -x_make_window (struct xdisplay * xd, - Window window, - int x_size, - int y_size, - struct drawing_attributes * attributes, - struct xwindow_methods * methods, - unsigned int size) -{ - GC normal_gc; - GC reverse_gc; - GC cursor_gc; - struct xwindow * xw; - Display * display = (XD_DISPLAY (xd)); - Font fid = ((attributes->font) -> fid); - unsigned long foreground_pixel = (attributes->foreground_pixel); - unsigned long background_pixel = (attributes->background_pixel); - Cursor mouse_cursor = (XCreateFontCursor (display, XC_left_ptr)); - MAKE_GC (normal_gc, foreground_pixel, background_pixel); - MAKE_GC (reverse_gc, background_pixel, foreground_pixel); - MAKE_GC (cursor_gc, background_pixel, (attributes->cursor_pixel)); - x_set_mouse_colors - (display, - (DefaultColormap (display, (DefaultScreen (display)))), - mouse_cursor, - (attributes->mouse_pixel), - background_pixel); - XDefineCursor (display, window, mouse_cursor); - XSelectInput (display, window, 0); - if (size < (sizeof (struct xwindow))) - error_external_return (); - xw = (x_malloc (size)); - (XW_ALLOCATION_INDEX (xw)) = (allocate_table_index ((&x_window_table), xw)); - (XW_XD (xw)) = xd; - (XW_WINDOW (xw)) = window; - (XW_X_SIZE (xw)) = x_size; - (XW_Y_SIZE (xw)) = y_size; - (XW_CLIP_X (xw)) = 0; - (XW_CLIP_Y (xw)) = 0; - (XW_CLIP_WIDTH (xw)) = x_size; - (XW_CLIP_HEIGHT (xw)) = y_size; - (xw->attributes) = (*attributes); - (xw->methods) = (*methods); - (XW_NORMAL_GC (xw)) = normal_gc; - (XW_REVERSE_GC (xw)) = reverse_gc; - (XW_CURSOR_GC (xw)) = cursor_gc; - (XW_MOUSE_CURSOR (xw)) = mouse_cursor; - (XW_EVENT_MASK (xw)) = 0; - (XW_CHECK_EXPECTED_MOVE_P (xw)) = 0; - (XW_MOVE_OFFSET_X (xw)) = 0; - (XW_MOVE_OFFSET_Y (xw)) = 0; - return (xw); -} - -static jmp_buf x_close_window_jmp_buf; - -static int -x_close_window_io_error (Display * display) -{ - longjmp (x_close_window_jmp_buf, 1); - /*NOTREACHED*/ - return (0); -} - -static void -x_close_window (struct xwindow * xw) -{ - Display * display = (XW_DISPLAY (xw)); - ((x_window_table.items) [XW_ALLOCATION_INDEX (xw)]) = 0; - if ((setjmp (x_close_window_jmp_buf)) == 0) - { - XSetIOErrorHandler (x_close_window_io_error); - { - x_deallocator_t deallocator = (XW_DEALLOCATOR (xw)); - if (deallocator != 0) - (*deallocator) (xw); - } - { - XFontStruct * font = (XW_FONT (xw)); - if (font != 0) - XFreeFont (display, font); - } - XDestroyWindow (display, (XW_WINDOW (xw))); - /* Guarantee that the IO error occurs while the IO error handler - is rebound, if at all. */ - XFlush (display); - } - XSetIOErrorHandler (x_io_error_handler); - free (xw); -} - -/* Initialize/Close Displays */ - -#define MODIFIER_INDEX_TO_MASK(N) (1 << (N)) - -/* Grovel through the X server's keycode and modifier mappings to find - out what we ought to interpret as Meta, Hyper, and Super, based on - what modifiers are associated with keycodes that are associated with - keysyms Meta_L, Meta_R, Alt_L, Alt_R, Hyper_L, &c. - - Adapted from GNU Emacs. */ - -static void -x_initialize_display_modifier_masks (struct xdisplay * xd) -{ - int min_keycode; - int max_keycode; - XModifierKeymap * modifier_keymap; - KeyCode * modifier_to_keycodes_table; - int keycodes_per_modifier; - KeySym * keycode_to_keysyms_table; - int keysyms_per_keycode; - - (XD_MODIFIER_MASK_META (xd)) = 0; - (XD_MODIFIER_MASK_SUPER (xd)) = 0; - (XD_MODIFIER_MASK_HYPER (xd)) = 0; - - modifier_keymap = (XGetModifierMapping ((XD_DISPLAY (xd)))); - modifier_to_keycodes_table = (modifier_keymap->modifiermap); - keycodes_per_modifier = (modifier_keymap->max_keypermod); - - XDisplayKeycodes ((XD_DISPLAY (xd)), (& min_keycode), (& max_keycode)); - - keycode_to_keysyms_table - = (XGetKeyboardMapping ((XD_DISPLAY (xd)), - min_keycode, - (max_keycode - min_keycode + 1), - (& keysyms_per_keycode))); - - /* Go through each of the 8 non-preassigned modifiers, which start at - 3 (Mod1), after Shift, Control, and Lock. For each modifier, go - through all of the (non-zero) keycodes attached to it; for each - keycode, go through all of the keysyms attached to it; check each - keysym for the modifiers that we're interested in (Meta, Hyper, - and Super). */ - - { - int modifier_index; - - for (modifier_index = 3; (modifier_index < 8); modifier_index += 1) - { - int modifier_mask = (MODIFIER_INDEX_TO_MASK (modifier_index)); - KeyCode * keycodes - = (& (modifier_to_keycodes_table - [modifier_index * keycodes_per_modifier])); - - /* This is a flag specifying whether the modifier has already - been identified as Meta, which takes precedence over Hyper - and Super. (What about precedence between Hyper and - Super...? This is GNU Emacs's behaviour.) */ - int modifier_is_meta_p = 0; - - int keycode_index; - - for (keycode_index = 0; - (keycode_index < keycodes_per_modifier); - keycode_index += 1) - { - KeyCode keycode = (keycodes [keycode_index]); - - if (keycode == 0) - continue; - - { - int keysym_index; - KeySym * keysyms - = (& (keycode_to_keysyms_table - [(keycode - min_keycode) * keysyms_per_keycode])); - - for (keysym_index = 0; - (keysym_index < keysyms_per_keycode); - keysym_index += 1) - switch (keysyms [keysym_index]) - { - case XK_Meta_L: - case XK_Meta_R: - case XK_Alt_L: - case XK_Alt_R: - modifier_is_meta_p = 1; - (XD_MODIFIER_MASK_META (xd)) |= modifier_mask; - break; - - case XK_Hyper_L: - case XK_Hyper_R: - if (! modifier_is_meta_p) - (XD_MODIFIER_MASK_HYPER (xd)) |= modifier_mask; - goto next_modifier; - - case XK_Super_L: - case XK_Super_R: - if (! modifier_is_meta_p) - (XD_MODIFIER_MASK_SUPER (xd)) |= modifier_mask; - goto next_modifier; - } - } - } - - next_modifier: - continue; - } - } - - XFree (((char *) keycode_to_keysyms_table)); - XFreeModifiermap (modifier_keymap); -} - -static void -x_close_display (struct xdisplay * xd) -{ - struct xwindow ** scan = ((struct xwindow **) (x_window_table.items)); - struct xwindow ** end = (scan + (x_window_table.length)); - while (scan < end) - { - struct xwindow * xw = (*scan++); - if ((xw != 0) && ((XW_XD (xw)) == xd)) - x_close_window (xw); - } - ((x_display_table.items) [XD_ALLOCATION_INDEX (xd)]) = 0; - XCloseDisplay (XD_DISPLAY (xd)); -} - -static void -x_close_all_displays (void) -{ - struct xdisplay ** scan = ((struct xdisplay **) (x_display_table.items)); - struct xdisplay ** end = (scan + (x_display_table.length)); - while (scan < end) - { - struct xdisplay * xd = (*scan++); - if (xd != 0) - x_close_display (xd); - } -} - -/* Window Manager Properties */ - -static void -xw_set_class_hint (struct xwindow * xw, const char * name, const char * class) -{ - XClassHint * class_hint = (XAllocClassHint ()); - if (class_hint == 0) - error_external_return (); - /* This structure is misdeclared, so cast the args. */ - (class_hint->res_name) = ((char *) name); - (class_hint->res_class) = ((char *) class); - XSetClassHint ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), class_hint); - XFree (class_hint); -} - -void -xw_set_wm_input_hint (struct xwindow * xw, int input_hint) -{ - XWMHints * hints = (XAllocWMHints ()); - if (hints == 0) - error_external_return (); - (hints->flags) = InputHint; - (hints->input) = (input_hint != 0); - XSetWMHints ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), hints); - XFree (hints); -} - -void -xw_set_wm_name (struct xwindow * xw, const char * name) -{ - XTextProperty property; - if ((XStringListToTextProperty (((char **) (&name)), 1, (&property))) == 0) - error_external_return (); - XSetWMName ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&property)); -} - -void -xw_set_wm_icon_name (struct xwindow * xw, const char * name) -{ - XTextProperty property; - if ((XStringListToTextProperty (((char **) (&name)), 1, (&property))) == 0) - error_external_return (); - XSetWMIconName ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&property)); -} - -void -x_decode_window_map_arg (SCHEME_OBJECT map_arg, - const char ** resource_name, - const char ** resource_class, - int * map_p) -{ - (*map_p) = 0; - if (map_arg == SHARP_F) - (*map_p) = 1; - else if ((PAIR_P (map_arg)) - && (STRING_P (PAIR_CAR (map_arg))) - && (STRING_P (PAIR_CDR (map_arg)))) - { - (*resource_name) = (STRING_POINTER (PAIR_CAR (map_arg))); - (*resource_class) = (STRING_POINTER (PAIR_CDR (map_arg))); - (*map_p) = 1; - } - else if ((VECTOR_P (map_arg)) - && ((VECTOR_LENGTH (map_arg)) == 3) - && (BOOLEAN_P (VECTOR_REF (map_arg, 0))) - && (STRING_P (VECTOR_REF (map_arg, 1))) - && (STRING_P (VECTOR_REF (map_arg, 2)))) - { - (*resource_name) = (STRING_POINTER (VECTOR_REF (map_arg, 1))); - (*resource_class) = (STRING_POINTER (VECTOR_REF (map_arg, 2))); - (*map_p) = (OBJECT_TO_BOOLEAN (VECTOR_REF (map_arg, 0))); - } -} - -void -xw_make_window_map (struct xwindow * xw, - const char * resource_name, - const char * resource_class, - int map_p) -{ - xw_set_class_hint (xw, resource_name, resource_class); - if (map_p) - { - XMapWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw))); - XFlush (XW_DISPLAY (xw)); - } -} - -/* Event Processing */ - -/* Returns non-zero value if caller should ignore the event. */ - -static int -xw_process_event (struct xwindow * xw, XEvent * event) -{ - if (x_debug > 0) - { - const char * type_name; - fprintf (stderr, "\nX event on 0x%lx: ", ((event->xany) . window)); - switch (event->type) - { - case ButtonPress: type_name = "ButtonPress"; break; - case ButtonRelease: type_name = "ButtonRelease"; break; - case CirculateNotify: type_name = "CirculateNotify"; break; - case CreateNotify: type_name = "CreateNotify"; break; - case DestroyNotify: type_name = "DestroyNotify"; break; - case EnterNotify: type_name = "EnterNotify"; break; - case Expose: type_name = "Expose"; break; - case FocusIn: type_name = "FocusIn"; break; - case FocusOut: type_name = "FocusOut"; break; - case GraphicsExpose: type_name = "GraphicsExpose"; break; - case GravityNotify: type_name = "GravityNotify"; break; - case KeyPress: type_name = "KeyPress"; break; - case KeyRelease: type_name = "KeyRelease"; break; - case LeaveNotify: type_name = "LeaveNotify"; break; - case MapNotify: type_name = "MapNotify"; break; - case MappingNotify: type_name = "MappingNotify"; break; - case MotionNotify: type_name = "MotionNotify"; break; - case NoExpose: type_name = "NoExpose"; break; - case ReparentNotify: type_name = "ReparentNotify"; break; - case SelectionClear: type_name = "SelectionClear"; break; - case SelectionRequest: type_name = "SelectionRequest"; break; - case UnmapNotify: type_name = "UnmapNotify"; break; - - case VisibilityNotify: - fprintf (stderr, "VisibilityNotify; state="); - switch ((event->xvisibility) . state) - { - case VisibilityUnobscured: - fprintf (stderr, "unobscured"); - break; - case VisibilityPartiallyObscured: - fprintf (stderr, "partially-obscured"); - break; - case VisibilityFullyObscured: - fprintf (stderr, "fully-obscured"); - break; - default: - fprintf (stderr, "%d", ((event->xvisibility) . state)); - break; - } - goto debug_done; - - case ConfigureNotify: - fprintf (stderr, "ConfigureNotify; x=%d y=%d width=%d height=%d", - ((event->xconfigure) . x), - ((event->xconfigure) . y), - ((event->xconfigure) . width), - ((event->xconfigure) . height)); - goto debug_done; - - case ClientMessage: - { - struct xdisplay * xd = (XW_XD (xw)); - if ((((event->xclient) . message_type) == (XD_WM_PROTOCOLS (xd))) - && (((event->xclient) . format) == 32)) - { - if (((Atom) (((event->xclient) . data . l) [0])) - == (XD_WM_DELETE_WINDOW (xd))) - type_name = "WM_DELETE_WINDOW"; - else if (((Atom) (((event->xclient) . data . l) [0])) - == (XD_WM_TAKE_FOCUS (xd))) - type_name = "WM_TAKE_FOCUS"; - else - type_name = "WM_PROTOCOLS"; - } - else - { - fprintf (stderr, "ClientMessage; message_type=0x%x format=%d", - ((unsigned int) ((event->xclient) . message_type)), - ((event->xclient) . format)); - goto debug_done; - } - } - break; - case PropertyNotify: - { - fprintf (stderr, "PropertyNotify; atom=%ld time=%ld state=%d", - ((event->xproperty) . atom), - ((event->xproperty) . time), - ((event->xproperty) . state)); - goto debug_done; - } - case SelectionNotify: - { - fprintf - (stderr, "SelectionNotify; sel=%ld targ=%ld prop=%ld t=%ld", - ((event->xselection) . selection), - ((event->xselection) . target), - ((event->xselection) . property), - ((event->xselection) . time)); - goto debug_done; - } - default: type_name = 0; break; - } - if (type_name != 0) - fprintf (stderr, "%s", type_name); - else - fprintf (stderr, "%d", (event->type)); - debug_done: - fprintf (stderr, "%s\n", - (((event->xany) . send_event) ? "; synthetic" : "")); - fflush (stderr); - } - switch (event->type) - { - case MappingNotify: - switch ((event->xmapping) . request) - { - case MappingModifier: - x_initialize_display_modifier_masks ((XW_XD (xw))); - /* Fall through. */ - case MappingKeyboard: - XRefreshKeyboardMapping (& (event->xmapping)); - break; - } - break; - } - if (xw != 0) - { - switch (event->type) - { - case ReparentNotify: - get_wm_decor_geometry (xw); - /* Perhaps reparented due to a WM restart. Reset this. */ - (XW_WM_TYPE (xw)) = X_WMTYPE_UNKNOWN; - break; - - case ConfigureNotify: - /* If the window has been reparented, don't check - non-synthetic events. */ - if ((XW_CHECK_EXPECTED_MOVE_P (xw)) - && (! ((get_wm_decor_geometry (xw)) - && (! ((event->xconfigure) . send_event))))) - check_expected_move (xw); - break; - } - (* (XW_EVENT_PROCESSOR (xw))) (xw, event); - } - return (0); -} - -enum event_type -{ - event_type_button_down, - event_type_button_up, - event_type_configure, - event_type_enter, - event_type_focus_in, - event_type_focus_out, - event_type_key_press, - event_type_leave, - event_type_motion, - event_type_expose, - event_type_delete_window, - event_type_map, - event_type_unmap, - event_type_take_focus, - event_type_visibility, - event_type_selection_clear, - event_type_selection_notify, - event_type_selection_request, - event_type_property_notify, - event_type_supremum -}; - -#define EVENT_MASK_ARG(arg) \ - (arg_ulong_index_integer \ - ((arg), (1 << ((unsigned int) event_type_supremum)))) - -#define EVENT_ENABLED(xw, type) \ - (((XW_EVENT_MASK (xw)) & (1 << ((unsigned int) (type)))) != 0) - -#define EVENT_0 2 -#define EVENT_1 3 -#define EVENT_2 4 -#define EVENT_3 5 -#define EVENT_4 6 - -#define EVENT_INTEGER(event, slot, number) \ - VECTOR_SET ((event), (slot), (long_to_integer (number))) - -#define EVENT_ULONG_INTEGER(event, slot, number) \ - VECTOR_SET ((event), (slot), (ulong_to_integer (number))) - -static SCHEME_OBJECT -make_event_object (struct xwindow * xw, - enum event_type type, - unsigned int extra) -{ - SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, (2 + extra), 1)); - VECTOR_SET (result, 0, (LONG_TO_UNSIGNED_FIXNUM ((long) type))); - VECTOR_SET (result, 1, ((xw == 0) ? SHARP_F : (XW_TO_OBJECT (xw)))); - return (result); -} - -/* This handles only the modifier bits that Scheme supports. - At the moment, these are Control, Meta, Super, and Hyper. - This might want to change if the character abstraction were ever to - change, or if the X11 interface were to be changed to use something - other than Scheme characters to convey key presses. */ - -static unsigned long -x_modifier_mask_to_bucky_bits (unsigned int mask, struct xdisplay * xd) -{ - unsigned long bucky = 0; - if (X_MODIFIER_MASK_CONTROL_P (mask, xd)) bucky |= CHAR_BITS_CONTROL; - if (X_MODIFIER_MASK_META_P (mask, xd)) bucky |= CHAR_BITS_META; - if (X_MODIFIER_MASK_SUPER_P (mask, xd)) bucky |= CHAR_BITS_SUPER; - if (X_MODIFIER_MASK_HYPER_P (mask, xd)) bucky |= CHAR_BITS_HYPER; - return (bucky); -} - -/* I'm not sure why we have a function for this. */ - -static SCHEME_OBJECT -x_key_button_mask_to_scheme (unsigned int x_state) -{ - unsigned long scheme_state = 0; - if (x_state & ControlMask) scheme_state |= 0x0001; - if (x_state & Mod1Mask) scheme_state |= 0x0002; - if (x_state & Mod2Mask) scheme_state |= 0x0004; - if (x_state & Mod3Mask) scheme_state |= 0x0008; - if (x_state & ShiftMask) scheme_state |= 0x0010; - if (x_state & LockMask) scheme_state |= 0x0020; - if (x_state & Mod4Mask) scheme_state |= 0x0040; - if (x_state & Mod5Mask) scheme_state |= 0x0080; - if (x_state & Button1Mask) scheme_state |= 0x0100; - if (x_state & Button2Mask) scheme_state |= 0x0200; - if (x_state & Button3Mask) scheme_state |= 0x0400; - if (x_state & Button4Mask) scheme_state |= 0x0800; - if (x_state & Button5Mask) scheme_state |= 0x1000; - return (ULONG_TO_FIXNUM (scheme_state)); -} - -static SCHEME_OBJECT -button_event (struct xwindow * xw, XButtonEvent * event, enum event_type type) -{ - SCHEME_OBJECT result = (make_event_object (xw, type, 4)); - EVENT_INTEGER (result, EVENT_0, (event->x)); - EVENT_INTEGER (result, EVENT_1, (event->y)); - VECTOR_SET - (result, EVENT_2, - ((((event->button) >= 1) && ((event->button) <= 256)) - ? (ULONG_TO_FIXNUM - (((event->button) - 1) - | ((x_modifier_mask_to_bucky_bits ((event->state), (XW_XD (xw)))) - << 8))) - : SHARP_F)); - EVENT_ULONG_INTEGER (result, EVENT_3, (event->time)); - return (result); -} - -static XComposeStatus compose_status; - -static SCHEME_OBJECT -key_event (struct xwindow * xw, XKeyEvent * event, enum event_type type) -{ - char copy_buffer [80]; - KeySym keysym; - int nbytes; - SCHEME_OBJECT result; - - /* Make ShiftLock modifier not affect keys with other modifiers. */ - if ((event->state) - & (ShiftMask || ControlMask - || Mod1Mask || Mod2Mask || Mod3Mask || Mod4Mask || Mod5Mask)) - { - if (((event->state) & LockMask) != 0) - (event->state) &=~ LockMask; - } - nbytes - = (XLookupString (event, - copy_buffer, - (sizeof (copy_buffer)), - (&keysym), - (&compose_status))); - if (keysym == NoSymbol) - return (SHARP_F); - /* If the BackSpace keysym is received, and XLookupString has - translated it into ASCII backspace, substitute ASCII DEL - instead. */ - if ((keysym == XK_BackSpace) - && (nbytes == 1) - && ((copy_buffer[0]) == '\b')) - (copy_buffer[0]) = '\177'; - if (IsModifierKey (keysym)) - return (SHARP_F); - - result = (make_event_object (xw, type, 4)); - VECTOR_SET (result, EVENT_0, - (memory_to_string (nbytes, ((unsigned char *) copy_buffer)))); - /* Create Scheme bucky bits (kept independent of the character). - X has already controlified, so Scheme may choose to ignore - the control bucky bit. */ - VECTOR_SET (result, EVENT_1, - (ULONG_TO_FIXNUM - (x_modifier_mask_to_bucky_bits ((event->state), - (XW_XD (xw)))))); - VECTOR_SET (result, EVENT_2, (ulong_to_integer (keysym))); - EVENT_ULONG_INTEGER (result, EVENT_3, (event->time)); - return (result); -} - -#define CONVERT_TRIVIAL_EVENT(scheme_name) \ - if (EVENT_ENABLED (xw, scheme_name)) \ - result = (make_event_object (xw, scheme_name, 0)); \ - break - -static SCHEME_OBJECT -x_event_to_object (XEvent * event) -{ - struct xwindow * xw - = (x_window_to_xw (((event->xany) . display), - ((event->xany) . window))); - SCHEME_OBJECT result = SHARP_F; - if (xw == 0) - return result; - switch (event->type) - { - case KeyPress: - if (EVENT_ENABLED (xw, event_type_key_press)) - result = (key_event (xw, (& (event->xkey)), event_type_key_press)); - break; - case ButtonPress: - if (EVENT_ENABLED (xw, event_type_button_down)) - result - = (button_event (xw, (& (event->xbutton)), event_type_button_down)); - break; - case ButtonRelease: - if (EVENT_ENABLED (xw, event_type_button_up)) - result - = (button_event (xw, (& (event->xbutton)), event_type_button_up)); - break; - case MotionNotify: - if (EVENT_ENABLED (xw, event_type_motion)) - { - result = (make_event_object (xw, event_type_motion, 3)); - EVENT_INTEGER (result, EVENT_0, ((event->xmotion) . x)); - EVENT_INTEGER (result, EVENT_1, ((event->xmotion) . y)); - VECTOR_SET (result, EVENT_2, - (x_key_button_mask_to_scheme - (((event->xmotion) . state)))); - } - break; - case ConfigureNotify: - if (EVENT_ENABLED (xw, event_type_configure)) - { - result = (make_event_object (xw, event_type_configure, 2)); - EVENT_ULONG_INTEGER - (result, EVENT_0, ((event->xconfigure) . width)); - EVENT_ULONG_INTEGER - (result, EVENT_1, ((event->xconfigure) . height)); - } - break; - case Expose: - if (EVENT_ENABLED (xw, event_type_expose)) - { - result = (make_event_object (xw, event_type_expose, 5)); - EVENT_INTEGER (result, EVENT_0, ((event->xexpose) . x)); - EVENT_INTEGER (result, EVENT_1, ((event->xexpose) . y)); - EVENT_ULONG_INTEGER (result, EVENT_2, ((event->xexpose) . width)); - EVENT_ULONG_INTEGER (result, EVENT_3, ((event->xexpose) . height)); - VECTOR_SET (result, EVENT_4, (LONG_TO_UNSIGNED_FIXNUM (0))); - } - break; - case GraphicsExpose: - if (EVENT_ENABLED (xw, event_type_expose)) - { - result = (make_event_object (xw, event_type_expose, 5)); - EVENT_INTEGER (result, EVENT_0, ((event->xgraphicsexpose) . x)); - EVENT_INTEGER (result, EVENT_1, ((event->xgraphicsexpose) . y)); - EVENT_ULONG_INTEGER - (result, EVENT_2, ((event->xgraphicsexpose) . width)); - EVENT_ULONG_INTEGER - (result, EVENT_3, ((event->xgraphicsexpose) . height)); - VECTOR_SET (result, EVENT_4, (LONG_TO_UNSIGNED_FIXNUM (1))); - } - break; - case ClientMessage: - { - struct xdisplay * xd = (XW_XD (xw)); - if ((((event->xclient) . message_type) == (XD_WM_PROTOCOLS (xd))) - && (((event->xclient) . format) == 32)) - { - if (((Atom) (((event->xclient) . data . l) [0])) - == (XD_WM_DELETE_WINDOW (xd))) - { - if (EVENT_ENABLED (xw, event_type_delete_window)) - result - = (make_event_object (xw, event_type_delete_window, 0)); - } - else if (((Atom) (((event->xclient) . data . l) [0])) - == (XD_WM_TAKE_FOCUS (xd))) - { - if (EVENT_ENABLED (xw, event_type_take_focus)) - { - result - = (make_event_object (xw, event_type_take_focus, 1)); - EVENT_ULONG_INTEGER - (result, EVENT_0, (((event->xclient) . data . l) [1])); - } - } - } - } - break; - case VisibilityNotify: - if (EVENT_ENABLED (xw, event_type_visibility)) - { - unsigned int state; - switch ((event->xvisibility) . state) - { - case VisibilityUnobscured: - state = 0; - break; - case VisibilityPartiallyObscured: - state = 1; - break; - case VisibilityFullyObscured: - state = 2; - break; - default: - state = 3; - break; - } - result = (make_event_object (xw, event_type_visibility, 1)); - EVENT_ULONG_INTEGER (result, EVENT_0, state); - } - break; - case SelectionClear: - if (EVENT_ENABLED (xw, event_type_selection_clear)) - { - result = (make_event_object (xw, event_type_selection_clear, 2)); - EVENT_ULONG_INTEGER - (result, EVENT_0, ((event->xselectionclear) . selection)); - EVENT_ULONG_INTEGER - (result, EVENT_1, ((event->xselectionclear) . time)); - } - break; - case SelectionNotify: - if (EVENT_ENABLED (xw, event_type_selection_notify)) - { - result = (make_event_object (xw, event_type_selection_notify, 5)); - EVENT_ULONG_INTEGER - (result, EVENT_0, ((event->xselection) . requestor)); - EVENT_ULONG_INTEGER - (result, EVENT_1, ((event->xselection) . selection)); - EVENT_ULONG_INTEGER - (result, EVENT_2, ((event->xselection) . target)); - EVENT_ULONG_INTEGER - (result, EVENT_3, ((event->xselection) . property)); - EVENT_ULONG_INTEGER - (result, EVENT_4, ((event->xselection) . time)); - } - break; - case SelectionRequest: - if (EVENT_ENABLED (xw, event_type_selection_request)) - { - result = (make_event_object (xw, event_type_selection_request, 5)); - EVENT_ULONG_INTEGER - (result, EVENT_0, ((event->xselectionrequest) . requestor)); - EVENT_ULONG_INTEGER - (result, EVENT_1, ((event->xselectionrequest) . selection)); - EVENT_ULONG_INTEGER - (result, EVENT_2, ((event->xselectionrequest) . target)); - EVENT_ULONG_INTEGER - (result, EVENT_3, ((event->xselectionrequest) . property)); - EVENT_ULONG_INTEGER - (result, EVENT_4, ((event->xselectionrequest) . time)); - } - break; - case PropertyNotify: - if (EVENT_ENABLED (xw, event_type_property_notify)) - { - result = (make_event_object (xw, event_type_property_notify, 4)); - /* Must store window element separately because this window - might not have a corresponding XW object. */ - EVENT_ULONG_INTEGER - (result, EVENT_0, ((event->xproperty) . window)); - EVENT_ULONG_INTEGER - (result, EVENT_1, ((event->xproperty) . atom)); - EVENT_ULONG_INTEGER - (result, EVENT_2, ((event->xproperty) . time)); - EVENT_ULONG_INTEGER - (result, EVENT_3, ((event->xproperty) . state)); - } - break; - case EnterNotify: CONVERT_TRIVIAL_EVENT (event_type_enter); - case LeaveNotify: CONVERT_TRIVIAL_EVENT (event_type_leave); - case FocusIn: CONVERT_TRIVIAL_EVENT (event_type_focus_in); - case FocusOut: CONVERT_TRIVIAL_EVENT (event_type_focus_out); - case MapNotify: CONVERT_TRIVIAL_EVENT (event_type_map); - case UnmapNotify: CONVERT_TRIVIAL_EVENT (event_type_unmap); - } - return (result); -} - -static void -update_input_mask (struct xwindow * xw) -{ - { - unsigned long event_mask = 0; - if (EVENT_ENABLED (xw, event_type_expose)) - event_mask |= ExposureMask; - if ((EVENT_ENABLED (xw, event_type_configure)) - || (EVENT_ENABLED (xw, event_type_map)) - || (EVENT_ENABLED (xw, event_type_unmap))) - event_mask |= StructureNotifyMask; - if (EVENT_ENABLED (xw, event_type_button_down)) - event_mask |= ButtonPressMask; - if (EVENT_ENABLED (xw, event_type_button_up)) - event_mask |= ButtonReleaseMask; - if (EVENT_ENABLED (xw, event_type_key_press)) - event_mask |= KeyPressMask; - if (EVENT_ENABLED (xw, event_type_enter)) - event_mask |= EnterWindowMask; - if (EVENT_ENABLED (xw, event_type_leave)) - event_mask |= LeaveWindowMask; - if ((EVENT_ENABLED (xw, event_type_focus_in)) - || (EVENT_ENABLED (xw, event_type_focus_out))) - event_mask |= FocusChangeMask; - if (EVENT_ENABLED (xw, event_type_motion)) - event_mask |= (PointerMotionMask | PointerMotionHintMask); - if (EVENT_ENABLED (xw, event_type_visibility)) - event_mask |= VisibilityChangeMask; - if (EVENT_ENABLED (xw, event_type_property_notify)) - event_mask |= PropertyChangeMask; - XSelectInput ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), event_mask); - } - { - struct xdisplay * xd = (XW_XD (xw)); - Atom protocols [2]; - unsigned int n_protocols = 0; - if (EVENT_ENABLED (xw, event_type_delete_window)) - (protocols[n_protocols++]) = (XD_WM_DELETE_WINDOW (xd)); - if (EVENT_ENABLED (xw, event_type_take_focus)) - (protocols[n_protocols++]) = (XD_WM_TAKE_FOCUS (xd)); - if (n_protocols > 0) - XSetWMProtocols - ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&protocols[0]), n_protocols); - } -} - -static void -ping_server (struct xdisplay * xd) -{ - /* Periodically ping the server connection to see if it has died. */ - (XD_SERVER_PING_TIMER (xd)) += 1; - if ((XD_SERVER_PING_TIMER (xd)) >= 100) - { - (XD_SERVER_PING_TIMER (xd)) = 0; - XNoOp (XD_DISPLAY (xd)); - XFlush (XD_DISPLAY (xd)); - } -} - -/* The use of `XD_CACHED_EVENT' prevents an event from being lost due - to garbage collection. First `XD_CACHED_EVENT' is set to hold the - current event, then the allocations are performed. If one of them - fails, the primitive will exit, and when it reenters it will notice - the cached event and use it. It is important that this be the only - entry that reads events -- or else that all other event readers - cooperate with this strategy. */ - -static SCHEME_OBJECT -xd_process_events (struct xdisplay * xd) -{ - Display * display = (XD_DISPLAY (xd)); - unsigned int events_queued; - XEvent event; - SCHEME_OBJECT result = SHARP_F; - if (x_debug > 1) - { - fprintf (stderr, "Enter xd_process_events\n"); - fflush (stderr); - } - if (XD_CACHED_EVENT_P (xd)) - { - events_queued = (XEventsQueued (display, QueuedAlready)); - event = (XD_CACHED_EVENT (xd)); - goto restart; - } - ping_server (xd); - events_queued = (XEventsQueued (display, QueuedAfterReading)); - while (0 < events_queued) - { - events_queued -= 1; - XNextEvent (display, (&event)); - if ((event.type) == KeymapNotify) - continue; - { - struct xwindow * xw - = (x_window_to_xw (display, (event.xany.window))); - if ((xw == 0) - && (! (((event.type) == PropertyNotify) - || ((event.type) == SelectionClear) - || ((event.type) == SelectionNotify) - || ((event.type) == SelectionRequest)))) - continue; - if (xw_process_event (xw, (&event))) - continue; - } - (XD_CACHED_EVENT (xd)) = event; - (XD_CACHED_EVENT_P (xd)) = 1; - restart: - result = (x_event_to_object (&event)); - (XD_CACHED_EVENT_P (xd)) = 0; - if (result != SHARP_F) - break; - } - if (x_debug > 1) - { - fprintf (stderr, "Return from xd_process_events: "); - if (result == SHARP_F) - fprintf (stderr, "#f"); - else if (VECTOR_P (result)) - fprintf (stderr, "[vector]"); - else - fprintf (stderr, "[other: 0x%lx]", ((unsigned long) result)); - fprintf (stderr, "\n"); - fflush (stderr); - } - return (result); -} - -/* Open/Close Primitives */ - -static void -initialize_once (void) -{ - allocation_table_initialize (&x_display_table); - allocation_table_initialize (&x_window_table); - allocation_table_initialize (&x_image_table); - ((x_error_info.message) [0]) = '\0'; - (x_error_info.terminate_p) = 1; - (x_error_info.code) = 0; - XSetErrorHandler (x_error_handler); - XSetIOErrorHandler (x_io_error_handler); -#ifndef COMPILE_AS_MODULE - add_reload_cleanup (x_close_all_displays); -#endif - initialization_done = 1; -} - -DEFINE_PRIMITIVE ("X-DEBUG", Prim_x_debug, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - { - SCHEME_OBJECT object = (ARG_REF (1)); - if (object == SHARP_F) - x_debug = 0; - else if (UNSIGNED_FIXNUM_P (object)) - x_debug = (UNSIGNED_FIXNUM_TO_LONG (object)); - else - x_debug = 1; - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-OPEN-DISPLAY", Prim_x_open_display, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - INITIALIZE_ONCE (); - { - struct xdisplay * xd = (x_malloc (sizeof (struct xdisplay))); - /* Added 7/95 by Nick in an attempt to fix problem Hal was having - with SWAT over PPP (i.e. slow connections). */ - block_signals (); - (XD_DISPLAY (xd)) - = (XOpenDisplay (((ARG_REF (1)) == SHARP_F) ? 0 : (STRING_ARG (1)))); - unblock_signals (); - if ((XD_DISPLAY (xd)) == 0) - { - free (xd); - PRIMITIVE_RETURN (SHARP_F); - } - (XD_ALLOCATION_INDEX (xd)) - = (allocate_table_index ((&x_display_table), xd)); - (XD_SERVER_PING_TIMER (xd)) = 0; - (XD_WM_PROTOCOLS (xd)) - = (XInternAtom ((XD_DISPLAY (xd)), "WM_PROTOCOLS", False)); - (XD_WM_DELETE_WINDOW (xd)) - = (XInternAtom ((XD_DISPLAY (xd)), "WM_DELETE_WINDOW", False)); - (XD_WM_TAKE_FOCUS (xd)) - = (XInternAtom ((XD_DISPLAY (xd)), "WM_TAKE_FOCUS", False)); - (XD_CACHED_EVENT_P (xd)) = 0; - x_initialize_display_modifier_masks (xd); - XRebindKeysym ((XD_DISPLAY (xd)), XK_BackSpace, 0, 0, - ((unsigned char *) "\177"), 1); - PRIMITIVE_RETURN (XD_TO_OBJECT (xd)); - } -} - -DEFINE_PRIMITIVE ("X-CLOSE-DISPLAY", Prim_x_close_display, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - x_close_display (x_display_arg (1)); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-CLOSE-ALL-DISPLAYS", Prim_x_close_all_displays, 0, 0, 0) -{ - PRIMITIVE_HEADER (0); - INITIALIZE_ONCE (); - x_close_all_displays (); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-DISPLAY-GET-SIZE", Prim_x_display_get_size, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xdisplay * xd = (x_display_arg (1)); - Display * display = (XD_DISPLAY (xd)); - long screen = (arg_nonnegative_integer (2)); - PRIMITIVE_RETURN - (cons ((ulong_to_integer (DisplayWidth (display, screen))), - (ulong_to_integer (DisplayHeight (display, screen))))); - } -} - -DEFINE_PRIMITIVE ("X-CLOSE-WINDOW", Prim_x_close_window, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - { - struct xwindow * xw = (x_window_arg (1)); - Display * display = (XW_DISPLAY (xw)); - x_close_window (xw); - XFlush (display); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-SET-DEFAULT-FONT", Prim_x_set_default_font, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xdisplay * xd = (x_display_arg (1)); - Display * display = (XD_DISPLAY (xd)); - const char * name = (STRING_ARG (2)); - XFontStruct * font = (XLoadQueryFont (display, name)); - if (font == 0) - PRIMITIVE_RETURN (SHARP_F); - XFreeFont (display, font); - if (x_default_font != 0) - OS_free ((void *) x_default_font); - { - char * copy = (OS_malloc ((strlen (name)) + 1)); - const char * s1 = name; - char * s2 = copy; - while (1) - { - char c = (*s1++); - (*s2++) = c; - if (c == '\0') - break; - } - x_default_font = copy; - } - } - PRIMITIVE_RETURN (SHARP_T); -} - -/* Event Processing Primitives */ - -DEFINE_PRIMITIVE ("X-DISPLAY-DESCRIPTOR", Prim_x_display_descriptor, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - PRIMITIVE_RETURN - (long_to_integer (ConnectionNumber (XD_DISPLAY (x_display_arg (1))))); -} - -DEFINE_PRIMITIVE ("X-MAX-REQUEST-SIZE", Prim_x_max_request_size, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - PRIMITIVE_RETURN - (long_to_integer (XMaxRequestSize (XD_DISPLAY (x_display_arg (1))))); -} - -DEFINE_PRIMITIVE ("X-DISPLAY-PROCESS-EVENTS", Prim_x_display_process_events, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xdisplay * xd = (x_display_arg (1)); - SCHEME_OBJECT how = (ARG_REF (2)); - /* Previously, the `how' argument could be #F (block, select), 0 - (don't block, select), 1 (block, don't select), 2 (don't block, - don't select). Now we never select or block -- it is up to the - caller to do that. #F and 0 have been unused for a long time, - and the only caller that used 1 in the system already selected - and blocked anyway. */ - if ((how != (LONG_TO_UNSIGNED_FIXNUM (1))) - && (how != (LONG_TO_UNSIGNED_FIXNUM (2)))) - error_bad_range_arg (2); - PRIMITIVE_RETURN (xd_process_events (xd)); - } -} - -DEFINE_PRIMITIVE ("X-SELECT-INPUT", Prim_x_select_input, 3, 3, 0) -{ - PRIMITIVE_HEADER (3); - XSelectInput ((XD_DISPLAY (x_display_arg (1))), - (arg_ulong_integer (2)), - (arg_integer (3))); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-WINDOW-EVENT-MASK", Prim_x_window_event_mask, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - PRIMITIVE_RETURN (ulong_to_integer (XW_EVENT_MASK (x_window_arg (1)))); -} - -DEFINE_PRIMITIVE ("X-WINDOW-SET-EVENT-MASK", Prim_x_window_set_event_mask, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - (XW_EVENT_MASK (xw)) = (EVENT_MASK_ARG (2)); - update_input_mask (xw); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-WINDOW-OR-EVENT-MASK", Prim_x_window_or_event_mask, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - (XW_EVENT_MASK (xw)) |= (EVENT_MASK_ARG (2)); - update_input_mask (xw); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-WINDOW-ANDC-EVENT-MASK", Prim_x_window_andc_event_mask, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - (XW_EVENT_MASK (xw)) &=~ (EVENT_MASK_ARG (2)); - update_input_mask (xw); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -/* Miscellaneous Primitives */ - -DEFINE_PRIMITIVE ("X-WINDOW-DISPLAY", Prim_x_window_display, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - PRIMITIVE_RETURN (XD_TO_OBJECT (XW_XD (x_window_arg (1)))); -} - -DEFINE_PRIMITIVE ("X-WINDOW-X-SIZE", Prim_x_window_x_size, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - PRIMITIVE_RETURN (ulong_to_integer (XW_X_SIZE (x_window_arg (1)))); -} - -DEFINE_PRIMITIVE ("X-WINDOW-Y-SIZE", Prim_x_window_y_size, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - PRIMITIVE_RETURN (ulong_to_integer (XW_Y_SIZE (x_window_arg (1)))); -} - -DEFINE_PRIMITIVE ("X-WINDOW-BEEP", Prim_x_window_beep, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - XBell ((XW_DISPLAY (x_window_arg (1))), 0); /* base value */ - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-WINDOW-CLEAR", Prim_x_window_clear, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - { - struct xwindow * xw = (x_window_arg (1)); - if (((XW_CLIP_X (xw)) == 0) - && ((XW_CLIP_Y (xw)) == 0) - && ((XW_CLIP_WIDTH (xw)) == (XW_X_SIZE (xw))) - && ((XW_CLIP_HEIGHT (xw)) == (XW_Y_SIZE (xw)))) - XClearWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw))); - else - XClearArea ((XW_DISPLAY (xw)), - (XW_WINDOW (xw)), - ((XW_CLIP_X (xw)) + (XW_INTERNAL_BORDER_WIDTH (xw))), - ((XW_CLIP_Y (xw)) + (XW_INTERNAL_BORDER_WIDTH (xw))), - (XW_CLIP_WIDTH (xw)), - (XW_CLIP_HEIGHT (xw)), - False); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-DISPLAY-FLUSH", Prim_x_display_flush, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - XFlush (XD_DISPLAY (x_display_arg (1))); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-WINDOW-FLUSH", Prim_x_window_flush, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - XFlush (XW_DISPLAY (x_window_arg (1))); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-DISPLAY-SYNC", Prim_x_display_sync, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - XSync ((XD_DISPLAY (x_display_arg (1))), (BOOLEAN_ARG (2))); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-DISPLAY-GET-DEFAULT", Prim_x_display_get_default, 3, 3, 0) -{ - PRIMITIVE_HEADER (3); - { - char * result - = (XGetDefault ((XD_DISPLAY (x_display_arg (1))), - (STRING_ARG (2)), - (STRING_ARG (3)))); - PRIMITIVE_RETURN - ((result == 0) - ? SHARP_F - : (char_pointer_to_string (result))); - } -} - -DEFINE_PRIMITIVE ("X-WINDOW-COORDS-ROOT->LOCAL", Prim_x_window_coords_root2local, 3, 3, 0) -{ - PRIMITIVE_HEADER (3); - { - SCHEME_OBJECT result = (cons (SHARP_F, SHARP_F)); - struct xwindow * xw = (x_window_arg (1)); - Display * display = (XW_DISPLAY (xw)); - int rx = (arg_integer (2)); - int ry = (arg_integer (3)); - int wx; - int wy; - Window child; - if (! (XTranslateCoordinates - (display, - (RootWindow (display, (DefaultScreen (display)))), - (XW_WINDOW (xw)), - rx, ry, (&wx), (&wy), (&child)))) - error_bad_range_arg (1); - SET_PAIR_CAR (result, (long_to_integer (wx))); - SET_PAIR_CDR (result, (long_to_integer (wy))); - PRIMITIVE_RETURN (result); - } -} - -DEFINE_PRIMITIVE ("X-WINDOW-COORDS-LOCAL->ROOT", Prim_x_window_coords_local2root, 3, 3, 0) -{ - PRIMITIVE_HEADER (3); - { - SCHEME_OBJECT result = (cons (SHARP_F, SHARP_F)); - struct xwindow * xw = (x_window_arg (1)); - Display * display = (XW_DISPLAY (xw)); - int wx = (arg_integer (2)); - int wy = (arg_integer (3)); - int rx; - int ry; - Window child; - if (! (XTranslateCoordinates - (display, - (XW_WINDOW (xw)), - (RootWindow (display, (DefaultScreen (display)))), - wx, wy, (&rx), (&ry), (&child)))) - error_bad_range_arg (1); - SET_PAIR_CAR (result, (long_to_integer (rx))); - SET_PAIR_CDR (result, (long_to_integer (ry))); - PRIMITIVE_RETURN (result); - } -} - -DEFINE_PRIMITIVE ("X-WINDOW-QUERY-POINTER", Prim_x_window_query_pointer, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - { - SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 5, 1)); - struct xwindow * xw = (x_window_arg (1)); - Window root; - Window child; - int root_x; - int root_y; - int win_x; - int win_y; - unsigned int keys_buttons; - if (!XQueryPointer ((XW_DISPLAY (xw)), - (XW_WINDOW (xw)), - (&root), (&child), - (&root_x), (&root_y), - (&win_x), (&win_y), - (&keys_buttons))) - PRIMITIVE_RETURN (SHARP_F); - VECTOR_SET (result, 0, (long_to_integer (root_x))); - VECTOR_SET (result, 1, (long_to_integer (root_y))); - VECTOR_SET (result, 2, (long_to_integer (win_x))); - VECTOR_SET (result, 3, (long_to_integer (win_y))); - VECTOR_SET (result, 4, (x_key_button_mask_to_scheme (keys_buttons))); - PRIMITIVE_RETURN (result); - } -} - -DEFINE_PRIMITIVE ("X-WINDOW-ID", Prim_x_window_id, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - PRIMITIVE_RETURN (ulong_to_integer (XW_WINDOW (x_window_arg (1)))); -} - -DEFINE_PRIMITIVE ("X-ID->WINDOW", Prim_x_id_to_window, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw - = (x_window_to_xw ((XD_DISPLAY (x_display_arg (1))), - (arg_ulong_integer (2)))); - PRIMITIVE_RETURN ((xw == 0) ? SHARP_F : (XW_TO_OBJECT (xw))); - } -} - -/* Appearance Control Primitives */ - -DEFINE_PRIMITIVE ("X-WINDOW-SET-FOREGROUND-COLOR", Prim_x_window_set_foreground_color, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - Display * display = (XW_DISPLAY (xw)); - unsigned long foreground_pixel = (arg_window_color (2, display, xw)); - (XW_FOREGROUND_PIXEL (xw)) = foreground_pixel; - XSetForeground (display, (XW_NORMAL_GC (xw)), foreground_pixel); - XSetBackground (display, (XW_REVERSE_GC (xw)), foreground_pixel); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-WINDOW-SET-BACKGROUND-COLOR", Prim_x_window_set_background_color, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - Display * display = (XW_DISPLAY (xw)); - unsigned long background_pixel = (arg_window_color (2, display, xw)); - (XW_BACKGROUND_PIXEL (xw)) = background_pixel; - XSetWindowBackground (display, (XW_WINDOW (xw)), background_pixel); - XSetBackground (display, (XW_NORMAL_GC (xw)), background_pixel); - XSetForeground (display, (XW_REVERSE_GC (xw)), background_pixel); - XSetForeground (display, (XW_CURSOR_GC (xw)), background_pixel); - x_set_mouse_colors (display, - (xw_color_map (xw)), - (XW_MOUSE_CURSOR (xw)), - (XW_MOUSE_PIXEL (xw)), - background_pixel); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-WINDOW-SET-BORDER-COLOR", Prim_x_window_set_border_color, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - Display * display = (XW_DISPLAY (xw)); - unsigned long border_pixel = (arg_window_color (2, display, xw)); - (XW_BORDER_PIXEL (xw)) = border_pixel; - XSetWindowBorder (display, (XW_WINDOW (xw)), border_pixel); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-WINDOW-SET-CURSOR-COLOR", Prim_x_window_set_cursor_color, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - Display * display = (XW_DISPLAY (xw)); - unsigned long cursor_pixel = (arg_window_color (2, display, xw)); - (XW_CURSOR_PIXEL (xw)) = cursor_pixel; - XSetBackground (display, (XW_CURSOR_GC (xw)), cursor_pixel); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-WINDOW-SET-MOUSE-COLOR", Prim_x_window_set_mouse_color, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - Display * display = (XW_DISPLAY (xw)); - unsigned long mouse_pixel = (arg_window_color (2, display, xw)); - (XW_MOUSE_PIXEL (xw)) = mouse_pixel; - x_set_mouse_colors (display, - (xw_color_map (xw)), - (XW_MOUSE_CURSOR (xw)), - mouse_pixel, - (XW_BACKGROUND_PIXEL (xw))); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-WINDOW-SET-MOUSE-SHAPE", Prim_x_window_set_mouse_shape, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - Display * display = (XW_DISPLAY (xw)); - Window window = (XW_WINDOW (xw)); - { - Cursor old_cursor = (XW_MOUSE_CURSOR (xw)); - Cursor mouse_cursor - = (XCreateFontCursor - (display, (2 * (arg_index_integer (2, (XC_num_glyphs / 2)))))); - x_set_mouse_colors (display, - (xw_color_map (xw)), - mouse_cursor, - (XW_MOUSE_PIXEL (xw)), - (XW_BACKGROUND_PIXEL (xw))); - (XW_MOUSE_CURSOR (xw)) = mouse_cursor; - XDefineCursor (display, window, mouse_cursor); - XFreeCursor (display, old_cursor); - } - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-WINDOW-SET-FONT", Prim_x_window_set_font, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - Display * display = (XW_DISPLAY (xw)); - XFontStruct * font = (XLoadQueryFont (display, (STRING_ARG (2)))); - if (font == 0) - PRIMITIVE_RETURN (SHARP_F); - XFreeFont (display, (XW_FONT (xw))); - (XW_FONT (xw)) = font; - { - Font fid = (font->fid); - XSetFont (display, (XW_NORMAL_GC (xw)), fid); - XSetFont (display, (XW_REVERSE_GC (xw)), fid); - XSetFont (display, (XW_CURSOR_GC (xw)), fid); - } - if ((XW_UPDATE_NORMAL_HINTS (xw)) != 0) - (* (XW_UPDATE_NORMAL_HINTS (xw))) (xw); - } - PRIMITIVE_RETURN (SHARP_T); -} - -DEFINE_PRIMITIVE ("X-WINDOW-SET-BORDER-WIDTH", Prim_x_window_set_border_width, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - Display * display = (XW_DISPLAY (xw)); - unsigned int border_width = (arg_nonnegative_integer (2)); - (XW_BORDER_WIDTH (xw)) = border_width; - XSetWindowBorderWidth (display, (XW_WINDOW (xw)), border_width); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-WINDOW-SET-INTERNAL-BORDER-WIDTH", Prim_x_window_set_internal_border_width, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - unsigned int internal_border_width = (arg_nonnegative_integer (2)); - (XW_INTERNAL_BORDER_WIDTH (xw)) = internal_border_width; - if ((XW_UPDATE_NORMAL_HINTS (xw)) != 0) - (* (XW_UPDATE_NORMAL_HINTS (xw))) (xw); - XResizeWindow ((XW_DISPLAY (xw)), - (XW_WINDOW (xw)), - ((XW_X_SIZE (xw)) + (2 * internal_border_width)), - ((XW_Y_SIZE (xw)) + (2 * internal_border_width))); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -/* WM Communication Primitives */ - -DEFINE_PRIMITIVE ("X-WINDOW-SET-NAME", Prim_x_window_set_name, 2, 2, - "Set the name of WINDOW to STRING.") -{ - PRIMITIVE_HEADER (2); - xw_set_wm_name ((x_window_arg (1)), (STRING_ARG (2))); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-WINDOW-SET-ICON-NAME", Prim_x_window_set_icon_name, 2, 2, - "Set the icon name of WINDOW to STRING.") -{ - PRIMITIVE_HEADER (2); - xw_set_wm_icon_name ((x_window_arg (1)), (STRING_ARG (2))); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-WINDOW-SET-CLASS-HINT", Prim_x_window_set_class_hint, 3, 3, - "Set the class hint of WINDOW to RESOURCE_NAME and RESOURCE_CLASS.") -{ - PRIMITIVE_HEADER (3); - xw_set_class_hint ((x_window_arg (1)), (STRING_ARG (2)), (STRING_ARG (3))); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-WINDOW-SET-INPUT-HINT", Prim_x_window_set_input_hint, 2, 2, - "Set the input hint of WINDOW to INPUT.") -{ - PRIMITIVE_HEADER (2); - xw_set_wm_input_hint ((x_window_arg (1)), (BOOLEAN_ARG (2))); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-WINDOW-SET-INPUT-FOCUS", Prim_x_window_set_input_focus, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - Display * display = (XW_DISPLAY (xw)); - void * handle = (push_x_error_info (display)); - - XSetInputFocus (display, - (XW_WINDOW (xw)), - RevertToParent, - ((Time) (arg_ulong_integer (2)))); - if (any_x_errors_p (display)) - { - pop_x_error_info (handle); - error_bad_range_arg (1); - } - pop_x_error_info (handle); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-WINDOW-SET-TRANSIENT-FOR-HINT", Prim_x_window_set_transient_for, 2, 2, - "Set the transient-for hint of WINDOW to PRIMARY-WINDOW.") -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - struct xwindow * transient_for = (x_window_arg (2)); - if ((xw == transient_for) || ((XW_XD (xw)) != (XW_XD (transient_for)))) - error_bad_range_arg (2); - XSetTransientForHint - ((XW_DISPLAY (xw)), - (XW_WINDOW (xw)), - (XW_WINDOW (transient_for))); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -/* WM Control Primitives */ - -DEFINE_PRIMITIVE ("X-WINDOW-MAP", Prim_x_window_map, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - { - struct xwindow * xw = (x_window_arg (1)); - XMapWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw))); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-WINDOW-ICONIFY", Prim_x_window_iconify, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - { - struct xwindow * xw = (x_window_arg (1)); - Display * display = (XW_DISPLAY (xw)); - XIconifyWindow (display, (XW_WINDOW (xw)), (DefaultScreen (display))); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-WINDOW-WITHDRAW", Prim_x_window_withdraw, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - { - struct xwindow * xw = (x_window_arg (1)); - Display * display = (XW_DISPLAY (xw)); - XWithdrawWindow (display, (XW_WINDOW (xw)), (DefaultScreen (display))); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -/* The following shouldn't be used on top-level windows. Instead use - ICONIFY or WITHDRAW. */ -DEFINE_PRIMITIVE ("X-WINDOW-UNMAP", Prim_x_window_unmap, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - { - struct xwindow * xw = (x_window_arg (1)); - XUnmapWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw))); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-WINDOW-SET-SIZE", Prim_x_window_set_size, 3, 3, 0) -{ - PRIMITIVE_HEADER (3); - { - struct xwindow * xw = (x_window_arg (1)); - unsigned int extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw))); - XResizeWindow ((XW_DISPLAY (xw)), - (XW_WINDOW (xw)), - ((arg_ulong_integer (2)) + extra), - ((arg_ulong_integer (3)) + extra)); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-WINDOW-RAISE", Prim_x_window_raise, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - { - struct xwindow * xw = (x_window_arg (1)); - XRaiseWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw))); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-WINDOW-LOWER", Prim_x_window_lower, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - { - struct xwindow * xw = (x_window_arg (1)); - XLowerWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw))); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-WINDOW-GET-SIZE", Prim_x_window_get_size, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - { - struct xwindow * xw = (x_window_arg (1)); - unsigned int extra; - - get_wm_decor_geometry (xw); - extra = (2 * (XW_WM_DECOR_BORDER_WIDTH (xw))); - PRIMITIVE_RETURN - (cons ((ulong_to_integer ((XW_WM_DECOR_PIXEL_WIDTH (xw)) + extra)), - (ulong_to_integer ((XW_WM_DECOR_PIXEL_HEIGHT (xw)) + extra)))); - } -} - -DEFINE_PRIMITIVE ("X-WINDOW-GET-POSITION", Prim_x_window_get_position, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - { - struct xwindow * xw = (x_window_arg (1)); - get_wm_decor_geometry (xw); - PRIMITIVE_RETURN (cons ((long_to_integer (XW_WM_DECOR_X (xw))), - (long_to_integer (XW_WM_DECOR_Y (xw))))); - } -} - -DEFINE_PRIMITIVE ("X-WINDOW-SET-POSITION", Prim_x_window_set_position, 3, 3, 0) -{ - PRIMITIVE_HEADER (3); - move_window ((x_window_arg (1)), - (arg_integer (2)), - (arg_integer (3))); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -static void -move_window (struct xwindow * xw, int x, int y) -{ - if ((XW_UPDATE_NORMAL_HINTS (xw)) != 0) - (* (XW_UPDATE_NORMAL_HINTS (xw))) (xw); - if ((XW_WM_TYPE (xw)) == X_WMTYPE_A) - { - x += (XW_MOVE_OFFSET_X (xw)); - y += (XW_MOVE_OFFSET_Y (xw)); - } - XMoveWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), x, y); - if ((XW_WM_TYPE (xw)) == X_WMTYPE_UNKNOWN) - { - (XW_EXPECTED_X (xw)) = x; - (XW_EXPECTED_Y (xw)) = y; - (XW_CHECK_EXPECTED_MOVE_P (xw)) = 1; - } -} - -static void -check_expected_move (struct xwindow * xw) -{ - if (((XW_WM_DECOR_X (xw)) == (XW_EXPECTED_X (xw))) - && ((XW_WM_DECOR_Y (xw)) == (XW_EXPECTED_Y (xw)))) - { - if ((XW_WM_TYPE (xw)) == X_WMTYPE_UNKNOWN) - (XW_WM_TYPE (xw)) = X_WMTYPE_B; - } - else - { - (XW_WM_TYPE (xw)) = X_WMTYPE_A; - (XW_MOVE_OFFSET_X (xw)) = ((XW_EXPECTED_X (xw)) - (XW_WM_DECOR_X (xw))); - (XW_MOVE_OFFSET_Y (xw)) = ((XW_EXPECTED_Y (xw)) - (XW_WM_DECOR_Y (xw))); - move_window (xw, (XW_EXPECTED_X (xw)), (XW_EXPECTED_Y (xw))); - } - (XW_CHECK_EXPECTED_MOVE_P (xw)) = 0; -} - -/* Font Structure Primitive */ - -#define FONT_STRUCTURE_MAX_CONVERTED_SIZE (10+1 + 256+1 + ((5+1) * (256+2))) - /* font-structure-words + - char-struct-vector + - char-struct-words * maximum-number-possible */ - -static SCHEME_OBJECT -convert_char_struct (XCharStruct * char_struct) -{ - if (((char_struct->lbearing) == 0) - && ((char_struct->rbearing) == 0) - && ((char_struct->width) == 0) - && ((char_struct->ascent) == 0) - && ((char_struct->descent) == 0)) - return (SHARP_F); - { - SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 5, true)); - VECTOR_SET (result, 0, (long_to_integer (char_struct->lbearing))); - VECTOR_SET (result, 1, (long_to_integer (char_struct->rbearing))); - VECTOR_SET (result, 2, (long_to_integer (char_struct->width))); - VECTOR_SET (result, 3, (long_to_integer (char_struct->ascent))); - VECTOR_SET (result, 4, (long_to_integer (char_struct->descent))); - return (result); - } -} - -static SCHEME_OBJECT -convert_font_struct (SCHEME_OBJECT font_name, XFontStruct * font) -{ - SCHEME_OBJECT result; - if (font == 0) - return SHARP_F; - /* Handle only 8-bit fonts because of laziness. */ - if (((font->min_byte1) != 0) || ((font->max_byte1) != 0)) - return SHARP_F; - - result = (allocate_marked_vector (TC_VECTOR, 10, true)); - if ((font->per_char) == 0) - VECTOR_SET (result, 6, SHARP_F); - else - { - unsigned int start_index = (font->min_char_or_byte2); - unsigned int length = ((font->max_char_or_byte2) - start_index + 1); - SCHEME_OBJECT character_vector - = (allocate_marked_vector (TC_VECTOR, length, true)); - unsigned int index; - for (index = 0; (index < length); index += 1) - VECTOR_SET (character_vector, - index, - (convert_char_struct ((font->per_char) + index))); - VECTOR_SET (result, 6, (ulong_to_integer (start_index))); - VECTOR_SET (result, 7, character_vector); - } - VECTOR_SET (result, 0, font_name); - VECTOR_SET (result, 1, (ulong_to_integer (font->direction))); - VECTOR_SET (result, 2, - (BOOLEAN_TO_OBJECT ((font->all_chars_exist) == True))); - VECTOR_SET (result, 3, (ulong_to_integer (font->default_char))); - VECTOR_SET (result, 4, (convert_char_struct (& (font->min_bounds)))); - VECTOR_SET (result, 5, (convert_char_struct (& (font->max_bounds)))); - VECTOR_SET (result, 8, (long_to_integer (font->ascent))); - VECTOR_SET (result, 9, (long_to_integer (font->descent))); - - return result; -} - -DEFINE_PRIMITIVE ("X-FONT-STRUCTURE", Prim_x_font_structure, 2, 2, - "(DISPLAY FONT)\n\ -FONT is either a font name or a font ID.") -{ - PRIMITIVE_HEADER (2); - Primitive_GC_If_Needed (FONT_STRUCTURE_MAX_CONVERTED_SIZE); - { - SCHEME_OBJECT font_name = (ARG_REF (2)); - Display * display = (XD_DISPLAY (x_display_arg (1))); - XFontStruct * font = 0; - bool by_name = STRING_P (font_name); - SCHEME_OBJECT result; - - if (by_name) - font = XLoadQueryFont (display, (STRING_POINTER (font_name))); - else - font = XQueryFont (display, ((XID) (integer_to_ulong (ARG_REF (2))))); - - if (font == 0) - PRIMITIVE_RETURN (SHARP_F); - - result = convert_font_struct (font_name, font); - - if (by_name) - XFreeFont (display, font); - PRIMITIVE_RETURN (result); - } -} - -DEFINE_PRIMITIVE ("X-WINDOW-FONT-STRUCTURE", Prim_x_window_font_structure, 1, 1, - "(X-WINDOW)\n\ -Returns the font-structure for the font currently associated with X-WINDOW.") -{ - XFontStruct *font; - PRIMITIVE_HEADER (1); - Primitive_GC_If_Needed (FONT_STRUCTURE_MAX_CONVERTED_SIZE); - font = XW_FONT (x_window_arg (1)); - PRIMITIVE_RETURN (convert_font_struct (ulong_to_integer (font->fid), font)); -} - -DEFINE_PRIMITIVE ("X-LIST-FONTS", Prim_x_list_fonts, 3, 3, - "(DISPLAY PATTERN LIMIT)\n\ -LIMIT is an exact non-negative integer or #F for no limit.\n\ -Returns #F or a vector of at least one string.") -{ - PRIMITIVE_HEADER (1); - { - int actual_count = 0; - char ** names - = (XListFonts ((XD_DISPLAY (x_display_arg (1))), - (STRING_ARG (2)), - ((FIXNUM_P (ARG_REF (3))) - ? (FIXNUM_TO_LONG (ARG_REF (3))) - : 1000000), - (&actual_count))); - if (names == 0) - PRIMITIVE_RETURN (SHARP_F); - { - unsigned int words = (actual_count + 1); /* the vector of strings */ - unsigned int i; - for (i = 0; (i < actual_count); i += 1) - words += (STRING_LENGTH_TO_GC_LENGTH (strlen (names[i]))); - if (GC_NEEDED_P (words)) - { - /* this causes the primitive to be restarted, so deallocate names */ - XFreeFontNames (names); - Primitive_GC (words); - /* notreached */ - } - } - { - SCHEME_OBJECT result - = (allocate_marked_vector (TC_VECTOR, actual_count, false)); - unsigned int i; - for (i = 0; (i < actual_count); i += 1) - VECTOR_SET (result, i, (char_pointer_to_string (names[i]))); - XFreeFontNames (names); - PRIMITIVE_RETURN (result); - } - } -} - -/* Atoms */ - -DEFINE_PRIMITIVE ("X-INTERN-ATOM", Prim_x_intern_atom, 3, 3, 0) -{ - PRIMITIVE_HEADER (3); - PRIMITIVE_RETURN - (ulong_to_integer (XInternAtom ((XD_DISPLAY (x_display_arg (1))), - (STRING_ARG (2)), - (BOOLEAN_ARG (3))))); -} - -DEFINE_PRIMITIVE ("X-GET-ATOM-NAME", Prim_x_get_atom_name, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xdisplay * xd = (x_display_arg (1)); - Display * display = (XD_DISPLAY (xd)); - void * handle = (push_x_error_info (display)); - char * name = (XGetAtomName (display, (arg_ulong_integer (2)))); - unsigned char error_code = (x_error_code (display)); - SCHEME_OBJECT result - = ((error_code == 0) - ? (char_pointer_to_string (name)) - : (ulong_to_integer (error_code))); - if (name != 0) - XFree (name); - pop_x_error_info (handle); - PRIMITIVE_RETURN (result); - } -} - -/* Window Properties */ - -static SCHEME_OBJECT -char_ptr_to_prop_data_32 (const unsigned char * data, unsigned long nitems) -{ - SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, nitems, 1)); - unsigned long index; - for (index = 0; (index < nitems); index += 1) - VECTOR_SET (result, index, (ulong_to_integer ((CARD32) ((long *) data) [index]))); - return (result); -} - -static SCHEME_OBJECT -char_ptr_to_prop_data_16 (const unsigned char * data, unsigned long nitems) -{ - SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, nitems, 1)); - unsigned long index; - for (index = 0; (index < nitems); index += 1) - VECTOR_SET (result, index, (ulong_to_integer (((CARD16 *) data) [index]))); - return (result); -} - -static const unsigned char * -prop_data_32_to_char_ptr (SCHEME_OBJECT vector, unsigned long * length_return) -{ - unsigned long nitems = (VECTOR_LENGTH (vector)); - unsigned long length = (nitems * 4); - unsigned char * data = (dstack_alloc (length)); - unsigned long index; - for (index = 0; (index < nitems); index += 1) - { - SCHEME_OBJECT n = (VECTOR_REF (vector, index)); - if (!integer_to_ulong_p (n)) - return (0); - (((CARD32 *) data) [index]) = (integer_to_ulong (n)); - } - (*length_return) = length; - return (data); -} - -static const unsigned char * -prop_data_16_to_char_ptr (SCHEME_OBJECT vector, unsigned long * length_return) -{ - unsigned long nitems = (VECTOR_LENGTH (vector)); - unsigned long length = (nitems * 2); - unsigned char * data = (dstack_alloc (length)); - unsigned long index; - for (index = 0; (index < nitems); index += 1) - { - SCHEME_OBJECT n = (VECTOR_REF (vector, index)); - unsigned long un; - if (!integer_to_ulong_p (n)) - return (0); - un = (integer_to_ulong (n)); - if (un >= 65536) - return (0); - (((CARD16 *) data) [index]) = un; - } - (*length_return) = length; - return (data); -} - -DEFINE_PRIMITIVE ("X-GET-WINDOW-PROPERTY", Prim_x_get_window_property, 7, 7, 0) -{ - PRIMITIVE_HEADER (7); - { - Display * display = (XD_DISPLAY (x_display_arg (1))); - Window window = (arg_ulong_integer (2)); - Atom property = (arg_ulong_integer (3)); - long long_offset = (arg_nonnegative_integer (4)); - long long_length = (arg_nonnegative_integer (5)); - Bool delete = (BOOLEAN_ARG (6)); - Atom req_type = (arg_ulong_integer (7)); - - Atom actual_type; - int actual_format; - unsigned long nitems; - unsigned long bytes_after; - unsigned char * data; - - if ((XGetWindowProperty (display, window, property, long_offset, - long_length, delete, req_type, (&actual_type), - (&actual_format), (&nitems), (&bytes_after), - (&data))) - != Success) - error_external_return (); - if (actual_format == 0) - { - XFree (data); - PRIMITIVE_RETURN (SHARP_F); - } - if (! ((actual_format == 8) - || (actual_format == 16) - || (actual_format == 32))) - error_external_return (); - { - SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 4, 1)); - VECTOR_SET (result, 0, (ulong_to_integer (actual_type))); - VECTOR_SET (result, 1, (long_to_integer (actual_format))); - VECTOR_SET (result, 2, (ulong_to_integer (bytes_after))); - VECTOR_SET (result, 3, - (((req_type != AnyPropertyType) - && (req_type != actual_type)) - ? SHARP_F - : (actual_format == 32) - ? (char_ptr_to_prop_data_32 (data, nitems)) - : (actual_format == 16) - ? (char_ptr_to_prop_data_16 (data, nitems)) - : (memory_to_string (nitems, data)))); - XFree (data); - PRIMITIVE_RETURN (result); - } - } -} - -DEFINE_PRIMITIVE ("X-CHANGE-PROPERTY", Prim_x_change_property, 7, 7, 0) -{ - PRIMITIVE_HEADER (7); - { - Display * display = (XD_DISPLAY (x_display_arg (1))); - Window window = (arg_ulong_integer (2)); - Atom property = (arg_ulong_integer (3)); - Atom type = (arg_ulong_integer (4)); - int format = (arg_nonnegative_integer (5)); - int mode = (arg_index_integer (6, 3)); - unsigned long dlen = 0; - const unsigned char * data = 0; - void * handle; - unsigned char error_code; - - handle = (push_x_error_info (display)); - switch (format) - { - case 8: - CHECK_ARG (7, STRING_P); - data = (STRING_BYTE_PTR (ARG_REF (7))); - dlen = (STRING_LENGTH (ARG_REF (7))); - break; - case 16: - CHECK_ARG (7, VECTOR_P); - data = (prop_data_16_to_char_ptr ((ARG_REF (7)), (&dlen))); - if (data == 0) - error_bad_range_arg (7); - break; - case 32: - CHECK_ARG (7, VECTOR_P); - data = (prop_data_32_to_char_ptr ((ARG_REF (7)), (&dlen))); - if (data == 0) - error_bad_range_arg (7); - break; - default: - error_bad_range_arg (5); - break; - } - XChangeProperty (display, window, property, type, format, mode, data, dlen); - error_code = (x_error_code (display)); - pop_x_error_info (handle); - PRIMITIVE_RETURN (ulong_to_integer (error_code)); - } -} - -DEFINE_PRIMITIVE ("X-DELETE-PROPERTY", Prim_x_delete_property, 3, 3, 0) -{ - PRIMITIVE_HEADER (3); - XDeleteProperty ((XD_DISPLAY (x_display_arg (1))), - (arg_ulong_integer (2)), - (arg_ulong_integer (3))); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -/* Selections */ - -DEFINE_PRIMITIVE ("X-SET-SELECTION-OWNER", Prim_x_set_selection_owner, 4, 4, 0) -{ - PRIMITIVE_HEADER (4); - XSetSelectionOwner ((XD_DISPLAY (x_display_arg (1))), - (arg_ulong_integer (2)), - (arg_ulong_integer (3)), - (arg_ulong_integer (4))); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-GET-SELECTION-OWNER", Prim_x_get_selection_owner, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - PRIMITIVE_RETURN - (ulong_to_integer (XGetSelectionOwner ((XD_DISPLAY (x_display_arg (1))), - (arg_ulong_integer (2))))); -} - -DEFINE_PRIMITIVE ("X-CONVERT-SELECTION", Prim_x_convert_selection, 6, 6, 0) -{ - PRIMITIVE_HEADER (6); - XConvertSelection ((XD_DISPLAY (x_display_arg (1))), - (arg_ulong_integer (2)), - (arg_ulong_integer (3)), - (arg_ulong_integer (4)), - (arg_ulong_integer (5)), - (arg_ulong_integer (6))); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-SEND-SELECTION-NOTIFY", Prim_x_send_selection_notify, 6, 6, 0) -{ - PRIMITIVE_HEADER (6); - { - struct xdisplay * xd = (x_display_arg (1)); - Window requestor = (arg_ulong_integer (2)); - XSelectionEvent event; - (event.type) = SelectionNotify; - (event.display) = (XD_DISPLAY (xd)); - (event.requestor) = requestor; - (event.selection) = (arg_ulong_integer (3)); - (event.target) = (arg_ulong_integer (4)); - (event.property) = (arg_ulong_integer (5)); - (event.time) = (arg_ulong_integer (6)); - XSendEvent ((XD_DISPLAY (xd)), requestor, False, 0, ((XEvent *) (&event))); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -#ifdef COMPILE_AS_MODULE - -/* sed -n -e 's/^DEFINE_PRIMITIVE *(\([^)]*\))$/ declare_primitive (\1);/pg' \ - -e 's/^DEFINE_PRIMITIVE *(\([^)]*\)$/ declare_primitive (\1 0);/pg' */ - -void -dload_initialize_x11base (void) -{ - declare_primitive ("X-CHANGE-PROPERTY", Prim_x_change_property, 7, 7, 0); - declare_primitive ("X-CLOSE-ALL-DISPLAYS", Prim_x_close_all_displays, 0, 0, 0); - declare_primitive ("X-CLOSE-DISPLAY", Prim_x_close_display, 1, 1, 0); - declare_primitive ("X-CLOSE-WINDOW", Prim_x_close_window, 1, 1, 0); - declare_primitive ("X-CONVERT-SELECTION", Prim_x_convert_selection, 6, 6, 0); - declare_primitive ("X-DEBUG", Prim_x_debug, 1, 1, 0); - declare_primitive ("X-DELETE-PROPERTY", Prim_x_delete_property, 3, 3, 0); - declare_primitive ("X-DISPLAY-DESCRIPTOR", Prim_x_display_descriptor, 1, 1, 0); - declare_primitive ("X-DISPLAY-FLUSH", Prim_x_display_flush, 1, 1, 0); - declare_primitive ("X-DISPLAY-GET-DEFAULT", Prim_x_display_get_default, 3, 3, 0); - declare_primitive ("X-DISPLAY-GET-SIZE", Prim_x_display_get_size, 2, 2, 0); - declare_primitive ("X-DISPLAY-PROCESS-EVENTS", Prim_x_display_process_events, 2, 2, 0); - declare_primitive ("X-DISPLAY-SYNC", Prim_x_display_sync, 2, 2, 0); - declare_primitive ("X-FONT-STRUCTURE", Prim_x_font_structure, 2, 2, 0); - declare_primitive ("X-GET-ATOM-NAME", Prim_x_get_atom_name, 2, 2, 0); - declare_primitive ("X-GET-SELECTION-OWNER", Prim_x_get_selection_owner, 2, 2, 0); - declare_primitive ("X-GET-WINDOW-PROPERTY", Prim_x_get_window_property, 7, 7, 0); - declare_primitive ("X-ID->WINDOW", Prim_x_id_to_window, 2, 2, 0); - declare_primitive ("X-INTERN-ATOM", Prim_x_intern_atom, 3, 3, 0); - declare_primitive ("X-LIST-FONTS", Prim_x_list_fonts, 3, 3, 0); - declare_primitive ("X-MAX-REQUEST-SIZE", Prim_x_max_request_size, 1, 1, 0); - declare_primitive ("X-OPEN-DISPLAY", Prim_x_open_display, 1, 1, 0); - declare_primitive ("X-SELECT-INPUT", Prim_x_select_input, 3, 3, 0); - declare_primitive ("X-SEND-SELECTION-NOTIFY", Prim_x_send_selection_notify, 6, 6, 0); - declare_primitive ("X-SET-DEFAULT-FONT", Prim_x_set_default_font, 2, 2, 0); - declare_primitive ("X-SET-SELECTION-OWNER", Prim_x_set_selection_owner, 4, 4, 0); - declare_primitive ("X-WINDOW-ANDC-EVENT-MASK", Prim_x_window_andc_event_mask, 2, 2, 0); - declare_primitive ("X-WINDOW-BEEP", Prim_x_window_beep, 1, 1, 0); - declare_primitive ("X-WINDOW-CLEAR", Prim_x_window_clear, 1, 1, 0); - declare_primitive ("X-WINDOW-COORDS-LOCAL->ROOT", Prim_x_window_coords_local2root, 3, 3, 0); - declare_primitive ("X-WINDOW-COORDS-ROOT->LOCAL", Prim_x_window_coords_root2local, 3, 3, 0); - declare_primitive ("X-WINDOW-DISPLAY", Prim_x_window_display, 1, 1, 0); - declare_primitive ("X-WINDOW-EVENT-MASK", Prim_x_window_event_mask, 1, 1, 0); - declare_primitive ("X-WINDOW-FLUSH", Prim_x_window_flush, 1, 1, 0); - declare_primitive ("X-WINDOW-FONT-STRUCTURE", Prim_x_window_font_structure, 1, 1, 0); - declare_primitive ("X-WINDOW-GET-POSITION", Prim_x_window_get_position, 1, 1, 0); - declare_primitive ("X-WINDOW-GET-SIZE", Prim_x_window_get_size, 1, 1, 0); - declare_primitive ("X-WINDOW-ICONIFY", Prim_x_window_iconify, 1, 1, 0); - declare_primitive ("X-WINDOW-ID", Prim_x_window_id, 1, 1, 0); - declare_primitive ("X-WINDOW-LOWER", Prim_x_window_lower, 1, 1, 0); - declare_primitive ("X-WINDOW-MAP", Prim_x_window_map, 1, 1, 0); - declare_primitive ("X-WINDOW-OR-EVENT-MASK", Prim_x_window_or_event_mask, 2, 2, 0); - declare_primitive ("X-WINDOW-QUERY-POINTER", Prim_x_window_query_pointer, 1, 1, 0); - declare_primitive ("X-WINDOW-RAISE", Prim_x_window_raise, 1, 1, 0); - declare_primitive ("X-WINDOW-SET-BACKGROUND-COLOR", Prim_x_window_set_background_color, 2, 2, 0); - declare_primitive ("X-WINDOW-SET-BORDER-COLOR", Prim_x_window_set_border_color, 2, 2, 0); - declare_primitive ("X-WINDOW-SET-BORDER-WIDTH", Prim_x_window_set_border_width, 2, 2, 0); - declare_primitive ("X-WINDOW-SET-CLASS-HINT", Prim_x_window_set_class_hint, 3, 3, 0); - declare_primitive ("X-WINDOW-SET-CURSOR-COLOR", Prim_x_window_set_cursor_color, 2, 2, 0); - declare_primitive ("X-WINDOW-SET-EVENT-MASK", Prim_x_window_set_event_mask, 2, 2, 0); - declare_primitive ("X-WINDOW-SET-FONT", Prim_x_window_set_font, 2, 2, 0); - declare_primitive ("X-WINDOW-SET-FOREGROUND-COLOR", Prim_x_window_set_foreground_color, 2, 2, 0); - declare_primitive ("X-WINDOW-SET-ICON-NAME", Prim_x_window_set_icon_name, 2, 2, 0); - declare_primitive ("X-WINDOW-SET-INPUT-FOCUS", Prim_x_window_set_input_focus, 2, 2, 0); - declare_primitive ("X-WINDOW-SET-INPUT-HINT", Prim_x_window_set_input_hint, 2, 2, 0); - declare_primitive ("X-WINDOW-SET-INTERNAL-BORDER-WIDTH", Prim_x_window_set_internal_border_width, 2, 2, 0); - declare_primitive ("X-WINDOW-SET-MOUSE-COLOR", Prim_x_window_set_mouse_color, 2, 2, 0); - declare_primitive ("X-WINDOW-SET-MOUSE-SHAPE", Prim_x_window_set_mouse_shape, 2, 2, 0); - declare_primitive ("X-WINDOW-SET-NAME", Prim_x_window_set_name, 2, 2, 0); - declare_primitive ("X-WINDOW-SET-POSITION", Prim_x_window_set_position, 3, 3, 0); - declare_primitive ("X-WINDOW-SET-SIZE", Prim_x_window_set_size, 3, 3, 0); - declare_primitive ("X-WINDOW-SET-TRANSIENT-FOR-HINT", Prim_x_window_set_transient_for, 2, 2, 0); - declare_primitive ("X-WINDOW-UNMAP", Prim_x_window_unmap, 1, 1, 0); - declare_primitive ("X-WINDOW-WITHDRAW", Prim_x_window_withdraw, 1, 1, 0); - declare_primitive ("X-WINDOW-X-SIZE", Prim_x_window_x_size, 1, 1, 0); - declare_primitive ("X-WINDOW-Y-SIZE", Prim_x_window_y_size, 1, 1, 0); -} - -void -dload_finalize_x11base (void) -{ - if (initialization_done) - x_close_all_displays (); -} - -#endif /* defined (COMPILE_AS_MODULE) */ diff --git a/src/microcode/x11color.c b/src/microcode/x11color.c deleted file mode 100644 index 359d11cd9..000000000 --- a/src/microcode/x11color.c +++ /dev/null @@ -1,571 +0,0 @@ -/* -*-C-*- - -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 - 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. - -*/ - -/* Primitives for dealing with colors and color maps */ - -#include "scheme.h" -#include "prims.h" -#include "x11.h" - -DEFINE_PRIMITIVE ("X-GET-WINDOW-ATTRIBUTES", Prim_x_get_window_attributes, 1, 1, 0) -{ - PRIMITIVE_HEADER(1); - { - struct xwindow * xw = (x_window_arg (1)); - XWindowAttributes a; - if (! (XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&a)))) - error_external_return (); - { - SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 23, true)); - VECTOR_SET (result, 0, (long_to_integer (a . x))); - VECTOR_SET (result, 1, (long_to_integer (a . y))); - VECTOR_SET (result, 2, (long_to_integer (a . width))); - VECTOR_SET (result, 3, (long_to_integer (a . height))); - VECTOR_SET (result, 4, (long_to_integer (a . border_width))); - VECTOR_SET (result, 5, (long_to_integer (a . depth))); - VECTOR_SET (result, 6, (X_VISUAL_TO_OBJECT (a . visual))); - VECTOR_SET (result, 7, (long_to_integer (a . root))); - VECTOR_SET (result, 8, (long_to_integer (a . class))); - VECTOR_SET (result, 9, (long_to_integer (a . bit_gravity))); - VECTOR_SET (result, 10, (long_to_integer (a . win_gravity))); - VECTOR_SET (result, 11, (long_to_integer (a . backing_store))); - VECTOR_SET (result, 12, (long_to_integer (a . backing_planes))); - VECTOR_SET (result, 13, (long_to_integer (a . backing_pixel))); - VECTOR_SET (result, 14, (BOOLEAN_TO_OBJECT (a . save_under))); - VECTOR_SET (result, 15, - (X_COLORMAP_TO_OBJECT ((a . colormap), (XW_XD (xw))))); - VECTOR_SET (result, 16, (BOOLEAN_TO_OBJECT (a . map_installed))); - VECTOR_SET (result, 17, (long_to_integer (a . map_state))); - VECTOR_SET (result, 18, (long_to_integer (a . all_event_masks))); - VECTOR_SET (result, 19, (long_to_integer (a . your_event_mask))); - VECTOR_SET (result, 20, (long_to_integer (a . do_not_propagate_mask))); - VECTOR_SET (result, 21, (BOOLEAN_TO_OBJECT (a . override_redirect))); - VECTOR_SET (result, 22, - (long_to_integer (XScreenNumberOfScreen (a . screen)))); - PRIMITIVE_RETURN (result); - } - } -} - -/* Visuals */ - -DEFINE_PRIMITIVE ("X-GET-DEFAULT-VISUAL", Prim_x_get_default_visual, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - PRIMITIVE_RETURN - (X_VISUAL_TO_OBJECT - (XDefaultVisual ((XD_DISPLAY (x_display_arg (1))), (arg_integer (2))))); -} - -DEFINE_PRIMITIVE ("X-WINDOW-VISUAL", Prim_x_window_visual, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - { - struct xwindow * xw = (x_window_arg (1)); - XWindowAttributes a; - if (! (XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&a)))) - error_external_return (); - PRIMITIVE_RETURN (X_VISUAL_TO_OBJECT (a . visual)); - } -} - -DEFINE_PRIMITIVE ("X-VISUAL-DEALLOCATE", Prim_x_visual_deallocate, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - deallocate_x_visual (x_visual_arg (1)); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE("X-GET-VISUAL-INFO", Prim_x_get_visual_info, 10, 10, 0) -/* Inputs: Scheme window or display - (the remaining are either #F or a valid value) - Visual-ID - Screen number (or #F is window supplied) - Depth - Class - Red-mask (integer) - Green-mask (integer) - Blue-mask (integer) - Colormap size - Bits per RGB - - Returns a vector of vectors, each of which has the following format: - Visual (Scheme format, for use in later calls) - Visual-ID - Screen number - Depth - Class - Red-mask (integer) - Green-mask (integer) - Blue-mask (integer) - Colormap size - Bits per RGB -*/ -#define LOAD_IF(argno, type, field, mask_bit) \ - if (ARG_REF(argno) != SHARP_F) \ - { VI.field = type arg_integer(argno); \ - VIMask |= mask_bit; \ - } -{ PRIMITIVE_HEADER (10); - { Display *dpy; - long ScreenNumber; - XVisualInfo VI, *VIList, *ThisVI; - long VIMask = VisualNoMask; - long AnswerSize, i; - int AnswerCount; - SCHEME_OBJECT Result, This_Vector; - - if (ARG_REF(3) == SHARP_F) - { struct xwindow * xw = x_window_arg (1); - XWindowAttributes attrs; - - dpy = XW_DISPLAY(xw); - XGetWindowAttributes(dpy, XW_WINDOW(xw), &attrs); - ScreenNumber = XScreenNumberOfScreen(attrs.screen); - } - else - { struct xdisplay * xd = x_display_arg (1); - ScreenNumber = arg_integer(3); - dpy = XD_DISPLAY(xd); - } - VI.screen = ScreenNumber; - LOAD_IF(2, (VisualID), visualid, VisualIDMask); - LOAD_IF(4, (unsigned int), depth, VisualDepthMask); - LOAD_IF(5, (int), class, VisualClassMask); - LOAD_IF(6, (unsigned long), red_mask, VisualRedMaskMask); - LOAD_IF(7, (unsigned long), green_mask, VisualGreenMaskMask); - LOAD_IF(8, (unsigned long), blue_mask, VisualBlueMaskMask); - LOAD_IF(9, (int), colormap_size, VisualColormapSizeMask); - LOAD_IF(10, (int), bits_per_rgb, VisualBitsPerRGBMask); - VIList = XGetVisualInfo(dpy, VIMask, &VI, &AnswerCount); - AnswerSize = (AnswerCount + 1) + (11 * AnswerCount); - if (GC_NEEDED_P (AnswerSize)) - { XFree((void *) VIList); - Primitive_GC (AnswerSize); - } - Result = allocate_marked_vector (TC_VECTOR, AnswerCount, false); - for (i=0, ThisVI=VIList; i < AnswerCount; i++, ThisVI++) - { This_Vector = allocate_marked_vector(TC_VECTOR, 10, false); - VECTOR_SET(This_Vector, 0, (X_VISUAL_TO_OBJECT (ThisVI->visual))); - VECTOR_SET(This_Vector, 1, long_to_integer((long) ThisVI->visualid)); - VECTOR_SET(This_Vector, 2, long_to_integer(ThisVI->screen)); - VECTOR_SET(This_Vector, 3, long_to_integer(ThisVI->depth)); - VECTOR_SET(This_Vector, 4, long_to_integer(ThisVI->class)); - VECTOR_SET(This_Vector, 5, long_to_integer(ThisVI->red_mask)); - VECTOR_SET(This_Vector, 6, long_to_integer(ThisVI->green_mask)); - VECTOR_SET(This_Vector, 7, long_to_integer(ThisVI->blue_mask)); - VECTOR_SET(This_Vector, 8, long_to_integer(ThisVI->colormap_size)); - VECTOR_SET(This_Vector, 9, long_to_integer(ThisVI->bits_per_rgb)); - VECTOR_SET(Result, i, This_Vector); - } - XFree((void *) VIList); - PRIMITIVE_RETURN(Result); - } -} - -/* Colormaps */ - -DEFINE_PRIMITIVE ("X-GET-DEFAULT-COLORMAP", Prim_x_get_default_colormap, 2, 2, - "Given DISPLAY and SCREEN-NUMBER, return default colormap for screen.") -{ - PRIMITIVE_HEADER (2); - { - struct xdisplay * xd = (x_display_arg (1)); - PRIMITIVE_RETURN - (X_COLORMAP_TO_OBJECT - ((XDefaultColormap ((XD_DISPLAY (xd)), (arg_integer (2)))), xd)); - } -} - -DEFINE_PRIMITIVE ("X-WINDOW-COLORMAP", Prim_x_window_colormap, 1, 1, - "Return WINDOW's colormap.") -{ - PRIMITIVE_HEADER (1); - { - struct xwindow * xw = (x_window_arg (1)); - XWindowAttributes a; - if (! (XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&a)))) - error_external_return (); - PRIMITIVE_RETURN (X_COLORMAP_TO_OBJECT ((a . colormap), (XW_XD (xw)))); - } -} - -DEFINE_PRIMITIVE ("X-SET-WINDOW-COLORMAP", Prim_x_set_window_colormap, 2, 2, - "Set WINDOW's colormap to COLORMAP.") -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - XSetWindowColormap ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), - (XCM_COLORMAP (x_colormap_arg (2)))); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-CREATE-COLORMAP", Prim_x_create_colormap, 3, 3, - "Given WINDOW, and VISUAL, create and return a colormap.\n\ -If third arg WRITEABLE is true, returned colormap may be modified.") -{ - PRIMITIVE_HEADER (3); - { - struct xwindow * xw = (x_window_arg (1)); - PRIMITIVE_RETURN - (X_COLORMAP_TO_OBJECT - ((XCreateColormap ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), - (XV_VISUAL (x_visual_arg (2))), (BOOLEAN_ARG (3)))), - (XW_XD (xw)))); - } -} - -DEFINE_PRIMITIVE ("X-COPY-COLORMAP-AND-FREE", Prim_x_copy_colormap_and_free, 1, 1, - "Return a new copy of COLORMAP.") -{ - PRIMITIVE_HEADER (1); - { - struct xcolormap * xcm = (x_colormap_arg (1)); - PRIMITIVE_RETURN - (X_COLORMAP_TO_OBJECT - ((XCopyColormapAndFree ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)))), - (XCM_XD (xcm)))); - } -} - -DEFINE_PRIMITIVE ("X-FREE-COLORMAP", Prim_x_free_colormap, 1, 1, - "Deallocate COLORMAP.") -{ - PRIMITIVE_HEADER (1); - { - struct xcolormap * xcm = (x_colormap_arg (1)); - XFreeColormap ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm))); - deallocate_x_colormap (xcm); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -#define ARG_RGB_VALUE(argno) (arg_index_integer ((argno), 65536)) - -DEFINE_PRIMITIVE ("X-ALLOCATE-COLOR", Prim_x_allocate_color, 4, 4, 0) -{ - /* Input: colormap, red, green, blue - Returns: pixel, or #F if unable to allocate color cell. */ - PRIMITIVE_HEADER (4); - { - struct xcolormap * xcm = (x_colormap_arg (1)); - XColor c; - (c . red) = (ARG_RGB_VALUE (2)); - (c . green) = (ARG_RGB_VALUE (3)); - (c . blue) = (ARG_RGB_VALUE (4)); - PRIMITIVE_RETURN - ((XAllocColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), (&c))) - ? (long_to_integer (c . pixel)) - : SHARP_F); - } -} - -DEFINE_PRIMITIVE ("X-STORE-COLOR", Prim_x_store_color, 5, 5, - "Input: colormap, pixel, r, g, b (r/g/b may be #f).") -{ - PRIMITIVE_HEADER (5); - { - struct xcolormap * xcm = (x_colormap_arg (1)); - XColor c; - (c . pixel) = (arg_nonnegative_integer (2)); - (c . flags) = 0; - if ((ARG_REF (3)) != SHARP_F) - { - (c . red) = (arg_index_integer (3, 65536)); - (c . flags) |= DoRed; - } - if ((ARG_REF (4)) != SHARP_F) - { - (c . green) = (arg_index_integer (4, 65536)); - (c . flags) |= DoGreen; - } - if ((ARG_REF (5)) != SHARP_F) - { - (c . blue) = (arg_index_integer (5, 65536)); - (c . flags) |= DoBlue; - } - XStoreColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), (&c)); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -#define CONVERT_COLOR_OBJECT(index, color, flag) \ -{ \ - SCHEME_OBJECT object = (VECTOR_REF (color_object, (index))); \ - if (object != SHARP_F) \ - { \ - if (! ((INTEGER_P (object)) && (integer_to_long_p (object)))) \ - goto losing_color_object; \ - { \ - long value = (integer_to_long (object)); \ - if ((value < 0) || (value > 65535)) \ - goto losing_color_object; \ - (colors_scan -> color) = value; \ - (colors_scan -> flags) |= (flag); \ - } \ - } \ -} - -DEFINE_PRIMITIVE ("X-STORE-COLORS", Prim_x_store_colors, 2, 2, - "Input: colormap, vector of vectors, each of\n\ -which contains pixel, r, g, b (where r/g/b can be #f or integer).") -{ - PRIMITIVE_HEADER (2); - { - struct xcolormap * xcm = (x_colormap_arg (1)); - SCHEME_OBJECT color_vector = (VECTOR_ARG (2)); - unsigned long n_colors = (VECTOR_LENGTH (color_vector)); - XColor * colors = (dstack_alloc ((sizeof (XColor)) * n_colors)); - { - SCHEME_OBJECT * vector_scan = (VECTOR_LOC (color_vector, 0)); - SCHEME_OBJECT * vector_end = (vector_scan + n_colors); - XColor * colors_scan = colors; - while (vector_scan < vector_end) - { - SCHEME_OBJECT color_object = (*vector_scan++); - if (! ((VECTOR_P (color_object)) - && ((VECTOR_LENGTH (color_object)) == 4))) - { - losing_color_object: - error_wrong_type_arg (3); - } - { - SCHEME_OBJECT pixel_object = (VECTOR_REF (color_object, 0)); - if (! ((INTEGER_P (pixel_object)) - && (integer_to_long_p (pixel_object)))) - goto losing_color_object; - (colors_scan -> pixel) = (integer_to_long (pixel_object)); - } - (colors_scan -> flags) = 0; - CONVERT_COLOR_OBJECT (1, red, DoRed); - CONVERT_COLOR_OBJECT (2, green, DoGreen); - CONVERT_COLOR_OBJECT (3, blue, DoBlue); - colors_scan += 1; - } - } - XStoreColors ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), colors, n_colors); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-FREE-COLORS", Prim_x_free_colors, 1, -1, 0) -{ - /* Input: colormap, pixel ... */ - PRIMITIVE_HEADER (LEXPR); - if (GET_LEXPR_ACTUALS < 1) - signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS); - { - struct xcolormap * xcm = (x_colormap_arg (1)); - unsigned int n_pixels = (GET_LEXPR_ACTUALS - 1); - unsigned long * pixels = - (dstack_alloc ((sizeof (unsigned long)) * n_pixels)); - unsigned int i; - for (i = 0; (i < n_pixels); i += 1) - (pixels[i]) = (arg_integer (i + 2)); - XFreeColors ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), - pixels, n_pixels, 0); - } - PRIMITIVE_RETURN(UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-QUERY-COLOR", Prim_x_query_color, 2, 2, 0) -{ - /* Input: colormap, pixel - Output: vector of red, green, blue */ - PRIMITIVE_HEADER (2); - { - struct xcolormap * xcm = (x_colormap_arg (1)); - SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 3, true)); - XColor c; - c . pixel = (arg_integer (2)); - XQueryColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), (&c)); - VECTOR_SET (result, 0, (long_to_integer (c . red))); - VECTOR_SET (result, 1, (long_to_integer (c . green))); - VECTOR_SET (result, 2, (long_to_integer (c . blue))); - PRIMITIVE_RETURN (result); - } -} - -DEFINE_PRIMITIVE ("X-QUERY-COLORS", Prim_x_query_colors, 1, -1, 0) -{ - /* Input: colormap, pixel ... - Output: a vector of vectors, each with #(red, green, blue) */ - PRIMITIVE_HEADER (LEXPR); - if (GET_LEXPR_ACTUALS < 1) - signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS); - { - struct xcolormap * xcm = (x_colormap_arg (1)); - unsigned int n_colors = (GET_LEXPR_ACTUALS - 1); - XColor * colors = (dstack_alloc ((sizeof (XColor)) * n_colors)); - unsigned int i; - for (i = 0; (i < n_colors); i += 1) - ((colors[i]) . pixel) = (arg_integer (i + 2)); - XQueryColors ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), colors, n_colors); - { - SCHEME_OBJECT result = - (allocate_marked_vector (TC_VECTOR, n_colors, true)); - for (i = 0; (i < n_colors); i += 1) - { - SCHEME_OBJECT cv = (allocate_marked_vector (TC_VECTOR, 3, true)); - VECTOR_SET (cv, 0, (long_to_integer ((colors[i]) . red))); - VECTOR_SET (cv, 1, (long_to_integer ((colors[i]) . green))); - VECTOR_SET (cv, 2, (long_to_integer ((colors[i]) . blue))); - VECTOR_SET (result, i, cv); - } - PRIMITIVE_RETURN (result); - } - } -} - -/* Named colors */ - -DEFINE_PRIMITIVE ("X-PARSE-COLOR", Prim_x_parse_color, 2, 2, 0) -{ /* Input: colormap, string - Output: vector of pixel, red, green, blue - */ - PRIMITIVE_HEADER (2); - { - struct xcolormap * xcm = (x_colormap_arg (1)); - XColor TheColor; - if (! (XParseColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), - (STRING_ARG (2)), (&TheColor)))) - PRIMITIVE_RETURN (SHARP_F); - { - SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 4, true)); - VECTOR_SET(result, 0, long_to_integer(TheColor.pixel)); - VECTOR_SET(result, 1, long_to_integer(TheColor.red)); - VECTOR_SET(result, 2, long_to_integer(TheColor.green)); - VECTOR_SET(result, 3, long_to_integer(TheColor.blue)); - PRIMITIVE_RETURN (result); - } - } -} - -DEFINE_PRIMITIVE ("X-ALLOCATE-NAMED-COLOR", Prim_x_allocate_named_color, 2, 2, 0) -{ /* Input: colormap, name - Returns: vector of closest pixel, red, green, blue - exact pixel, red, green, blue - */ - - SCHEME_OBJECT Result; - XColor Exact, Closest; - struct xcolormap * xcm; - PRIMITIVE_HEADER (2); - - xcm = (x_colormap_arg (1)); - XAllocNamedColor - ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), - (STRING_ARG (2)), &Exact, &Closest); - Result = allocate_marked_vector(TC_VECTOR, 8, true); - VECTOR_SET(Result, 0, long_to_integer(Closest.pixel)); - VECTOR_SET(Result, 1, long_to_integer(Closest.red)); - VECTOR_SET(Result, 2, long_to_integer(Closest.green)); - VECTOR_SET(Result, 3, long_to_integer(Closest.blue)); - VECTOR_SET(Result, 4, long_to_integer(Exact.pixel)); - VECTOR_SET(Result, 5, long_to_integer(Exact.red)); - VECTOR_SET(Result, 6, long_to_integer(Exact.green)); - VECTOR_SET(Result, 7, long_to_integer(Exact.blue)); - PRIMITIVE_RETURN(Result); -} - -DEFINE_PRIMITIVE("X-STORE-NAMED-COLOR", Prim_x_store_named_color, 6, 6, 0) -{ - /* Input: colormap, color name, pixel, DoRed, DoGreen, DoBlue */ - PRIMITIVE_HEADER(6); - { - struct xcolormap * xcm = (x_colormap_arg (1)); - XStoreNamedColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), - (STRING_ARG (2)), (arg_integer (4)), - (((BOOLEAN_ARG (4)) ? DoRed : 0) - | ((BOOLEAN_ARG (5)) ? DoGreen : 0) - | ((BOOLEAN_ARG (6)) ? DoBlue : 0))); - } - PRIMITIVE_RETURN(UNSPECIFIC); -} - -DEFINE_PRIMITIVE("X-LOOKUP-COLOR", Prim_x_lookup_color, 2, 2, 0) -{ - /* Input: colormap, name - Returns: vector of closest pixel, red, green, blue - exact pixel, red, green, blue - */ - - SCHEME_OBJECT Result; - XColor Exact, Closest; - struct xcolormap * xcm; - PRIMITIVE_HEADER (2); - - xcm = (x_colormap_arg (1)); - if (! (XAllocNamedColor - ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), - (STRING_ARG (2)), &Exact, &Closest))) - PRIMITIVE_RETURN (SHARP_F); - Result = allocate_marked_vector(TC_VECTOR, 8, true); - VECTOR_SET(Result, 0, long_to_integer(Closest.pixel)); - VECTOR_SET(Result, 1, long_to_integer(Closest.red)); - VECTOR_SET(Result, 2, long_to_integer(Closest.green)); - VECTOR_SET(Result, 3, long_to_integer(Closest.blue)); - VECTOR_SET(Result, 4, long_to_integer(Exact.pixel)); - VECTOR_SET(Result, 5, long_to_integer(Exact.red)); - VECTOR_SET(Result, 6, long_to_integer(Exact.green)); - VECTOR_SET(Result, 7, long_to_integer(Exact.blue)); - PRIMITIVE_RETURN(Result); -} - -#ifdef COMPILE_AS_MODULE - -/* sed -n -e 's/^DEFINE_PRIMITIVE *(\([^)]*\))$/ declare_primitive (\1);/pg' \ - -e 's/^DEFINE_PRIMITIVE *(\([^)]*\)$/ declare_primitive (\1 0);/pg' */ - -void -dload_initialize_x11color (void) -{ - declare_primitive ("X-ALLOCATE-COLOR", Prim_x_allocate_color, 4, 4, 0); - declare_primitive ("X-ALLOCATE-NAMED-COLOR", Prim_x_allocate_named_color, 2, 2, 0); - declare_primitive ("X-COPY-COLORMAP-AND-FREE", Prim_x_copy_colormap_and_free, 1, 1, 0); - declare_primitive ("X-CREATE-COLORMAP", Prim_x_create_colormap, 3, 3, 0); - declare_primitive ("X-FREE-COLORMAP", Prim_x_free_colormap, 1, 1, 0); - declare_primitive ("X-FREE-COLORS", Prim_x_free_colors, 1, -1, 0); - declare_primitive ("X-GET-DEFAULT-COLORMAP", Prim_x_get_default_colormap, 2, 2, 0); - declare_primitive ("X-GET-DEFAULT-VISUAL", Prim_x_get_default_visual, 2, 2, 0); - declare_primitive ("X-GET-VISUAL-INFO", Prim_x_get_visual_info, 10, 10, 0); - declare_primitive ("X-GET-WINDOW-ATTRIBUTES", Prim_x_get_window_attributes, 1, 1, 0); - declare_primitive ("X-LOOKUP-COLOR", Prim_x_lookup_color, 2, 2, 0); - declare_primitive ("X-PARSE-COLOR", Prim_x_parse_color, 2, 2, 0); - declare_primitive ("X-QUERY-COLOR", Prim_x_query_color, 2, 2, 0); - declare_primitive ("X-QUERY-COLORS", Prim_x_query_colors, 1, -1, 0); - declare_primitive ("X-SET-WINDOW-COLORMAP", Prim_x_set_window_colormap, 2, 2, 0); - declare_primitive ("X-STORE-COLOR", Prim_x_store_color, 5, 5, 0); - declare_primitive ("X-STORE-COLORS", Prim_x_store_colors, 2, 2, 0); - declare_primitive ("X-STORE-NAMED-COLOR", Prim_x_store_named_color, 6, 6, 0); - declare_primitive ("X-VISUAL-DEALLOCATE", Prim_x_visual_deallocate, 1, 1, 0); - declare_primitive ("X-WINDOW-COLORMAP", Prim_x_window_colormap, 1, 1, 0); - declare_primitive ("X-WINDOW-VISUAL", Prim_x_window_visual, 1, 1, 0); -} - -#endif /* defined (COMPILE_AS_MODULE) */ diff --git a/src/microcode/x11graph.c b/src/microcode/x11graph.c deleted file mode 100644 index 07f4b506d..000000000 --- a/src/microcode/x11graph.c +++ /dev/null @@ -1,1187 +0,0 @@ -/* -*-C-*- - -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 - 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. - -*/ - -/* Simple graphics for X11 */ - -#include "scheme.h" -#include "prims.h" -#include "x11.h" - -#define RESOURCE_NAME "schemeGraphics" -#define RESOURCE_CLASS "SchemeGraphics" -#define DEFAULT_GEOMETRY "512x384+0+0" - -struct gw_extra -{ - float x_left; - float x_right; - float y_bottom; - float y_top; - float x_slope; - float y_slope; - int x_cursor; - int y_cursor; -}; - -struct xwindow_graphics -{ - struct xwindow xw; - struct gw_extra extra; -}; - -#define XW_EXTRA(xw) (& (((struct xwindow_graphics *) xw) -> extra)) - -#define XW_X_LEFT(xw) ((XW_EXTRA (xw)) -> x_left) -#define XW_X_RIGHT(xw) ((XW_EXTRA (xw)) -> x_right) -#define XW_Y_BOTTOM(xw) ((XW_EXTRA (xw)) -> y_bottom) -#define XW_Y_TOP(xw) ((XW_EXTRA (xw)) -> y_top) -#define XW_X_SLOPE(xw) ((XW_EXTRA (xw)) -> x_slope) -#define XW_Y_SLOPE(xw) ((XW_EXTRA (xw)) -> y_slope) -#define XW_X_CURSOR(xw) ((XW_EXTRA (xw)) -> x_cursor) -#define XW_Y_CURSOR(xw) ((XW_EXTRA (xw)) -> y_cursor) - -#define ROUND_FLOAT(flonum) \ - ((int) (((flonum) >= 0.0) ? ((flonum) + 0.5) : ((flonum) - 0.5))) - -#define X_COORDINATE(virtual_device_x, xw, direction) \ - (((XW_X_SLOPE (xw)) == FLT_MAX) \ - ? ((direction <= 0) ? 0 : ((int) ((XW_X_SIZE (xw)) - 1))) \ - : (ROUND_FLOAT \ - (((XW_X_SLOPE (xw)) * (virtual_device_x - (XW_X_LEFT (xw))))))) - -#define Y_COORDINATE(virtual_device_y, xw, direction) \ - (((XW_Y_SLOPE (xw)) == FLT_MAX) \ - ? ((direction <= 0) ? ((int) ((XW_Y_SIZE (xw)) - 1)) : 0) \ - : (((int) ((XW_Y_SIZE (xw)) - 1)) \ - + (ROUND_FLOAT \ - ((XW_Y_SLOPE (xw)) * (virtual_device_y - (XW_Y_BOTTOM (xw))))))) - -#define X_LENGTH(virtual_length, xw) \ - (((XW_X_SLOPE (xw)) == 0.0) \ - ? 0 \ - : ((XW_X_SLOPE (xw)) == FLT_MAX) \ - ? ((int) ((XW_X_SIZE (xw)) - 1)) \ - : (ROUND_FLOAT ((fabs (XW_X_SLOPE (xw))) * (virtual_length)))) - -#define Y_LENGTH(virtual_length, xw) \ - (((XW_Y_SLOPE (xw)) == 0.0) \ - ? 0 \ - : ((XW_Y_SLOPE (xw)) == FLT_MAX) \ - ? ((int) ((XW_Y_SIZE (xw)) - 1)) \ - : (ROUND_FLOAT ((fabs (XW_Y_SLOPE (xw))) * (virtual_length)))) - -static int -arg_x_coordinate (unsigned int arg, struct xwindow * xw, int direction) -{ - return (X_COORDINATE (((float) (arg_real_number (arg))), xw, direction)); -} - -static int -arg_y_coordinate (unsigned int arg, struct xwindow * xw, int direction) -{ - return (Y_COORDINATE (((float) (arg_real_number (arg))), xw, direction)); -} - -static SCHEME_OBJECT -x_coordinate_map (struct xwindow * xw, unsigned int x) -{ - return - (FLOAT_TO_FLONUM - ((((XW_X_SLOPE (xw)) == 0.0) || ((XW_X_SLOPE (xw)) == FLT_MAX)) - ? (XW_X_LEFT (xw)) - : ((((float) x) / (XW_X_SLOPE (xw))) + (XW_X_LEFT (xw))))); -} - -static SCHEME_OBJECT -y_coordinate_map (struct xwindow * xw, unsigned int y) -{ - return - (FLOAT_TO_FLONUM - ((((XW_Y_SLOPE (xw)) == 0.0) || ((XW_Y_SLOPE (xw)) == FLT_MAX)) - ? (XW_Y_BOTTOM (xw)) - : (((((float) y) - ((XW_Y_SIZE (xw)) - 1)) / (XW_Y_SLOPE (xw))) - + (XW_Y_BOTTOM (xw))))); -} - -static void -set_clip_rectangle (struct xwindow * xw, - int x_left, - int y_bottom, - int x_right, - int y_top) -{ - XRectangle rectangles [1]; - Display * display = (XW_DISPLAY (xw)); - unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw)); - if (x_left > x_right) - { - unsigned int x = x_left; - x_left = x_right; - x_right = x; - } - if (y_top > y_bottom) - { - unsigned int y = y_top; - y_top = y_bottom; - y_bottom = y; - } - { - unsigned int width = ((x_right + 1) - x_left); - unsigned int height = ((y_bottom + 1) - y_top); - (XW_CLIP_X (xw)) = x_left; - (XW_CLIP_Y (xw)) = y_top; - (XW_CLIP_WIDTH (xw)) = width; - (XW_CLIP_HEIGHT (xw)) = height; - ((rectangles[0]) . x) = x_left; - ((rectangles[0]) . y) = y_top; - ((rectangles[0]) . width) = width; - ((rectangles[0]) . height) = height; - } - XSetClipRectangles - (display, - (XW_NORMAL_GC (xw)), - internal_border_width, - internal_border_width, - rectangles, 1, Unsorted); - XSetClipRectangles - (display, - (XW_REVERSE_GC (xw)), - internal_border_width, - internal_border_width, - rectangles, 1, Unsorted); -} - -static void -reset_clip_rectangle (struct xwindow * xw) -{ - set_clip_rectangle - (xw, 0, ((XW_Y_SIZE (xw)) - 1), ((XW_X_SIZE (xw)) - 1), 0); -} - -static void -reset_virtual_device_coordinates (struct xwindow * xw) -{ - /* Note that the expression ((XW_c_SIZE (xw)) - 1) guarantees that - both limits of the device coordinates will be inside the window. */ - (XW_X_SLOPE (xw)) - = (((XW_X_RIGHT (xw)) == (XW_X_LEFT (xw))) - ? FLT_MAX - : ((XW_X_SIZE (xw)) <= 1) - ? 0.0 - : (((float) ((XW_X_SIZE (xw)) - 1)) - / ((XW_X_RIGHT (xw)) - (XW_X_LEFT (xw))))); - (XW_Y_SLOPE (xw)) - = (((XW_Y_BOTTOM (xw)) == (XW_Y_TOP (xw))) - ? FLT_MAX - : ((XW_Y_SIZE (xw)) <= 1) - ? 0.0 - : (((float) ((XW_Y_SIZE (xw)) - 1)) - / ((XW_Y_BOTTOM (xw)) - (XW_Y_TOP (xw))))); - reset_clip_rectangle (xw); -} - -DEFINE_PRIMITIVE ("X-GRAPHICS-SET-VDC-EXTENT", Prim_x_graphics_set_vdc_extent, 5, 5, - "(X-GRAPHICS-SET-VDC-EXTENT WINDOW X-MIN Y-MIN X-MAX Y-MAX)\n\ -Set the virtual device coordinates to the given values.") -{ - PRIMITIVE_HEADER (5); - { - struct xwindow * xw = (x_window_arg (1)); - float x_left = (arg_real_number (2)); - float y_bottom = (arg_real_number (3)); - float x_right = (arg_real_number (4)); - float y_top = (arg_real_number (5)); - (XW_X_LEFT (xw)) = x_left; - (XW_Y_BOTTOM (xw)) = y_bottom; - (XW_X_RIGHT (xw)) = x_right; - (XW_Y_TOP (xw)) = y_top; - reset_virtual_device_coordinates (xw); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-GRAPHICS-VDC-EXTENT", Prim_x_graphics_vdc_extent, 1, 1, 0) -{ - PRIMITIVE_HEADER (5); - { - struct xwindow * xw = (x_window_arg (1)); - SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 4, true)); - VECTOR_SET (result, 0, (double_to_flonum ((double) (XW_X_LEFT (xw))))); - VECTOR_SET (result, 1, (double_to_flonum ((double) (XW_Y_BOTTOM (xw))))); - VECTOR_SET (result, 2, (double_to_flonum ((double) (XW_X_RIGHT (xw))))); - VECTOR_SET (result, 3, (double_to_flonum ((double) (XW_Y_TOP (xw))))); - PRIMITIVE_RETURN (result); - } -} - -DEFINE_PRIMITIVE ("X-GRAPHICS-RESET-CLIP-RECTANGLE", Prim_x_graphics_reset_clip_rectangle, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - reset_clip_rectangle (x_window_arg (1)); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-GRAPHICS-SET-CLIP-RECTANGLE", Prim_x_graphics_set_clip_rectangle, 5, 5, - "(X-GRAPHICS-SET-CLIP-RECTANGLE WINDOW X-LEFT Y-BOTTOM X-RIGHT Y-TOP)\n\ -Set the clip rectangle to the given coordinates.") -{ - PRIMITIVE_HEADER (5); - { - struct xwindow * xw = (x_window_arg (1)); - set_clip_rectangle - (xw, - (arg_x_coordinate (2, xw, -1)), - (arg_y_coordinate (3, xw, -1)), - (arg_x_coordinate (4, xw, 1)), - (arg_y_coordinate (5, xw, 1))); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -static void -process_event (struct xwindow * xw, XEvent * event) -{ -} - -static void -reconfigure (struct xwindow * xw, unsigned int width, unsigned int height) -{ - unsigned int extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw))); - unsigned int x_size = ((width < extra) ? 0 : (width - extra)); - unsigned int y_size = ((height < extra) ? 0 : (height - extra)); - if ((x_size != (XW_X_SIZE (xw))) || (y_size != (XW_Y_SIZE (xw)))) - { - (XW_X_SIZE (xw)) = x_size; - (XW_Y_SIZE (xw)) = y_size; - reset_virtual_device_coordinates (xw); - XClearWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw))); - } -} - -DEFINE_PRIMITIVE ("X-GRAPHICS-RECONFIGURE", Prim_x_graphics_reconfigure, 3, 3, 0) -{ - PRIMITIVE_HEADER (3); - reconfigure ((x_window_arg (1)), - (arg_ulong_integer (2)), - (arg_ulong_integer (3))); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -static void -wm_set_size_hint (struct xwindow * xw, int geometry_mask, int x, int y) -{ - unsigned int extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw))); - XSizeHints * size_hints = (XAllocSizeHints ()); - if (size_hints == 0) - error_external_return (); - (size_hints -> flags) = - (PResizeInc | PMinSize | PBaseSize - | (((geometry_mask & XValue) && (geometry_mask & YValue)) - ? USPosition : PPosition) - | (((geometry_mask & WidthValue) && (geometry_mask & HeightValue)) - ? USSize : PSize)); - (size_hints -> x) = x; - (size_hints -> y) = y; - (size_hints -> width) = ((XW_X_SIZE (xw)) + extra); - (size_hints -> height) = ((XW_Y_SIZE (xw)) + extra); - (size_hints -> width_inc) = 1; - (size_hints -> height_inc) = 1; - (size_hints -> min_width) = extra; - (size_hints -> min_height) = extra; - (size_hints -> base_width) = extra; - (size_hints -> base_height) = extra; - XSetWMNormalHints ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), size_hints); - XFree ((caddr_t) size_hints); -} - -DEFINE_PRIMITIVE ("X-GRAPHICS-OPEN-WINDOW", Prim_x_graphics_open_window, 3, 3, - "(X-GRAPHICS-OPEN-WINDOW DISPLAY GEOMETRY SUPPRESS-MAP?)\n\ -Open a window on DISPLAY using GEOMETRY.\n\ -If GEOMETRY is false map window interactively.\n\ -If third argument SUPPRESS-MAP? is true, do not map the window immediately.") -{ - PRIMITIVE_HEADER (3); - { - struct xdisplay * xd = (x_display_arg (1)); - Display * display = (XD_DISPLAY (xd)); - struct drawing_attributes attributes; - struct xwindow_methods methods; - XSetWindowAttributes wattributes; - const char * resource_name = RESOURCE_NAME; - const char * resource_class = RESOURCE_CLASS; - int map_p; - - x_decode_window_map_arg - ((ARG_REF (3)), (&resource_name), (&resource_class), (&map_p)); - x_default_attributes - (display, resource_name, resource_class, (&attributes)); - (wattributes . background_pixel) = (attributes . background_pixel); - (wattributes . border_pixel) = (attributes . border_pixel); - (wattributes . backing_store) = Always; - (methods . deallocator) = 0; - (methods . event_processor) = process_event; - (methods . x_coordinate_map) = x_coordinate_map; - (methods . y_coordinate_map) = y_coordinate_map; - (methods . update_normal_hints) = 0; - { - unsigned int extra = (2 * (attributes . internal_border_width)); - int x_pos = (-1); - int y_pos = (-1); - int x_size = 512; - int y_size = 384; - int geometry_mask = - (XGeometry (display, (DefaultScreen (display)), - (((ARG_REF (2)) == SHARP_F) - ? (x_get_default - (display, resource_name, resource_class, - "geometry", "Geometry", 0)) - : (STRING_ARG (2))), - DEFAULT_GEOMETRY, (attributes . border_width), - 1, 1, extra, extra, - (&x_pos), (&y_pos), (&x_size), (&y_size))); - Window window = - (XCreateWindow - (display, - (RootWindow (display, (DefaultScreen (display)))), - x_pos, y_pos, (x_size + extra), (y_size + extra), - (attributes . border_width), - CopyFromParent, CopyFromParent, CopyFromParent, - (CWBackPixel | CWBorderPixel | CWBackingStore), - (&wattributes))); - if (window == 0) - error_external_return (); - { - struct xwindow * xw = - (x_make_window - (xd, window, x_size, y_size, (&attributes), (&methods), - (sizeof (struct xwindow_graphics)))); - (XW_X_LEFT (xw)) = ((float) (-1)); - (XW_X_RIGHT (xw)) = ((float) 1); - (XW_Y_BOTTOM (xw)) = ((float) (-1)); - (XW_Y_TOP (xw)) = ((float) 1); - reset_virtual_device_coordinates (xw); - (XW_X_CURSOR (xw)) = 0; - (XW_Y_CURSOR (xw)) = 0; - wm_set_size_hint (xw, geometry_mask, x_pos, y_pos); - xw_set_wm_input_hint (xw, 0); - xw_set_wm_name (xw, "scheme-graphics"); - xw_set_wm_icon_name (xw, "scheme-graphics"); - XSelectInput (display, window, StructureNotifyMask); - xw_make_window_map (xw, resource_name, resource_class, map_p); - PRIMITIVE_RETURN (XW_TO_OBJECT (xw)); - } - } - } -} - -DEFINE_PRIMITIVE ("X-GRAPHICS-DRAW-LINE", Prim_x_graphics_draw_line, 5, 5, - "(X-GRAPHICS-DRAW-LINE WINDOW X-START Y-START X-END Y-END)\n\ -Draw a line from the start coordinates to the end coordinates.\n\ -Subsequently move the graphics cursor to the end coordinates.") -{ - PRIMITIVE_HEADER (5); - { - struct xwindow * xw = (x_window_arg (1)); - unsigned int new_x_cursor = (arg_x_coordinate (4, xw, 0)); - unsigned int new_y_cursor = (arg_y_coordinate (5, xw, 0)); - unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw)); - XDrawLine - ((XW_DISPLAY (xw)), - (XW_WINDOW (xw)), - (XW_NORMAL_GC (xw)), - (internal_border_width + (arg_x_coordinate (2, xw, 0))), - (internal_border_width + (arg_y_coordinate (3, xw, 0))), - (internal_border_width + new_x_cursor), - (internal_border_width + new_y_cursor)); - (XW_X_CURSOR (xw)) = new_x_cursor; - (XW_Y_CURSOR (xw)) = new_y_cursor; - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-GRAPHICS-MOVE-CURSOR", Prim_x_graphics_move_cursor, 3, 3, - "(X-GRAPHICS-MOVE-CURSOR WINDOW X Y)\n\ -Move the graphics cursor to the given coordinates.") -{ - PRIMITIVE_HEADER (3); - { - struct xwindow * xw = (x_window_arg (1)); - (XW_X_CURSOR (xw)) = (arg_x_coordinate (2, xw, 0)); - (XW_Y_CURSOR (xw)) = (arg_y_coordinate (3, xw, 0)); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-GRAPHICS-DRAG-CURSOR", Prim_x_graphics_drag_cursor, 3, 3, - "(X-GRAPHICS-DRAG-CURSOR WINDOW X Y)\n\ -Draw a line from the graphics cursor to the given coordinates.\n\ -Subsequently move the graphics cursor to those coordinates.") -{ - PRIMITIVE_HEADER (3); - { - struct xwindow * xw = (x_window_arg (1)); - unsigned int new_x_cursor = (arg_x_coordinate (2, xw, 0)); - unsigned int new_y_cursor = (arg_y_coordinate (3, xw, 0)); - unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw)); - XDrawLine - ((XW_DISPLAY (xw)), - (XW_WINDOW (xw)), - (XW_NORMAL_GC (xw)), - (internal_border_width + (XW_X_CURSOR (xw))), - (internal_border_width + (XW_Y_CURSOR (xw))), - (internal_border_width + new_x_cursor), - (internal_border_width + new_y_cursor)); - (XW_X_CURSOR (xw)) = new_x_cursor; - (XW_Y_CURSOR (xw)) = new_y_cursor; - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-GRAPHICS-DRAW-POINT", Prim_x_graphics_draw_point, 3, 3, - "(X-GRAPHICS-DRAW-POINT WINDOW X Y)\n\ -Draw one point at the given coordinates.\n\ -Subsequently move the graphics cursor to those coordinates.") -{ - PRIMITIVE_HEADER (3); - { - struct xwindow * xw = (x_window_arg (1)); - unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw)); - XDrawPoint - ((XW_DISPLAY (xw)), - (XW_WINDOW (xw)), - (XW_NORMAL_GC (xw)), - (internal_border_width + (arg_x_coordinate (2, xw, 0))), - (internal_border_width + (arg_y_coordinate (3, xw, 0)))); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-GRAPHICS-DRAW-ARC", Prim_x_graphics_draw_arc, 8, 8, - "(X-GRAPHICS-DRAW-ARC WINDOW X Y RADIUS-X RADIUS-Y START-ANGLE SWEEP-ANGLE FILL?)\n\ -Draw an arc at the given coordinates, with given X and Y radii.\n\ -START-ANGLE and SWEEP-ANGLE are in degrees, anti-clocwise.\n\ -START-ANGLE is from 3 o'clock, and SWEEP-ANGLE is relative to the START-ANGLE\n\ -If FILL? is true, the arc is filled.") -{ - PRIMITIVE_HEADER (3); - { - struct xwindow * xw = (x_window_arg (1)); - unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw)); - float virtual_device_x = arg_real_number (2); - float virtual_device_y = arg_real_number (3); - float radius_x = arg_real_number (4); - float radius_y = arg_real_number (5); - float angle_start = arg_real_number (6); - float angle_sweep = arg_real_number (7); - - /* we assume a virtual coordinate system with X increasing left to - * right and Y increasing top to bottom. If we are wrong then we - * have to flip the axes and adjust the angles */ - - int x1 = (X_COORDINATE (virtual_device_x - radius_x, xw, 0)); - int x2 = (X_COORDINATE (virtual_device_x + radius_x, xw, 0)); - int y1 = (Y_COORDINATE (virtual_device_y + radius_y, xw, 0)); - int y2 = (Y_COORDINATE (virtual_device_y - radius_y, xw, 0)); - int width, height; - int angle1 = ((int)(angle_start * 64)) % (64*360); - int angle2 = ((int)(angle_sweep * 64)); - if (angle1 < 0) - angle1 = (64*360) + angle1; - /* angle1 is now 0..359 */ - if (x2 a b2)) - (graphics-draw-text g (fx a) (fy a) "."))) - - (graphics-draw-text g (fx a1) (fy a1) ".Start") - (graphics-draw-text g (fx (+ a1 a2)) (fy (+ a1 a2)) ".End"))) - -;; Test axes -(test 1 1 30 90) -(test -1 1 30 90) -(test 1 -1 30 90) -(test -1 -1 30 90) - -;; Test angles -(test 1 1 30 90) -(test 1 1 30 -90) -(test 1 1 -30 90) -(test 1 1 -30 -90) - ***********************************************************************/ - -DEFINE_PRIMITIVE ("X-GRAPHICS-DRAW-STRING", Prim_x_graphics_draw_string, 4, 4, - "(X-GRAPHICS-DRAW-STRING WINDOW X Y STRING)\n\ -Draw characters in the current font at the given coordinates, with\n\ -transparent background.") -{ - PRIMITIVE_HEADER (4); - { - struct xwindow * xw = (x_window_arg (1)); - unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw)); - char * s = (STRING_ARG (4)); - XDrawString - ((XW_DISPLAY (xw)), - (XW_WINDOW (xw)), - (XW_NORMAL_GC (xw)), - (internal_border_width + (arg_x_coordinate (2, xw, 0))), - (internal_border_width + (arg_y_coordinate (3, xw, 0))), - s, - (STRING_LENGTH (ARG_REF (4)))); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-GRAPHICS-DRAW-IMAGE-STRING", Prim_x_graphics_draw_image_string, 4, 4, - "(X-GRAPHICS-DRAW-IMAGE-STRING WINDOW X Y STRING)\n\ -Draw characters in the current font at the given coordinates, with\n\ -solid background.") -{ - PRIMITIVE_HEADER (4); - { - struct xwindow * xw = (x_window_arg (1)); - unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw)); - char * s = (STRING_ARG (4)); - XDrawImageString - ((XW_DISPLAY (xw)), - (XW_WINDOW (xw)), - (XW_NORMAL_GC (xw)), - (internal_border_width + (arg_x_coordinate (2, xw, 0))), - (internal_border_width + (arg_y_coordinate (3, xw, 0))), - s, - (STRING_LENGTH (ARG_REF (4)))); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-GRAPHICS-SET-FUNCTION", Prim_x_graphics_set_function, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - Display * display = (XW_DISPLAY (xw)); - unsigned int function = (arg_ulong_index_integer (2, 16)); - XSetFunction (display, (XW_NORMAL_GC (xw)), function); - XSetFunction (display, (XW_REVERSE_GC (xw)), function); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -static XPoint * -floating_vector_point_args (struct xwindow * xw, - unsigned int x_index, - unsigned int y_index, - unsigned int * return_n_points) -{ - SCHEME_OBJECT x_vector = (ARG_REF (x_index)); - SCHEME_OBJECT y_vector = (ARG_REF (y_index)); - unsigned int n_points; - - if (!FLONUM_P (x_vector)) - error_wrong_type_arg (x_index); - if (!FLONUM_P (y_vector)) - error_wrong_type_arg (y_index); - n_points = (FLOATING_VECTOR_LENGTH (x_vector)); - if (n_points != (FLOATING_VECTOR_LENGTH (y_vector))) - error_bad_range_arg (x_index); - { - XPoint * points = (dstack_alloc (n_points * (sizeof (XPoint)))); - double * scan_x = (FLOATING_VECTOR_LOC (x_vector, 0)); - double * end_x = (FLOATING_VECTOR_LOC (x_vector, n_points)); - double * scan_y = (FLOATING_VECTOR_LOC (y_vector, 0)); - XPoint * scan_points = points; - unsigned int border = (XW_INTERNAL_BORDER_WIDTH (xw)); - while (scan_x < end_x) - { - (scan_points -> x) = (border + (X_COORDINATE ((*scan_x++), xw, 0))); - (scan_points -> y) = (border + (X_COORDINATE ((*scan_y++), xw, 0))); - scan_points += 1; - } - (*return_n_points) = n_points; - return (points); - } -} - -DEFINE_PRIMITIVE ("X-GRAPHICS-DRAW-POINTS", Prim_x_graphics_draw_points, 3, 3, - "(X-GRAPHICS-DRAW-POINTS WINDOW X-VECTOR Y-VECTOR)\n\ -Draw multiple points.") -{ - PRIMITIVE_HEADER (3); - { - void * position = dstack_position; - struct xwindow * xw = (x_window_arg (1)); - unsigned int n_points; - XPoint * points = (floating_vector_point_args (xw, 2, 3, (&n_points))); - while (n_points > 0) - { - unsigned int this_send = ((n_points <= 4093) ? n_points : 4093); - n_points -= this_send; - XDrawPoints ((XW_DISPLAY (xw)), - (XW_WINDOW (xw)), - (XW_NORMAL_GC (xw)), - points, - this_send, - CoordModeOrigin); - points += this_send; - } - dstack_set_position (position); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-GRAPHICS-DRAW-LINES", Prim_x_graphics_draw_lines, 3, 3, - "(X-GRAPHICS-DRAW-LINES WINDOW X-VECTOR Y-VECTOR)\n\ -Draw multiple lines.") -{ - PRIMITIVE_HEADER (3); - { - void * position = dstack_position; - struct xwindow * xw = (x_window_arg (1)); - unsigned int n_points; - XPoint * points = (floating_vector_point_args (xw, 2, 3, (&n_points))); - while (n_points > 0) - { - unsigned int this_send = ((n_points <= 2047) ? n_points : 2047); - n_points -= this_send; - XDrawLines ((XW_DISPLAY (xw)), - (XW_WINDOW (xw)), - (XW_NORMAL_GC (xw)), - points, - this_send, - CoordModeOrigin); - points += (this_send - 1); - } - dstack_set_position (position); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-GRAPHICS-SET-FILL-STYLE", Prim_x_graphics_set_fill_style, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - Display * display = (XW_DISPLAY (xw)); - unsigned int fill_style = (arg_ulong_index_integer (2, 4)); - XSetFillStyle (display, (XW_NORMAL_GC (xw)), fill_style); - XSetFillStyle (display, (XW_REVERSE_GC (xw)), fill_style); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-GRAPHICS-SET-LINE-STYLE", Prim_x_graphics_set_line_style, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - Display * display = (XW_DISPLAY (xw)); - unsigned int style = (arg_ulong_index_integer (2, 3)); - XSetLineAttributes - (display, (XW_NORMAL_GC (xw)), 0, style, CapButt, JoinMiter); - XSetLineAttributes - (display, (XW_REVERSE_GC (xw)), 0, style, CapButt, JoinMiter); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-GRAPHICS-SET-DASHES", Prim_x_graphics_set_dashes, 3, 3, 0) -{ - PRIMITIVE_HEADER (3); - { - struct xwindow * xw = (x_window_arg (1)); - Display * display = (XW_DISPLAY (xw)); - char * dash_list = (STRING_ARG (3)); - unsigned int dash_list_length = (STRING_LENGTH (ARG_REF (3))); - unsigned int dash_offset = (arg_ulong_index_integer (2, dash_list_length)); - XSetDashes - (display, (XW_NORMAL_GC (xw)), dash_offset, dash_list, dash_list_length); - XSetDashes - (display, (XW_REVERSE_GC (xw)), dash_offset, dash_list, - dash_list_length); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("X-GRAPHICS-COPY-AREA", Prim_x_graphics_copy_area, 8, 8, 0) -{ - PRIMITIVE_HEADER (7); - { - struct xwindow * source_xw = x_window_arg (1); - struct xwindow * destination_xw = x_window_arg (2); - unsigned int source_internal_border_width - = (XW_INTERNAL_BORDER_WIDTH (source_xw)); - unsigned int destination_internal_border_width - = (XW_INTERNAL_BORDER_WIDTH (destination_xw)); - Display *source_display = XW_DISPLAY (source_xw); - Display *destination_display = XW_DISPLAY (destination_xw); - if (source_display != destination_display) - error_bad_range_arg (2); - XCopyArea (source_display, - (XW_WINDOW (source_xw)), - (XW_WINDOW (destination_xw)), - (XW_NORMAL_GC (source_xw)), - (source_internal_border_width - + (arg_x_coordinate (3, source_xw, -1))), - (source_internal_border_width - + (arg_y_coordinate (4, source_xw, 1))), - (X_LENGTH ((arg_real_number (5)), source_xw)), - (Y_LENGTH ((arg_real_number (6)), source_xw)), - (destination_internal_border_width - + (arg_x_coordinate (7, destination_xw, -1))), - (destination_internal_border_width - + (arg_y_coordinate (8, destination_xw, 1)))); - PRIMITIVE_RETURN (UNSPECIFIC); - } -} - -static XPoint * -x_polygon_vector_arg (struct xwindow * xw, unsigned int argno) -{ - SCHEME_OBJECT vector = (VECTOR_ARG (argno)); - unsigned long length = (VECTOR_LENGTH (vector)); - unsigned int border = (XW_INTERNAL_BORDER_WIDTH (xw)); - if ((length % 2) != 0) - error_bad_range_arg (argno); - { - XPoint * result = (x_malloc ((length / 2) * (sizeof (XPoint)))); - XPoint * scan_result = result; - SCHEME_OBJECT * scan = (& (VECTOR_REF (vector, 0))); - SCHEME_OBJECT * end = (scan + length); - SCHEME_OBJECT coord; - while (scan < end) - { - coord = (*scan++); - if (! ((REAL_P (coord)) && (real_number_to_double_p (coord)))) - error_bad_range_arg (argno); - (scan_result -> x) - = (border - + (X_COORDINATE ((real_number_to_double (coord)), xw, 0))); - coord = (*scan++); - if (! ((REAL_P (coord)) && (real_number_to_double_p (coord)))) - error_bad_range_arg (argno); - (scan_result -> y) - = (border - + (Y_COORDINATE ((real_number_to_double (coord)), xw, 0))); - scan_result += 1; - } - return (result); - } -} - -DEFINE_PRIMITIVE ("X-GRAPHICS-FILL-POLYGON", Prim_x_graphics_fill_polygon, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = x_window_arg (1); - XPoint * points = (x_polygon_vector_arg (xw, 2)); - unsigned long length = VECTOR_LENGTH (VECTOR_ARG (2)); - XFillPolygon ((XW_DISPLAY (xw)), - (XW_WINDOW (xw)), - (XW_NORMAL_GC (xw)), - points, - (length / 2), - Nonconvex, - CoordModeOrigin); - free (points); - PRIMITIVE_RETURN (UNSPECIFIC); - } -} - -static int -find_pixmap_format (Display * dpy, int depth, XPixmapFormatValues * format) -{ - XPixmapFormatValues * pixmap_formats; - int n_pixmap_formats; - XPixmapFormatValues * scan_pixmap_formats; - XPixmapFormatValues * end_pixmap_formats; - - pixmap_formats = (XListPixmapFormats (dpy, (&n_pixmap_formats))); - if (pixmap_formats == 0) - return (0); - scan_pixmap_formats = pixmap_formats; - end_pixmap_formats = (pixmap_formats + n_pixmap_formats); - while (1) - { - if (scan_pixmap_formats >= end_pixmap_formats) - return (0); - if ((scan_pixmap_formats -> depth) == depth) - { - (*format) = (*scan_pixmap_formats); - XFree (pixmap_formats); - return (1); - } - scan_pixmap_formats += 1; - } -} - -DEFINE_PRIMITIVE ("X-CREATE-IMAGE", Prim_x_create_image, 3, 3, - "(window width height)\n\ -Creates and returns an XImage object, of dimensions WIDTH by HEIGHT.\n\ -WINDOW is used to set the Display, Visual, and Depth characteristics.\n\ -The image is created by calling XCreateImage.") -{ - PRIMITIVE_HEADER (3); - { - struct xwindow * xw = (x_window_arg (1)); - Window window = (XW_WINDOW (xw)); - Display * dpy = (XW_DISPLAY (xw)); - unsigned int width = (arg_ulong_integer (2)); - unsigned int height = (arg_ulong_integer (3)); - XWindowAttributes attrs; - XPixmapFormatValues pixmap_format; - unsigned int bits_per_line; - unsigned int bitmap_pad; - unsigned int bytes_per_line; - - XGetWindowAttributes (dpy, window, (&attrs)); - if (!find_pixmap_format (dpy, (attrs . depth), (&pixmap_format))) - error_external_return (); - bits_per_line = ((pixmap_format . bits_per_pixel) * width); - bitmap_pad = (pixmap_format . scanline_pad); - if ((bits_per_line % bitmap_pad) != 0) - bits_per_line += (bitmap_pad - (bits_per_line % bitmap_pad)); - bytes_per_line = ((bits_per_line + (CHAR_BIT - 1)) / CHAR_BIT); - PRIMITIVE_RETURN - (X_IMAGE_TO_OBJECT - (XCreateImage - (dpy, - (DefaultVisualOfScreen (attrs . screen)), - (attrs . depth), - ZPixmap, - 0, - ((char *) (x_malloc (height * bytes_per_line))), - width, - height, - bitmap_pad, - bytes_per_line))); - } -} - -DEFINE_PRIMITIVE ("X-BYTES-INTO-IMAGE", Prim_x_bytes_into_image, 2, 2, - "(vector image)\n\ -VECTOR is a vector or vector-8b of pixel values stored in row-major\n\ -order; it must have the same number of pixels as IMAGE.\n\ -These pixels are written onto IMAGE by repeated calls to XPutPixel.\n\ -This procedure is equivalent to calling X-SET-PIXEL-IN-IMAGE for each\n\ -pixel in VECTOR.") -{ - PRIMITIVE_HEADER (2); - { - SCHEME_OBJECT vector = (ARG_REF (1)); - XImage * image = (XI_IMAGE (x_image_arg (2))); - unsigned long width = (image -> width); - unsigned long height = (image -> height); - if (STRING_P (vector)) - { - unsigned char * vscan; - unsigned long x; - unsigned long y; - - if ((STRING_LENGTH (vector)) != (width * height)) - error_bad_range_arg (1); - vscan = (STRING_BYTE_PTR (vector)); - for (y = 0; (y < height); y += 1) - for (x = 0; (x < width); x += 1) - XPutPixel (image, x, y, ((unsigned long) (*vscan++))); - } - else if (VECTOR_P (vector)) - { - unsigned long vlen; - SCHEME_OBJECT * vscan; - SCHEME_OBJECT * vend; - unsigned long x; - unsigned long y; - - vlen = (VECTOR_LENGTH (vector)); - if (vlen != (width * height)) - error_bad_range_arg (1); - vscan = (VECTOR_LOC (vector, 0)); - vend = (VECTOR_LOC (vector, vlen)); - while (vscan < vend) - { - SCHEME_OBJECT elt = (*vscan++); - if (! ((INTEGER_P (elt)) && (integer_to_ulong_p (elt)))) - error_bad_range_arg (1); - } - vscan = (VECTOR_LOC (vector, 0)); - for (y = 0; (y < height); y += 1) - for (x = 0; (x < width); x += 1) - XPutPixel (image, x, y, (integer_to_ulong (*vscan++))); - } - else - error_wrong_type_arg (1); - PRIMITIVE_RETURN (UNSPECIFIC); - } -} - -DEFINE_PRIMITIVE ("X-GET-PIXEL-FROM-IMAGE", Prim_x_get_image_pixel, 3, 3, - "(image x y)\n\ -The value of pixel (X,Y) of IMAGE is returned as an integer.\n\ -This is accomplished by calling XGetPixel.") -{ - PRIMITIVE_HEADER (3); - { - XImage * image = (XI_IMAGE (x_image_arg (1))); - PRIMITIVE_RETURN - (ulong_to_integer - (XGetPixel (image, - (arg_index_integer (2, (image -> width))), - (arg_index_integer (3, (image -> height)))))); - } -} - -DEFINE_PRIMITIVE ("X-SET-PIXEL-IN-IMAGE", Prim_x_set_image_pixel, 4, 4, - "(image x y pixel-value)\n\ -The pixel (X,Y) of IMAGE is modified to contain PIXEL-VALUE.\n\ -This is accomplished by calling XPutPixel.") -{ - PRIMITIVE_HEADER (4); - { - XImage * image = (XI_IMAGE (x_image_arg (1))); - XPutPixel (image, - (arg_index_integer (2, (image -> width))), - (arg_index_integer (3, (image -> height))), - (arg_ulong_integer (4))); - PRIMITIVE_RETURN (UNSPECIFIC); - } -} - -DEFINE_PRIMITIVE ("X-DESTROY-IMAGE", Prim_x_destroy_image, 1, 1, - "(image)\n\ -IMAGE is deallocated by calling XDestroyImage.") -{ - PRIMITIVE_HEADER (1); - { - struct ximage * xi = (x_image_arg (1)); - XDestroyImage (XI_IMAGE (xi)); - deallocate_x_image (xi); - PRIMITIVE_RETURN (UNSPECIFIC); - } -} - -DEFINE_PRIMITIVE ("X-DISPLAY-IMAGE", Prim_x_display_image, 8, 8, - "(image image-xoff image-yoff window window_xoff window_yoff width height)\n\ -IMAGE is drawn on WINDOW by calling XPutImage.") -{ - PRIMITIVE_HEADER (8); - { - XImage * image = (XI_IMAGE (x_image_arg (1))); - unsigned int image_width = (image -> width); - unsigned int image_height = (image -> height); - unsigned int x_offset = (arg_ulong_index_integer (2, image_width)); - unsigned int y_offset = (arg_ulong_index_integer (3, image_height)); - struct xwindow * xw = (x_window_arg (4)); - XPutImage - ((XW_DISPLAY (xw)),(XW_WINDOW (xw)),(XW_NORMAL_GC (xw)), - image, x_offset, y_offset, - (arg_x_coordinate (5, xw, -1)), - (arg_y_coordinate (6, xw, 1)), - (arg_index_integer (7, ((image_width - x_offset) + 1))), - (arg_index_integer (8, ((image_height - y_offset) + 1)))); - PRIMITIVE_RETURN (UNSPECIFIC); - } -} - -DEFINE_PRIMITIVE ("X-READ-IMAGE", Prim_x_read_image, 8, 8, - "(image image-xoff image-yoff window window_xoff window_yoff width height)\n\ -Reads the specified rectangle of WINDOW into IMAGE by calling XGetSubImage.") -{ - /* Called with Image, X-offset in image, Y-offset in image, - Window, X-offset in window, Y-offset in window, - Width, Height */ - PRIMITIVE_HEADER (8); - { struct ximage * xi = x_image_arg (1); - long XImageOffset = arg_integer(2); - long YImageOffset = arg_integer(3); - struct xwindow * xw = x_window_arg(4); - long XWindowOffset = arg_integer(5); - long YWindowOffset = arg_integer(6); - long Width = arg_integer(7); - long Height = arg_integer(8); - - XGetSubImage(XW_DISPLAY(xw), XW_WINDOW(xw), XWindowOffset, YWindowOffset, - Width, Height, -1, ZPixmap, - XI_IMAGE(xi), XImageOffset, YImageOffset); - PRIMITIVE_RETURN (UNSPECIFIC); - } -} - -DEFINE_PRIMITIVE ("X-WINDOW-DEPTH", Prim_x_window_depth, 1, 1, - "(window)\n\ -Returns the pixel depth of WINDOW as an integer.") -{ - PRIMITIVE_HEADER (1); - { - struct xwindow * xw = (x_window_arg (1)); - XWindowAttributes attrs; - XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&attrs)); - PRIMITIVE_RETURN (long_to_integer (attrs . depth)); - } -} - -DEFINE_PRIMITIVE ("X-GRAPHICS-MAP-X-COORDINATE", Prim_x_graphics_map_x_coordinate, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - int signed_xp = (arg_integer (2)); - unsigned int xp = ((signed_xp < 0) ? 0 : ((unsigned int) signed_xp)); - int bx = (xp - (XW_INTERNAL_BORDER_WIDTH (xw))); - PRIMITIVE_RETURN - (x_coordinate_map - (xw, - ((bx < 0) ? 0 - : (bx >= (XW_X_SIZE (xw))) ? ((XW_X_SIZE (xw)) - 1) - : bx))); - } -} - -DEFINE_PRIMITIVE ("X-GRAPHICS-MAP-Y-COORDINATE", Prim_x_graphics_map_y_coordinate, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - int signed_yp = (arg_integer (2)); - unsigned int yp = ((signed_yp < 0) ? 0 : ((unsigned int) signed_yp)); - int by = (yp - (XW_INTERNAL_BORDER_WIDTH (xw))); - PRIMITIVE_RETURN - (y_coordinate_map - (xw, - ((by < 0) ? 0 - : (by >= (XW_Y_SIZE (xw))) ? ((XW_Y_SIZE (xw)) - 1) - : by))); - } -} - -#ifdef COMPILE_AS_MODULE - -/* sed -n -e 's/^DEFINE_PRIMITIVE *(\([^)]*\))$/ declare_primitive (\1);/pg' \ - -e 's/^DEFINE_PRIMITIVE *(\([^)]*\)$/ declare_primitive (\1 0);/pg' */ - -void -dload_initialize_x11graph (void) -{ - declare_primitive ("X-BYTES-INTO-IMAGE", Prim_x_bytes_into_image, 2, 2, 0); - declare_primitive ("X-CREATE-IMAGE", Prim_x_create_image, 3, 3, 0); - declare_primitive ("X-DESTROY-IMAGE", Prim_x_destroy_image, 1, 1, 0); - declare_primitive ("X-DISPLAY-IMAGE", Prim_x_display_image, 8, 8, 0); - declare_primitive ("X-GET-PIXEL-FROM-IMAGE", Prim_x_get_image_pixel, 3, 3, 0); - declare_primitive ("X-GRAPHICS-COPY-AREA", Prim_x_graphics_copy_area, 8, 8, 0); - declare_primitive ("X-GRAPHICS-DRAG-CURSOR", Prim_x_graphics_drag_cursor, 3, 3, 0); - declare_primitive ("X-GRAPHICS-DRAW-ARC", Prim_x_graphics_draw_arc, 8, 8, 0); - declare_primitive ("X-GRAPHICS-DRAW-IMAGE-STRING", Prim_x_graphics_draw_image_string, 4, 4, 0); - declare_primitive ("X-GRAPHICS-DRAW-LINE", Prim_x_graphics_draw_line, 5, 5, 0); - declare_primitive ("X-GRAPHICS-DRAW-LINES", Prim_x_graphics_draw_lines, 3, 3, 0); - declare_primitive ("X-GRAPHICS-DRAW-POINT", Prim_x_graphics_draw_point, 3, 3, 0); - declare_primitive ("X-GRAPHICS-DRAW-POINTS", Prim_x_graphics_draw_points, 3, 3, 0); - declare_primitive ("X-GRAPHICS-DRAW-STRING", Prim_x_graphics_draw_string, 4, 4, 0); - declare_primitive ("X-GRAPHICS-FILL-POLYGON", Prim_x_graphics_fill_polygon, 2, 2, 0); - declare_primitive ("X-GRAPHICS-MAP-X-COORDINATE", Prim_x_graphics_map_x_coordinate, 2, 2, 0); - declare_primitive ("X-GRAPHICS-MAP-Y-COORDINATE", Prim_x_graphics_map_y_coordinate, 2, 2, 0); - declare_primitive ("X-GRAPHICS-MOVE-CURSOR", Prim_x_graphics_move_cursor, 3, 3, 0); - declare_primitive ("X-GRAPHICS-OPEN-WINDOW", Prim_x_graphics_open_window, 3, 3, 0); - declare_primitive ("X-GRAPHICS-RECONFIGURE", Prim_x_graphics_reconfigure, 3, 3, 0); - declare_primitive ("X-GRAPHICS-RESET-CLIP-RECTANGLE", Prim_x_graphics_reset_clip_rectangle, 1, 1, 0); - declare_primitive ("X-GRAPHICS-SET-CLIP-RECTANGLE", Prim_x_graphics_set_clip_rectangle, 5, 5, 0); - declare_primitive ("X-GRAPHICS-SET-DASHES", Prim_x_graphics_set_dashes, 3, 3, 0); - declare_primitive ("X-GRAPHICS-SET-FILL-STYLE", Prim_x_graphics_set_fill_style, 2, 2, 0); - declare_primitive ("X-GRAPHICS-SET-FUNCTION", Prim_x_graphics_set_function, 2, 2, 0); - declare_primitive ("X-GRAPHICS-SET-LINE-STYLE", Prim_x_graphics_set_line_style, 2, 2, 0); - declare_primitive ("X-GRAPHICS-SET-VDC-EXTENT", Prim_x_graphics_set_vdc_extent, 5, 5, 0); - declare_primitive ("X-GRAPHICS-VDC-EXTENT", Prim_x_graphics_vdc_extent, 1, 1, 0); - declare_primitive ("X-READ-IMAGE", Prim_x_read_image, 8, 8, 0); - declare_primitive ("X-SET-PIXEL-IN-IMAGE", Prim_x_set_image_pixel, 4, 4, 0); - declare_primitive ("X-WINDOW-DEPTH", Prim_x_window_depth, 1, 1, 0); -} - -#endif /* defined (COMPILE_AS_MODULE) */ diff --git a/src/microcode/x11term.c b/src/microcode/x11term.c deleted file mode 100644 index 81e3036d7..000000000 --- a/src/microcode/x11term.c +++ /dev/null @@ -1,1021 +0,0 @@ -/* -*-C-*- - -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 - 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. - -*/ - -/* X11 terminal for Edwin. */ - -#include "scheme.h" -#include "prims.h" -#include "x11.h" - -struct xterm_extra -{ - /* Dimensions of the window, in characters. Valid character - coordinates are nonnegative integers strictly less than these - limits. */ - unsigned int x_size; - unsigned int y_size; - - /* Position of the cursor, in character coordinates. */ - unsigned int cursor_x; - unsigned int cursor_y; - - /* Character map of the window's contents. See `XTERM_CHAR_LOC' for - the address arithmetic. */ - char * character_map; - - /* Bit map of the window's highlighting. */ - char * highlight_map; - - /* Nonzero iff the cursor is drawn on the window. */ - char cursor_visible_p; - - /* Nonzero iff the cursor should be drawn on the window. */ - char cursor_enabled_p; -}; - -struct xwindow_term -{ - struct xwindow xw; - struct xterm_extra extra; -}; - -#define XW_EXTRA(xw) (& (((struct xwindow_term *) xw) -> extra)) - -#define XW_X_CSIZE(xw) ((XW_EXTRA (xw)) -> x_size) -#define XW_Y_CSIZE(xw) ((XW_EXTRA (xw)) -> y_size) -#define XW_CURSOR_X(xw) ((XW_EXTRA (xw)) -> cursor_x) -#define XW_CURSOR_Y(xw) ((XW_EXTRA (xw)) -> cursor_y) -#define XW_CHARACTER_MAP(xw) ((XW_EXTRA (xw)) -> character_map) -#define XW_HIGHLIGHT_MAP(xw) ((XW_EXTRA (xw)) -> highlight_map) -#define XW_CURSOR_VISIBLE_P(xw) ((XW_EXTRA (xw)) -> cursor_visible_p) -#define XW_CURSOR_ENABLED_P(xw) ((XW_EXTRA (xw)) -> cursor_enabled_p) - -#define XTERM_CHAR_INDEX(xw, x, y) (((y) * (XW_X_CSIZE (xw))) + (x)) -#define XTERM_CHAR_LOC(xw, index) ((XW_CHARACTER_MAP (xw)) + (index)) -#define XTERM_CHAR(xw, index) (* (XTERM_CHAR_LOC (xw, index))) -#define XTERM_HL_LOC(xw, index) ((XW_HIGHLIGHT_MAP (xw)) + (index)) -#define XTERM_HL(xw, index) (* (XTERM_HL_LOC (xw, index))) - -#define XTERM_HL_GC(xw, hl) (hl ? (XW_REVERSE_GC (xw)) : (XW_NORMAL_GC (xw))) - -#define HL_ARG(arg) arg_index_integer (arg, 2) - -#define RESOURCE_NAME "schemeTerminal" -#define RESOURCE_CLASS "SchemeTerminal" -#define DEFAULT_GEOMETRY "80x40+0+0" -#define BLANK_CHAR ' ' -#define DEFAULT_HL 0 - -#define XTERM_X_PIXEL(xw, x) \ - (((x) * (FONT_WIDTH (XW_FONT (xw)))) + (XW_INTERNAL_BORDER_WIDTH (xw))) - -#define XTERM_Y_PIXEL(xw, y) \ - (((y) * (FONT_HEIGHT (XW_FONT (xw)))) + (XW_INTERNAL_BORDER_WIDTH (xw))) - -#define XTERM_DRAW_CHARS(xw, x, y, s, n, gc) \ - XDrawImageString \ - ((XW_DISPLAY (xw)), \ - (XW_WINDOW (xw)), \ - gc, \ - (XTERM_X_PIXEL (xw, x)), \ - ((XTERM_Y_PIXEL (xw, y)) + (FONT_BASE (XW_FONT (xw)))), \ - s, \ - n) - -#define CURSOR_IN_RECTANGLE(xw, x_start, x_end, y_start, y_end) \ - (((x_start) <= (XW_CURSOR_X (xw))) \ - && ((XW_CURSOR_X (xw)) < (x_end)) \ - && ((y_start) <= (XW_CURSOR_Y (xw))) \ - && ((XW_CURSOR_Y (xw)) < (y_end))) - -static void -xterm_erase_cursor (struct xwindow * xw) -{ - if (XW_CURSOR_VISIBLE_P (xw)) - { - unsigned int x = (XW_CURSOR_X (xw)); - unsigned int y = (XW_CURSOR_Y (xw)); - unsigned int index = (XTERM_CHAR_INDEX (xw, x, y)); - XTERM_DRAW_CHARS - (xw, x, y, - (XTERM_CHAR_LOC (xw, index)), - 1, - (XTERM_HL_GC (xw, (XTERM_HL (xw, index))))); - (XW_CURSOR_VISIBLE_P (xw)) = 0; - } -} - -static void -xterm_draw_cursor (struct xwindow * xw) -{ - if ((XW_CURSOR_ENABLED_P (xw)) && (! (XW_CURSOR_VISIBLE_P (xw)))) - { - unsigned int x = (XW_CURSOR_X (xw)); - unsigned int y = (XW_CURSOR_Y (xw)); - unsigned int index = (XTERM_CHAR_INDEX (xw, x, y)); - int hl = (XTERM_HL (xw, index)); - XTERM_DRAW_CHARS - (xw, x, y, - (XTERM_CHAR_LOC (xw, index)), - 1, - ((hl && ((XW_FOREGROUND_PIXEL (xw)) == (XW_CURSOR_PIXEL (xw)))) - ? (XW_NORMAL_GC (xw)) - : (XW_CURSOR_GC (xw)))); - (XW_CURSOR_VISIBLE_P (xw)) = 1; - } -} - -static void -xterm_process_event (struct xwindow * xw, XEvent * event) -{ -} - -static XSizeHints * -xterm_make_size_hints (XFontStruct * font, unsigned int extra) -{ - XSizeHints * size_hints = (XAllocSizeHints ()); - if (size_hints == 0) - error_external_return (); - (size_hints -> flags) = (PResizeInc | PMinSize | PBaseSize); - (size_hints -> width_inc) = (FONT_WIDTH (font)); - (size_hints -> height_inc) = (FONT_HEIGHT (font)); - (size_hints -> min_width) = extra; - (size_hints -> min_height) = extra; - (size_hints -> base_width) = extra; - (size_hints -> base_height) = extra; - return (size_hints); -} - -static void -xterm_set_wm_normal_hints (struct xwindow * xw, XSizeHints * size_hints) -{ - XSetWMNormalHints ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), size_hints); - XFree (size_hints); -} - -static void -xterm_update_normal_hints (struct xwindow * xw) -{ - xterm_set_wm_normal_hints - (xw, - (xterm_make_size_hints - ((XW_FONT (xw)), - (2 * (XW_INTERNAL_BORDER_WIDTH (xw)))))); -} - -static void -xterm_deallocate (struct xwindow * xw) -{ - free (XW_CHARACTER_MAP (xw)); - free (XW_HIGHLIGHT_MAP (xw)); -} - -static SCHEME_OBJECT -xterm_x_coordinate_map (struct xwindow * xw, unsigned int x) -{ - return (ulong_to_integer (x / (FONT_WIDTH (XW_FONT (xw))))); -} - -static SCHEME_OBJECT -xterm_y_coordinate_map (struct xwindow * xw, unsigned int y) -{ - return (ulong_to_integer (y / (FONT_HEIGHT (XW_FONT (xw))))); -} - -static void -xterm_copy_map_line (struct xwindow * xw, - unsigned int x_start, - unsigned int x_end, - unsigned int y_from, - unsigned int y_to) -{ - { - char * from_scan = - (XTERM_CHAR_LOC (xw, (XTERM_CHAR_INDEX (xw, x_start, y_from)))); - char * from_end = - (XTERM_CHAR_LOC (xw, (XTERM_CHAR_INDEX (xw, x_end, y_from)))); - char * to_scan = - (XTERM_CHAR_LOC (xw, (XTERM_CHAR_INDEX (xw, x_start, y_to)))); - while (from_scan < from_end) - (*to_scan++) = (*from_scan++); - } - { - char * from_scan = - (XTERM_HL_LOC (xw, (XTERM_CHAR_INDEX (xw, x_start, y_from)))); - char * from_end = - (XTERM_HL_LOC (xw, (XTERM_CHAR_INDEX (xw, x_end, y_from)))); - char * to_scan = - (XTERM_HL_LOC (xw, (XTERM_CHAR_INDEX (xw, x_start, y_to)))); - while (from_scan < from_end) - (*to_scan++) = (*from_scan++); - } -} - -static void -xterm_dump_contents (struct xwindow * xw, - unsigned int x_start, - unsigned int x_end, - unsigned int y_start, - unsigned int y_end) -{ - char * character_map = (XW_CHARACTER_MAP (xw)); - char * highlight_map = (XW_HIGHLIGHT_MAP (xw)); - if (x_start < x_end) - { - unsigned int yi; - for (yi = y_start; (yi < y_end); yi += 1) - { - unsigned int index = (XTERM_CHAR_INDEX (xw, 0, yi)); - char * line_char = (&character_map[index]); - char * line_hl = (&highlight_map[index]); - unsigned int xi = x_start; - while (1) - { - unsigned int hl = (line_hl[xi]); - unsigned int xj = (xi + 1); - while ((xj < x_end) && ((line_hl[xj]) == hl)) - xj += 1; - XTERM_DRAW_CHARS (xw, xi, yi, - (&line_char[xi]), - (xj - xi), - (XTERM_HL_GC (xw, hl))); - if (xj == x_end) - break; - xi = xj; - } - } - if (CURSOR_IN_RECTANGLE (xw, x_start, x_end, y_start, y_end)) - { - (XW_CURSOR_VISIBLE_P (xw)) = 0; - xterm_draw_cursor (xw); - } - } -} - -static void -xterm_dump_rectangle (struct xwindow * xw, - int signed_x, - int signed_y, - unsigned int width, - unsigned int height) -{ - XFontStruct * font = (XW_FONT (xw)); - unsigned int x = ((signed_x < 0) ? 0 : ((unsigned int) signed_x)); - unsigned int y = ((signed_y < 0) ? 0 : ((unsigned int) signed_y)); - unsigned int fwidth = (FONT_WIDTH (font)); - unsigned int fheight = (FONT_HEIGHT (font)); - unsigned int border = (XW_INTERNAL_BORDER_WIDTH (xw)); - if (x < border) - { - width -= (border - x); - x = 0; - } - else - x -= border; - if ((x + width) > (XW_X_SIZE (xw))) - width = ((XW_X_SIZE (xw)) - x); - if (y < border) - { - height -= (border - y); - y = 0; - } - else - y -= border; - if ((y + height) > (XW_Y_SIZE (xw))) - height = ((XW_Y_SIZE (xw)) - y); - { - unsigned int x_start = (x / fwidth); - unsigned int x_end = (((x + width) + (fwidth - 1)) / fwidth); - unsigned int y_start = (y / fheight); - unsigned int y_end = (((y + height) + (fheight - 1)) / fheight); - if (x_end > (XW_X_CSIZE (xw))) - x_end = (XW_X_CSIZE (xw)); - if (y_end > (XW_Y_CSIZE (xw))) - y_end = (XW_Y_CSIZE (xw)); - xterm_dump_contents (xw, x_start, x_end, y_start, y_end); - } - XFlush (XW_DISPLAY (xw)); -} - -#define MIN(x, y) (((x) < (y)) ? (x) : (y)) - -static void -xterm_reconfigure (struct xwindow * xw, - unsigned int x_csize, - unsigned int y_csize) -{ - if ((x_csize != (XW_X_CSIZE (xw))) || (y_csize != (XW_Y_CSIZE (xw)))) - { - char * new_char_map = (x_malloc (x_csize * y_csize)); - char * new_hl_map = (x_malloc (x_csize * y_csize)); - unsigned int old_x_csize = (XW_X_CSIZE (xw)); - unsigned int min_x_csize = (MIN (x_csize, old_x_csize)); - unsigned int min_y_csize = (MIN (y_csize, (XW_Y_CSIZE (xw)))); - int x_clipped = (old_x_csize - x_csize); - char * new_scan_char = new_char_map; - char * new_scan_hl = new_hl_map; - char * new_end; - char * old_scan_char = (XW_CHARACTER_MAP (xw)); - char * old_scan_hl = (XW_HIGHLIGHT_MAP (xw)); - char * old_end; - unsigned int new_y = 0; - for (; (new_y < min_y_csize); new_y += 1) - { - old_end = (old_scan_char + min_x_csize); - while (old_scan_char < old_end) - { - (*new_scan_char++) = (*old_scan_char++); - (*new_scan_hl++) = (*old_scan_hl++); - } - if (x_clipped < 0) - { - new_end = (new_scan_char + ((unsigned int) (- x_clipped))); - while (new_scan_char < new_end) - { - (*new_scan_char++) = BLANK_CHAR; - (*new_scan_hl++) = DEFAULT_HL; - } - } - else if (x_clipped > 0) - { - old_scan_char += ((unsigned int) x_clipped); - old_scan_hl += ((unsigned int) x_clipped); - } - } - for (; (new_y < y_csize); new_y += 1) - { - new_end = (new_scan_char + x_csize); - while (new_scan_char < new_end) - { - (*new_scan_char++) = BLANK_CHAR; - (*new_scan_hl++) = DEFAULT_HL; - } - } - free (XW_CHARACTER_MAP (xw)); - free (XW_HIGHLIGHT_MAP (xw)); - { - unsigned int x_size = (XTERM_X_PIXEL (xw, x_csize)); - unsigned int y_size = (XTERM_Y_PIXEL (xw, x_csize)); - (XW_X_SIZE (xw)) = x_size; - (XW_Y_SIZE (xw)) = y_size; - (XW_CLIP_X (xw)) = 0; - (XW_CLIP_Y (xw)) = 0; - (XW_CLIP_WIDTH (xw)) = x_size; - (XW_CLIP_HEIGHT (xw)) = y_size; - } - (XW_X_CSIZE (xw)) = x_csize; - (XW_Y_CSIZE (xw)) = y_csize; - (XW_CHARACTER_MAP (xw))= new_char_map; - (XW_HIGHLIGHT_MAP (xw))= new_hl_map; - XClearWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw))); - xterm_dump_contents (xw, 0, 0, x_csize, y_csize); - xterm_update_normal_hints (xw); - XFlush (XW_DISPLAY (xw)); - } -} - -DEFINE_PRIMITIVE ("XTERM-RECONFIGURE", Prim_xterm_reconfigure, 3, 3, 0) -{ - PRIMITIVE_HEADER (3); - xterm_reconfigure ((x_window_arg (1)), - (arg_ulong_integer (2)), - (arg_ulong_integer (3))); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("XTERM-DUMP-RECTANGLE", Prim_xterm_dump_rectangle, 5, 5, 0) -{ - PRIMITIVE_HEADER (5); - xterm_dump_rectangle ((x_window_arg (1)), - (arg_integer (2)), - (arg_integer (3)), - (arg_ulong_integer (4)), - (arg_ulong_integer (5))); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("XTERM-MAP-X-COORDINATE", Prim_xterm_map_x_coordinate, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - int signed_xp = (arg_integer (2)); - unsigned int xp = ((signed_xp < 0) ? 0 : ((unsigned int) signed_xp)); - int bx = (xp - (XW_INTERNAL_BORDER_WIDTH (xw))); - PRIMITIVE_RETURN - (long_to_integer - (((bx < 0) ? 0 - : (bx >= (XW_X_SIZE (xw))) ? ((XW_X_SIZE (xw)) - 1) - : bx) - / (FONT_WIDTH (XW_FONT (xw))))); - } -} - -DEFINE_PRIMITIVE ("XTERM-MAP-Y-COORDINATE", Prim_xterm_map_y_coordinate, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - int signed_yp = (arg_integer (2)); - unsigned int yp = ((signed_yp < 0) ? 0 : ((unsigned int) signed_yp)); - int by = (yp - (XW_INTERNAL_BORDER_WIDTH (xw))); - PRIMITIVE_RETURN - (long_to_integer - (((by < 0) ? 0 - : (by >= (XW_Y_SIZE (xw))) ? ((XW_Y_SIZE (xw)) - 1) - : by) - / (FONT_HEIGHT (XW_FONT (xw))))); - } -} - -DEFINE_PRIMITIVE ("XTERM-MAP-X-SIZE", Prim_xterm_map_x_size, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - int width = - ((arg_nonnegative_integer (2)) - (2 * (XW_INTERNAL_BORDER_WIDTH (xw)))); - PRIMITIVE_RETURN - (ulong_to_integer - ((width < 0) ? 0 : (width / (FONT_WIDTH (XW_FONT (xw)))))); - } -} - -DEFINE_PRIMITIVE ("XTERM-MAP-Y-SIZE", Prim_xterm_map_y_size, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - int height = - ((arg_nonnegative_integer (2)) - (2 * (XW_INTERNAL_BORDER_WIDTH (xw)))); - PRIMITIVE_RETURN - (ulong_to_integer - ((height < 0) ? 0 : (height / (FONT_HEIGHT (XW_FONT (xw)))))); - } -} - -DEFINE_PRIMITIVE ("XTERM-OPEN-WINDOW", Prim_xterm_open_window, 3, 3, 0) -{ - PRIMITIVE_HEADER (3); - { - struct xdisplay * xd = (x_display_arg (1)); - Display * display = (XD_DISPLAY (xd)); - struct drawing_attributes attributes; - struct xwindow_methods methods; - const char * resource_name = RESOURCE_NAME; - const char * resource_class = RESOURCE_CLASS; - int map_p; - XSizeHints * size_hints; - int x_pos; - int y_pos; - int x_size; - int y_size; - unsigned int x_csize; - unsigned int y_csize; - Window window; - struct xwindow * xw; - unsigned int map_size; - - x_decode_window_map_arg - ((ARG_REF (3)), (&resource_name), (&resource_class), (&map_p)); - x_default_attributes - (display, resource_name, resource_class, (&attributes)); - (methods.deallocator) = xterm_deallocate; - (methods.event_processor) = xterm_process_event; - (methods.x_coordinate_map) = xterm_x_coordinate_map; - (methods.y_coordinate_map) = xterm_y_coordinate_map; - (methods.update_normal_hints) = xterm_update_normal_hints; - - size_hints - = (xterm_make_size_hints ((attributes.font), - (2 * (attributes.internal_border_width)))); - XWMGeometry (display, - (DefaultScreen (display)), - (((ARG_REF (2)) == SHARP_F) - ? (x_get_default - (display, resource_name, resource_class, - "geometry", "Geometry", 0)) - : (STRING_ARG (2))), - DEFAULT_GEOMETRY, - (attributes.border_width), - size_hints, - (&x_pos), (&y_pos), (&x_size), (&y_size), - (& (size_hints->win_gravity))); - x_csize - = ((x_size - (size_hints->base_width)) / (size_hints->width_inc)); - y_csize - = ((y_size - (size_hints->base_height)) / (size_hints->height_inc)); - - window = (XCreateSimpleWindow - (display, (RootWindow (display, (DefaultScreen (display)))), - x_pos, y_pos, x_size, y_size, - (attributes.border_width), - (attributes.border_pixel), - (attributes.background_pixel))); - if (window == 0) - error_external_return (); - - xw = (x_make_window - (xd, - window, - (x_size - (size_hints->base_width)), - (y_size - (size_hints->base_height)), - (&attributes), - (&methods), - (sizeof (struct xwindow_term)))); - (XW_X_CSIZE (xw)) = x_csize; - (XW_Y_CSIZE (xw)) = y_csize; - (XW_CURSOR_X (xw)) = 0; - (XW_CURSOR_Y (xw)) = 0; - (XW_CURSOR_VISIBLE_P (xw)) = 0; - (XW_CURSOR_ENABLED_P (xw)) = 1; - - map_size = (x_csize * y_csize); - (XW_CHARACTER_MAP (xw)) = (x_malloc (map_size)); - memset ((XW_CHARACTER_MAP (xw)), BLANK_CHAR, map_size); - (XW_HIGHLIGHT_MAP (xw)) = (x_malloc (map_size)); - memset ((XW_CHARACTER_MAP (xw)), DEFAULT_HL, map_size); - - (size_hints->flags) |= PWinGravity; - xterm_set_wm_normal_hints (xw, size_hints); - xw_set_wm_input_hint (xw, 1); - xw_set_wm_name (xw, "scheme-terminal"); - xw_set_wm_icon_name (xw, "scheme-terminal"); - xw_make_window_map (xw, resource_name, resource_class, map_p); - PRIMITIVE_RETURN (XW_TO_OBJECT (xw)); - } -} - -DEFINE_PRIMITIVE ("XTERM-X-SIZE", Prim_xterm_x_size, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - PRIMITIVE_RETURN (ulong_to_integer (XW_X_CSIZE (x_window_arg (1)))); -} - -DEFINE_PRIMITIVE ("XTERM-Y-SIZE", Prim_xterm_y_size, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - PRIMITIVE_RETURN (ulong_to_integer (XW_Y_CSIZE (x_window_arg (1)))); -} - -DEFINE_PRIMITIVE ("XTERM-SET-SIZE", Prim_xterm_set_size, 3, 3, 0) -{ - struct xwindow * xw; - int extra; - XFontStruct * font; - PRIMITIVE_HEADER (3); - xw = (x_window_arg (1)); - extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw))); -#ifdef __APPLE__ - extra += 1; -#endif - font = (XW_FONT (xw)); - XResizeWindow - ((XW_DISPLAY (xw)), - (XW_WINDOW (xw)), - (((arg_ulong_integer (2)) * (FONT_WIDTH (font))) + extra), - (((arg_ulong_integer (3)) * (FONT_HEIGHT (font))) + extra)); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("XTERM-ENABLE-CURSOR", Prim_xterm_enable_cursor, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - (XW_CURSOR_ENABLED_P (x_window_arg (1))) = (BOOLEAN_ARG (2)); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("XTERM-ERASE-CURSOR", Prim_xterm_erase_cursor, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - xterm_erase_cursor (x_window_arg (1)); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("XTERM-DRAW-CURSOR", Prim_xterm_draw_cursor, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - xterm_draw_cursor (x_window_arg (1)); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("XTERM-WRITE-CURSOR!", Prim_xterm_write_cursor, 3, 3, 0) -{ - PRIMITIVE_HEADER (3); - { - struct xwindow * xw = (x_window_arg (1)); - unsigned int x = (arg_ulong_index_integer (2, (XW_X_CSIZE (xw)))); - unsigned int y = (arg_ulong_index_integer (3, (XW_Y_CSIZE (xw)))); - if ((x != (XW_CURSOR_X (xw))) || (y != (XW_CURSOR_Y (xw)))) - { - xterm_erase_cursor (xw); - (XW_CURSOR_X (xw)) = x; - (XW_CURSOR_Y (xw)) = y; - } - xterm_draw_cursor (xw); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("XTERM-WRITE-CHAR!", Prim_xterm_write_char, 5, 5, 0) -{ - PRIMITIVE_HEADER (5); - { - struct xwindow * xw = (x_window_arg (1)); - unsigned int x = (arg_ulong_index_integer (2, (XW_X_CSIZE (xw)))); - unsigned int y = (arg_ulong_index_integer (3, (XW_Y_CSIZE (xw)))); - int c = (arg_ascii_char (4)); - unsigned int hl = (HL_ARG (5)); - unsigned int index = (XTERM_CHAR_INDEX (xw, x, y)); - char * map_ptr = (XTERM_CHAR_LOC (xw, index)); - (*map_ptr) = c; - (XTERM_HL (xw, index)) = hl; - XTERM_DRAW_CHARS (xw, x, y, map_ptr, 1, (XTERM_HL_GC (xw, hl))); - if (((XW_CURSOR_X (xw)) == x) && ((XW_CURSOR_Y (xw)) == y)) - { - (XW_CURSOR_VISIBLE_P (xw)) = 0; - xterm_draw_cursor (xw); - } - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("XTERM-WRITE-SUBSTRING!", Prim_xterm_write_substring, 7, 7, 0) -{ - PRIMITIVE_HEADER (7); - CHECK_ARG (4, STRING_P); - { - struct xwindow * xw = (x_window_arg (1)); - unsigned int x = (arg_ulong_index_integer (2, (XW_X_CSIZE (xw)))); - unsigned int y = (arg_ulong_index_integer (3, (XW_Y_CSIZE (xw)))); - SCHEME_OBJECT string = (ARG_REF (4)); - unsigned int end - = (arg_ulong_index_integer (6, ((STRING_LENGTH (string)) + 1))); - unsigned int start = (arg_ulong_index_integer (5, (end + 1))); - unsigned int hl = (HL_ARG (7)); - unsigned int length = (end - start); - unsigned int index = (XTERM_CHAR_INDEX (xw, x, y)); - if ((x + length) > (XW_X_CSIZE (xw))) - error_bad_range_arg (2); - { - unsigned char * string_scan = (STRING_LOC (string, start)); - unsigned char * string_end = (STRING_LOC (string, end)); - char * char_scan = (XTERM_CHAR_LOC (xw, index)); - char * hl_scan = (XTERM_HL_LOC (xw, index)); - while (string_scan < string_end) - { - (*char_scan++) = (*string_scan++); - (*hl_scan++) = hl; - } - } - XTERM_DRAW_CHARS - (xw, x, y, (XTERM_CHAR_LOC (xw, index)), length, (XTERM_HL_GC (xw, hl))); - if ((x <= (XW_CURSOR_X (xw))) && ((XW_CURSOR_X (xw)) < (x + length)) - && (y == (XW_CURSOR_Y (xw)))) - { - (XW_CURSOR_VISIBLE_P (xw)) = 0; - xterm_draw_cursor (xw); - } - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -static void -xterm_clear_rectangle (struct xwindow * xw, - unsigned int x_start, - unsigned int x_end, - unsigned int y_start, - unsigned int y_end, - unsigned int hl) -{ - unsigned int x_length = (x_end - x_start); - unsigned int y; - for (y = y_start; (y < y_end); y += 1) - { - unsigned int index = (XTERM_CHAR_INDEX (xw, x_start, y)); - { - char * scan = (XTERM_CHAR_LOC (xw, index)); - char * end = (scan + x_length); - while (scan < end) - (*scan++) = BLANK_CHAR; - } - { - char * scan = (XTERM_HL_LOC (xw, index)); - char * end = (scan + x_length); - while (scan < end) - (*scan++) = hl; - } - } - if (hl != 0) - { - GC hl_gc = (XTERM_HL_GC (xw, hl)); - for (y = y_start; (y < y_end); y += 1) - XTERM_DRAW_CHARS - (xw, x_start, y, - (XTERM_CHAR_LOC (xw, (XTERM_CHAR_INDEX (xw, x_start, y)))), - x_length, hl_gc); - } - else if ((x_start == 0) - && (y_start == 0) - && (x_end == (XW_X_CSIZE (xw))) - && (y_end == (XW_Y_CSIZE (xw)))) - XClearWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw))); - else - XClearArea ((XW_DISPLAY (xw)), - (XW_WINDOW (xw)), - (XTERM_X_PIXEL (xw, x_start)), - (XTERM_Y_PIXEL (xw, y_start)), - (x_length * (FONT_WIDTH (XW_FONT (xw)))), - ((y_end - y_start) * (FONT_HEIGHT (XW_FONT (xw)))), - False); -} - -DEFINE_PRIMITIVE ("XTERM-CLEAR-RECTANGLE!", Prim_xterm_clear_rectangle, 6, 6, 0) -{ - PRIMITIVE_HEADER (6); - { - struct xwindow * xw = (x_window_arg (1)); - unsigned int x_end - = (arg_ulong_index_integer (3, ((XW_X_CSIZE (xw)) + 1))); - unsigned int y_end - = (arg_ulong_index_integer (5, ((XW_Y_CSIZE (xw)) + 1))); - unsigned int x_start = (arg_ulong_index_integer (2, (x_end + 1))); - unsigned int y_start = (arg_ulong_index_integer (4, (y_end + 1))); - unsigned int hl = (HL_ARG (6)); - if ((x_start < x_end) && (y_start < y_end)) - { - xterm_clear_rectangle (xw, x_start, x_end, y_start, y_end, hl); - if (CURSOR_IN_RECTANGLE (xw, x_start, x_end, y_start, y_end)) - { - (XW_CURSOR_VISIBLE_P (xw)) = 0; - xterm_draw_cursor (xw); - } - } - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -static void -xterm_scroll_lines_up (struct xwindow * xw, - unsigned int x_start, - unsigned int x_end, - unsigned int y_start, - unsigned int y_end, - unsigned int lines) -{ - { - unsigned int y_to = y_start; - unsigned int y_from = (y_to + lines); - while (y_from < y_end) - xterm_copy_map_line (xw, x_start, x_end, (y_from++), (y_to++)); - } - XCopyArea ((XW_DISPLAY (xw)), - (XW_WINDOW (xw)), - (XW_WINDOW (xw)), - (XW_NORMAL_GC (xw)), - (XTERM_X_PIXEL (xw, x_start)), - (XTERM_Y_PIXEL (xw, (y_start + lines))), - ((x_end - x_start) * (FONT_WIDTH (XW_FONT (xw)))), - (((y_end - y_start) - lines) * (FONT_HEIGHT (XW_FONT (xw)))), - (XTERM_X_PIXEL (xw, x_start)), - (XTERM_Y_PIXEL (xw, y_start))); -} - -DEFINE_PRIMITIVE ("XTERM-SCROLL-LINES-UP", Prim_xterm_scroll_lines_up, 6, 6, - "(XTERM-SCROLL-LINES-UP XTERM X-START X-END Y-START Y-END LINES)\n\ -Scroll the contents of the region up by LINES.") -{ - PRIMITIVE_HEADER (6); - { - struct xwindow * xw = (x_window_arg (1)); - unsigned int x_end - = (arg_ulong_index_integer (3, ((XW_X_CSIZE (xw)) + 1))); - unsigned int x_start = (arg_ulong_index_integer (2, (x_end + 1))); - unsigned int y_end - = (arg_ulong_index_integer (5, ((XW_Y_CSIZE (xw)) + 1))); - unsigned int y_start = (arg_ulong_index_integer (4, (y_end + 1))); - unsigned int lines = (arg_ulong_index_integer (6, (y_end - y_start))); - if ((0 < lines) && (x_start < x_end) && (y_start < y_end)) - { - if (CURSOR_IN_RECTANGLE (xw, x_start, x_end, (y_start + lines), y_end)) - { - xterm_erase_cursor (xw); - xterm_scroll_lines_up (xw, x_start, x_end, y_start, y_end, lines); - xterm_draw_cursor (xw); - } - else - { - xterm_scroll_lines_up (xw, x_start, x_end, y_start, y_end, lines); - if (CURSOR_IN_RECTANGLE - (xw, x_start, x_end, y_start, (y_end - lines))) - { - (XW_CURSOR_VISIBLE_P (xw)) = 0; - xterm_draw_cursor (xw); - } - } - } - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -static void -xterm_scroll_lines_down (struct xwindow * xw, - unsigned int x_start, - unsigned int x_end, - unsigned int y_start, - unsigned int y_end, - unsigned int lines) -{ - { - unsigned int y_to = y_end; - unsigned int y_from = (y_to - lines); - while (y_from > y_start) - xterm_copy_map_line (xw, x_start, x_end, (--y_from), (--y_to)); - } - XCopyArea ((XW_DISPLAY (xw)), - (XW_WINDOW (xw)), - (XW_WINDOW (xw)), - (XW_NORMAL_GC (xw)), - (XTERM_X_PIXEL (xw, x_start)), - (XTERM_Y_PIXEL (xw, y_start)), - ((x_end - x_start) * (FONT_WIDTH (XW_FONT (xw)))), - (((y_end - y_start) - lines) * (FONT_HEIGHT (XW_FONT (xw)))), - (XTERM_X_PIXEL (xw, x_start)), - (XTERM_Y_PIXEL (xw, (y_start + lines)))); -} - -DEFINE_PRIMITIVE ("XTERM-SCROLL-LINES-DOWN", Prim_xterm_scroll_lines_down, 6, 6, - "(XTERM-SCROLL-LINES-DOWN XTERM X-START X-END Y-START Y-END LINES)\n\ -Scroll the contents of the region down by LINES.") -{ - PRIMITIVE_HEADER (6); - { - struct xwindow * xw = (x_window_arg (1)); - unsigned int x_end - = (arg_ulong_index_integer (3, ((XW_X_CSIZE (xw)) + 1))); - unsigned int x_start = (arg_ulong_index_integer (2, (x_end + 1))); - unsigned int y_end - = (arg_ulong_index_integer (5, ((XW_Y_CSIZE (xw)) + 1))); - unsigned int y_start = (arg_ulong_index_integer (4, (y_end + 1))); - unsigned int lines = (arg_ulong_index_integer (6, (y_end - y_start))); - if ((0 < lines) && (x_start < x_end) && (y_start < y_end)) - { - if (CURSOR_IN_RECTANGLE (xw, x_start, x_end, y_start, (y_end - lines))) - { - xterm_erase_cursor (xw); - xterm_scroll_lines_down - (xw, x_start, x_end, y_start, y_end, lines); - xterm_draw_cursor (xw); - } - else - { - xterm_scroll_lines_down - (xw, x_start, x_end, y_start, y_end, lines); - if (CURSOR_IN_RECTANGLE - (xw, x_start, x_end, (y_start + lines), y_end)) - { - (XW_CURSOR_VISIBLE_P (xw)) = 0; - xterm_draw_cursor (xw); - } - } - } - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("XTERM-SAVE-CONTENTS", Prim_xterm_save_contents, 5, 5, - "(XTERM-SAVE-CONTENTS XW X-START X-END Y-START Y-END)\n\ -Get the contents of the terminal screen rectangle as a string.\n\ -The string contains alternating (CHARACTER, HIGHLIGHT) pairs.\n\ -The pairs are organized in row-major order from (X-START, Y-START).") -{ - PRIMITIVE_HEADER (5); - { - struct xwindow * xw = (x_window_arg (1)); - unsigned int x_end - = (arg_ulong_index_integer (3, ((XW_X_CSIZE (xw)) + 1))); - unsigned int y_end - = (arg_ulong_index_integer (5, ((XW_Y_CSIZE (xw)) + 1))); - unsigned int x_start = (arg_ulong_index_integer (2, (x_end + 1))); - unsigned int y_start = (arg_ulong_index_integer (4, (y_end + 1))); - unsigned int x_length = (x_end - x_start); - unsigned int string_length = (2 * x_length * (y_end - y_start)); - SCHEME_OBJECT string = (allocate_string (string_length)); - if (string_length > 0) - { - char * string_scan = (STRING_POINTER (string)); - unsigned int y; - for (y = y_start; (y < y_end); y += 1) - { - unsigned int index = (XTERM_CHAR_INDEX (xw, x_start, y)); - char * char_scan = (XTERM_CHAR_LOC (xw, index)); - char * char_end = (char_scan + x_length); - char * hl_scan = (XTERM_HL_LOC (xw, index)); - while (char_scan < char_end) - { - (*string_scan++) = (*char_scan++); - (*string_scan++) = (*hl_scan++); - } - } - } - PRIMITIVE_RETURN (string); - } -} - -DEFINE_PRIMITIVE ("XTERM-RESTORE-CONTENTS", Prim_xterm_restore_contents, 6, 6, - "(xterm-restore-contents xterm x-start x-end y-start y-end contents)\n\ -Replace the terminal screen rectangle with CONTENTS.\n\ -See `XTERM-SCREEN-CONTENTS' for the format of CONTENTS.") -{ - PRIMITIVE_HEADER (6); - CHECK_ARG (6, STRING_P); - { - struct xwindow * xw = (x_window_arg (1)); - unsigned int x_end - = (arg_ulong_index_integer (3, ((XW_X_CSIZE (xw)) + 1))); - unsigned int y_end - = (arg_ulong_index_integer (5, ((XW_Y_CSIZE (xw)) + 1))); - unsigned int x_start = (arg_ulong_index_integer (2, (x_end + 1))); - unsigned int y_start = (arg_ulong_index_integer (4, (y_end + 1))); - unsigned int x_length = (x_end - x_start); - unsigned int string_length = (2 * x_length * (y_end - y_start)); - SCHEME_OBJECT string = (ARG_REF (6)); - if ((STRING_LENGTH (string)) != string_length) - error_bad_range_arg (6); - if (string_length > 0) - { - char * string_scan = (STRING_POINTER (string)); - unsigned int y; - for (y = y_start; (y < y_end); y += 1) - { - unsigned int index = (XTERM_CHAR_INDEX (xw, x_start, y)); - char * char_scan = (XTERM_CHAR_LOC (xw, index)); - char * char_end = (char_scan + x_length); - char * hl_scan = (XTERM_HL_LOC (xw, index)); - while (char_scan < char_end) - { - (*char_scan++) = (*string_scan++); - (*hl_scan++) = (*string_scan++); - } - } - xterm_dump_contents (xw, x_start, x_end, y_start, y_end); - } - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -#ifdef COMPILE_AS_MODULE - -/* sed -n -e 's/^DEFINE_PRIMITIVE *(\([^)]*\))$/ declare_primitive (\1);/pg' \ - -e 's/^DEFINE_PRIMITIVE *(\([^)]*\)$/ declare_primitive (\1 0);/pg' */ - -void -dload_initialize_x11term (void) -{ - declare_primitive ("XTERM-CLEAR-RECTANGLE!", Prim_xterm_clear_rectangle, 6, 6, 0); - declare_primitive ("XTERM-DRAW-CURSOR", Prim_xterm_draw_cursor, 1, 1, 0); - declare_primitive ("XTERM-DUMP-RECTANGLE", Prim_xterm_dump_rectangle, 5, 5, 0); - declare_primitive ("XTERM-ENABLE-CURSOR", Prim_xterm_enable_cursor, 2, 2, 0); - declare_primitive ("XTERM-ERASE-CURSOR", Prim_xterm_erase_cursor, 1, 1, 0); - declare_primitive ("XTERM-MAP-X-COORDINATE", Prim_xterm_map_x_coordinate, 2, 2, 0); - declare_primitive ("XTERM-MAP-X-SIZE", Prim_xterm_map_x_size, 2, 2, 0); - declare_primitive ("XTERM-MAP-Y-COORDINATE", Prim_xterm_map_y_coordinate, 2, 2, 0); - declare_primitive ("XTERM-MAP-Y-SIZE", Prim_xterm_map_y_size, 2, 2, 0); - declare_primitive ("XTERM-OPEN-WINDOW", Prim_xterm_open_window, 3, 3, 0); - declare_primitive ("XTERM-RECONFIGURE", Prim_xterm_reconfigure, 3, 3, 0); - declare_primitive ("XTERM-RESTORE-CONTENTS", Prim_xterm_restore_contents, 6, 6, 0); - declare_primitive ("XTERM-SAVE-CONTENTS", Prim_xterm_save_contents, 5, 5, 0); - declare_primitive ("XTERM-SCROLL-LINES-DOWN", Prim_xterm_scroll_lines_down, 6, 6, 0); - declare_primitive ("XTERM-SCROLL-LINES-UP", Prim_xterm_scroll_lines_up, 6, 6, 0); - declare_primitive ("XTERM-SET-SIZE", Prim_xterm_set_size, 3, 3, 0); - declare_primitive ("XTERM-WRITE-CHAR!", Prim_xterm_write_char, 5, 5, 0); - declare_primitive ("XTERM-WRITE-CURSOR!", Prim_xterm_write_cursor, 3, 3, 0); - declare_primitive ("XTERM-WRITE-SUBSTRING!", Prim_xterm_write_substring, 7, 7, 0); - declare_primitive ("XTERM-X-SIZE", Prim_xterm_x_size, 1, 1, 0); - declare_primitive ("XTERM-Y-SIZE", Prim_xterm_y_size, 1, 1, 0); -} - -#endif /* defined (COMPILE_AS_MODULE) */ diff --git a/src/pgsql/README b/src/pgsql/README new file mode 100644 index 000000000..ebcad4d1f --- /dev/null +++ b/src/pgsql/README @@ -0,0 +1,4 @@ +The POSTGRES option. + +This is just the code for the old microcode module prpgsql as cut out +of microcode/. diff --git a/src/pgsql/configure.ac b/src/pgsql/configure.ac new file mode 100644 index 000000000..124148b08 --- /dev/null +++ b/src/pgsql/configure.ac @@ -0,0 +1,49 @@ + +AC_ARG_WITH([libpq], + AS_HELP_STRING([--with-libpq], + [Use PostgreSQL libpq library if available [[yes]]])) +: ${with_libpq='yes'} + + +dnl PostgreSQL support +if test "${with_libpq}" != no; then + if test "${with_libpq}" != yes; then + libpq_inc=${with_libpq}/include + libpq_lib=${with_libpq}/lib + else + AC_PATH_PROG([PG_CONFIG], [pg_config]) + if test "x${PG_CONFIG}" != x; then + libpq_inc=`${PG_CONFIG} --includedir 2>/dev/null` + libpq_lib=`${PG_CONFIG} --libdir 2>/dev/null` + else + if test -d /usr/include/postgresql; then + libpq_inc=/usr/include/postgresql + else + libpq_inc=/usr/include + fi + libpq_lib=/usr/lib + fi + fi + if test "x${libpq_inc}" != x; then + if test "${libpq_inc}" != /usr/include; then + CPPFLAGS="${CPPFLAGS} -I${libpq_inc}" + fi + fi + if test "x${libpq_lib}" != x; then + if test "${libpq_lib}" != /usr/lib; then + LDFLAGS="${LDFLAGS} -L${libpq_lib}" + fi + fi + AC_CHECK_HEADER([libpq-fe.h], + [ + AC_DEFINE([HAVE_LIBPQ_FE_H], [1], + [Define to 1 if you have the header file.]) + AC_CHECK_LIB([pq], [PQconnectdb], + [ + AC_DEFINE([HAVE_LIBPQ], [1], + [Define to 1 if you have the `pq' library (-lpq).]) + MODULE_LIBS="-lpq ${MODULE_LIBS}" + MODULE_BASES="${MODULE_BASES} prpgsql" + ]) + ]) +fi diff --git a/src/microcode/prpgsql.c b/src/pgsql/pgsql.c similarity index 100% rename from src/microcode/prpgsql.c rename to src/pgsql/pgsql.c diff --git a/src/pgsql/pgsql.pkg b/src/pgsql/pgsql.pkg new file mode 100644 index 000000000..a5b0123e0 --- /dev/null +++ b/src/pgsql/pgsql.pkg @@ -0,0 +1,65 @@ +(define-package (runtime postgresql) + (file-case options + ((load) "pgsql") + (else)) + (parent (runtime)) + (export () + call-with-pgsql-conn + close-pgsql-conn + condition-type:pgsql-connection-error + condition-type:pgsql-error + condition-type:pgsql-query-error + decode-pgsql-bytea + encode-pgsql-bytea + escape-pgsql-string + exec-pgsql-query + guarantee-pgsql-available + make-empty-pgsql-result + open-pgsql-conn + pgsql-available? + pgsql-bad-response + pgsql-clear + pgsql-cmd-status + pgsql-cmd-tuples + pgsql-command-ok + pgsql-conn-db + pgsql-conn-error-message + pgsql-conn-host + pgsql-conn-open? + pgsql-conn-options + pgsql-conn-pass + pgsql-conn-port + pgsql-conn-reset + pgsql-conn-reset-start + pgsql-conn-status + pgsql-conn-tty + pgsql-conn-user + pgsql-connection-auth-ok + pgsql-connection-awaiting-response + pgsql-connection-bad + pgsql-connection-made + pgsql-connection-ok + pgsql-connection-setenv + pgsql-connection-started + pgsql-copy-in + pgsql-copy-out + pgsql-empty-query + pgsql-fatal-error + pgsql-field-name + pgsql-get-is-null? + pgsql-get-line + pgsql-get-value + pgsql-n-fields + pgsql-n-tuples + pgsql-nonfatal-error + pgsql-polling-active + pgsql-polling-failed + pgsql-polling-ok + pgsql-polling-reading + pgsql-polling-writing + pgsql-put-line + pgsql-result-error-message + pgsql-result-status + pgsql-tuples-ok + poll-pgsql-conn + poll-pgsql-reset)) \ No newline at end of file diff --git a/src/runtime/pgsql.scm b/src/pgsql/pgsql.scm similarity index 100% rename from src/runtime/pgsql.scm rename to src/pgsql/pgsql.scm diff --git a/src/runtime/Makefile-fragment b/src/runtime/Makefile-fragment index e39b9958b..9ee60714b 100644 --- a/src/runtime/Makefile-fragment +++ b/src/runtime/Makefile-fragment @@ -1,6 +1,6 @@ RUNDIR = $(AUXDIR)/runtime -RUNOPTS = chrsyn cpress format gdbm hashtb krypt mime-codec numint \ - ordvec pgsql process rbtree regexp rexp rgxcmp syncproc wttree ystep +RUNOPTS = chrsyn cpress format mime-codec numint \ + ordvec process rbtree regexp rexp rgxcmp syncproc wttree ystep install: rm -rf $(DESTDIR)$(RUNDIR) diff --git a/src/runtime/blowfish.scm b/src/runtime/blowfish.scm index 76e349095..60dc18441 100644 --- a/src/runtime/blowfish.scm +++ b/src/runtime/blowfish.scm @@ -29,76 +29,52 @@ USA. (declare (usual-integrations)) -(define blowfish-set-key (ucode-primitive blowfish-set-key 1)) -(define blowfish-ecb (ucode-primitive blowfish-ecb 4)) -(define blowfish-cbc (ucode-primitive blowfish-cbc-v2 5)) -(define blowfish-cfb64 (ucode-primitive blowfish-cfb64-substring-v2 9)) -(define blowfish-ofb64 (ucode-primitive blowfish-ofb64-substring 8)) +;;; This package now autoloads the blowfish plugin, which updates the +;;; bindings here. -(define (blowfish-available?) - (load-library-object-file "prbfish" #f) - (implemented-primitive-procedure? blowfish-cfb64)) - -(define (blowfish-encrypt-port input output key init-vector encrypt?) - ;; Assumes that INPUT is in blocking mode. - (let ((key (blowfish-set-key key)) - (input-buffer (make-string 4096)) - (output-buffer (make-string 4096))) - (dynamic-wind - (lambda () - unspecific) - (lambda () - (let loop ((m 0)) - (let ((n (input-port/read-string! input input-buffer))) - (if (not (fix:= 0 n)) - (let ((m - (blowfish-cfb64 input-buffer 0 n output-buffer 0 - key init-vector m encrypt?))) - (write-substring output-buffer 0 n output) - (loop m)))))) - (lambda () - (string-fill! input-buffer #\NUL) - (string-fill! output-buffer #\NUL))))) +;;; bindings during blowfish-available?. During a restore, the +;;; bindings are un-assigned. Restored threads in the midst of using +;;; the blowfish library thus quickly signal unassigned and can +;;; restart or abort as appropriate. It is assumed a restart begins +;;; again with a call to blowfish-available?, thus autoloading the +;;; plugin in the restored world. -(define (compute-blowfish-init-vector) - ;; This init vector includes a timestamp with a resolution of - ;; milliseconds, plus 20 random bits. This should make it very - ;; difficult to generate two identical vectors. - (let ((iv (make-string 8))) - (do ((i 0 (fix:+ i 1)) - (t (+ (* (+ (* (get-universal-time) 1000) - (remainder (real-time-clock) 1000)) - #x100000) - (random #x100000)) - (quotient t #x100))) - ((fix:= 8 i)) - (vector-8b-set! iv i (remainder t #x100))) - iv)) +(define loaded? #f) -(define (write-blowfish-file-header port) - (write-string blowfish-file-header-v2 port) - (newline port) - (let ((init-vector (compute-blowfish-init-vector))) - (write-string init-vector port) - init-vector)) +(define (blowfish-available?) + (or loaded? + (and (plugin-available? "blowfish") + (begin + (load-option 'blowfish) + (set! loaded? #t) + #t)))) -(define (read-blowfish-file-header port) - (let ((line (read-line port))) - (cond ((string=? blowfish-file-header-v1 line) - (make-string 8 #\NUL)) - ((string=? blowfish-file-header-v2 line) - (let ((init-vector (make-string 8))) - (if (not (= 8 (read-substring! init-vector 0 8 port))) - (error "Short read while getting init-vector:" port)) - init-vector)) - (else - (error:bad-range-argument port 'READ-BLOWFISH-FILE-HEADER))))) +(define (reset-blowfish!) + (set! loaded? #f) + (let ((env (->environment '(runtime blowfish)))) + (for-each + (lambda (name) + (environment-assign! env name (microcode-object/unassigned))) + '(blowfish-cbc + blowfish-cfb64 + blowfish-ecb + blowfish-encrypt-port + blowfish-file? + blowfish-ofb64 + blowfish-set-key + compute-blowfish-init-vector + read-blowfish-file-header + write-blowfish-file-header)))) -(define (blowfish-file? pathname) - (let ((line (call-with-binary-input-file pathname read-line))) - (and (not (eof-object? line)) - (or (string=? line blowfish-file-header-v1) - (string=? line blowfish-file-header-v2))))) +(define blowfish-cbc) +(define blowfish-cfb64) +(define blowfish-ecb) +(define blowfish-encrypt-port) +(define blowfish-file?) +(define blowfish-ofb64) +(define blowfish-set-key) +(define compute-blowfish-init-vector) +(define read-blowfish-file-header) +(define write-blowfish-file-header) -(define blowfish-file-header-v1 "Blowfish, 16 rounds") -(define blowfish-file-header-v2 "Blowfish, 16 rounds, version 2") \ No newline at end of file +(add-event-receiver! event:after-restart reset-blowfish!) \ No newline at end of file diff --git a/src/runtime/crypto.scm b/src/runtime/crypto.scm index bd60582b4..d31aef885 100644 --- a/src/runtime/crypto.scm +++ b/src/runtime/crypto.scm @@ -29,507 +29,144 @@ USA. (declare (usual-integrations)) -;;;; The mhash library - -(define mhash-initialized?) -(define mhash-algorithm-names) -(define mhash-contexts) -(define mhash-hmac-contexts) - -(define (mhash-name->id name procedure) - (let ((n (vector-length mhash-algorithm-names))) - (let loop ((i 0)) - (cond ((fix:= i n) (error:bad-range-argument name procedure)) - ((eq? name (vector-ref mhash-algorithm-names i)) i) - (else (loop (fix:+ i 1))))))) - -(define-structure mhash-context index) -(define-structure mhash-hmac-context index) - -(define (guarantee-mhash-context object procedure) - (if (not (mhash-context? object)) - (error:wrong-type-argument object "mhash context" procedure)) - (if (not (mhash-context-index object)) - (error:bad-range-argument object procedure))) - -(define (guarantee-mhash-hmac-context object procedure) - (if (not (mhash-hmac-context? object)) - (error:wrong-type-argument object "mhash HMAC context" procedure)) - (if (not (mhash-hmac-context-index object)) - (error:bad-range-argument object procedure))) - -(define (mhash-type-names) - (names-vector->list mhash-algorithm-names)) - -(define (mhash-get-block-size name) - ((ucode-primitive mhash_get_block_size 1) - (mhash-name->id name 'MHASH-GET-BLOCK-SIZE))) - -(define (mhash-init name) - (let ((id (mhash-name->id name 'MHASH-INIT))) - (without-interruption - (lambda () - (let ((index ((ucode-primitive mhash_init 1) id))) - (if (not index) - (error "Unable to allocate mhash context:" name)) - (add-to-gc-finalizer! mhash-contexts (make-mhash-context index))))))) - -(define (mhash-update context string start end) - (guarantee-mhash-context context 'MHASH-UPDATE) - ((ucode-primitive mhash 4) (mhash-context-index context) string start end)) - -(define (mhash-end context) - (remove-from-gc-finalizer! mhash-contexts context)) - -(define (mhash-hmac-init name key) - (let* ((id (mhash-name->id name 'MHASH-INIT)) - (pblock ((ucode-primitive mhash_get_hash_pblock 1) id))) - (without-interruption - (lambda () - (let ((index ((ucode-primitive mhash_hmac_init 3) id key pblock))) - (if (not index) - (error "Unable to allocate mhash HMAC context:" name)) - (add-to-gc-finalizer! mhash-hmac-contexts - (make-mhash-hmac-context index))))))) - -(define (mhash-hmac-update context string start end) - (guarantee-mhash-hmac-context context 'MHASH-HMAC-UPDATE) - ((ucode-primitive mhash 4) (mhash-hmac-context-index context) - string start end)) - -(define (mhash-hmac-end context) - (remove-from-gc-finalizer! mhash-hmac-contexts context)) - -(define mhash-keygen-names) - -(define (keygen-name->id name procedure) - (let ((n (vector-length mhash-keygen-names))) - (let loop ((i 0)) - (cond ((fix:= i n) (error:bad-range-argument name procedure)) - ((eq? name (vector-ref mhash-keygen-names i)) i) - (else (loop (fix:+ i 1))))))) - -(define (mhash-keygen-type-names) - (names-vector->list mhash-keygen-names)) - -(define (mhash-keygen-uses-salt? name) - ((ucode-primitive mhash_keygen_uses_salt 1) - (keygen-name->id name 'MHASH-KEYGEN-USES-SALT?))) - -(define (mhash-keygen-uses-count? name) - ((ucode-primitive mhash_keygen_uses_count 1) - (keygen-name->id name 'MHASH-KEYGEN-USES-COUNT?))) - -(define (mhash-keygen-uses-hash-algorithm name) - ((ucode-primitive mhash_keygen_uses_hash_algorithm 1) - (keygen-name->id name 'MHASH-KEYGEN-USES-HASH-ALGORITHM))) - -(define (mhash-keygen-salt-size name) - ((ucode-primitive mhash_get_keygen_salt_size 1) - (keygen-name->id name 'MHASH-KEYGEN-SALT-SIZE))) - -(define (mhash-keygen-max-key-size name) - ((ucode-primitive mhash_get_keygen_max_key_size 1) - (keygen-name->id name 'MHASH-KEYGEN-MAX-KEY-SIZE))) - -(define (mhash-keygen type passphrase #!optional salt) - (if (not (mhash-keygen-type? type)) - (error:wrong-type-argument type "mhash type" 'MHASH-KEYGEN)) - (let ((id (mhash-keygen-type-id type)) - (keyword (make-string (mhash-keygen-type-key-length type))) - (v (mhash-keygen-type-parameter-vector type))) - (if (not ((ucode-primitive mhash_keygen 4) - id - (if ((ucode-primitive mhash_keygen_uses_salt 1) id) - (begin - (if (or (default-object? salt) (not salt)) - (error "Salt required:" - (vector-ref mhash-keygen-names id))) - (let ((n - ((ucode-primitive mhash_get_keygen_salt_size 1) - id))) - (if (not (or (= n 0) - (= n (string-length salt)))) - (error "Salt size incorrect:" - (string-length salt) - (error-irritant/noise "; should be:") - n))) - (let ((v (vector-copy v))) - (vector-set! v 0 salt) - v)) - v) - keyword - passphrase)) - (error "Error signalled by mhash_keygen.")) - keyword)) - -(define-structure (mhash-keygen-type (constructor %make-mhash-keygen-type)) - (id #f read-only #t) - (key-length #f read-only #t) - (parameter-vector #f read-only #t)) - -(define (make-mhash-keygen-type name key-length hash-names #!optional count) - (if (not (index-fixnum? key-length)) - (error:wrong-type-argument key-length "key length" - 'MAKE-MHASH-KEYGEN-TYPE)) - (if (not (let ((m (mhash-keygen-max-key-size name))) - (or (= m 0) - (<= key-length m)))) - (error:bad-range-argument key-length 'MAKE-MHASH-KEYGEN-TYPE)) - (%make-mhash-keygen-type - (keygen-name->id name 'MAKE-MHASH-KEYGEN-TYPE) - key-length - (let ((n-algorithms (mhash-keygen-uses-hash-algorithm name)) - (hash-names - (if (list? hash-names) hash-names (list hash-names)))) - (let ((m (length hash-names))) - (if (not (= n-algorithms m)) - (error "Wrong number of hash types supplied:" - m - (error-irritant/noise "; should be:") - n-algorithms))) - (let ((n (+ 2 n-algorithms))) - (let ((v (make-vector n))) - (vector-set! v 0 #f) - (vector-set! - v 1 - (and (mhash-keygen-uses-count? name) - (begin - (if (or (default-object? count) (not count)) - (error "Iteration count required:" name)) - (if (not (and (exact-integer? count) - (positive? count))) - (error:bad-range-argument count 'MAKE-MHASH-KEYGEN-TYPE)) - count))) - (do ((i 2 (fix:+ i 1)) - (names hash-names (cdr names))) - ((fix:= i n)) - (vector-set! v i - (mhash-name->id (car names) 'MAKE-MHASH-KEYGEN-TYPE))) - v))))) - -(define (mhash-available?) - (load-library-object-file "prmhash" #f) - (and (implemented-primitive-procedure? (ucode-primitive mhash 4)) - (begin - (if (not mhash-initialized?) - (begin - (set! mhash-algorithm-names - (make-names-vector - (ucode-primitive mhash_count 0) - (ucode-primitive mhash_get_hash_name 1))) - (set! mhash-contexts - (make-gc-finalizer (ucode-primitive mhash_end 1) - mhash-context? - mhash-context-index - set-mhash-context-index!)) - (set! mhash-hmac-contexts - (make-gc-finalizer (ucode-primitive mhash_hmac_end 1) - mhash-hmac-context? - mhash-hmac-context-index - set-mhash-hmac-context-index!)) - (set! mhash-keygen-names - (make-names-vector - (ucode-primitive mhash_keygen_count 0) - (ucode-primitive mhash_get_keygen_name 1))) - (set! mhash-initialized? #t))) - #t))) - -(define (reset-mhash-variables!) - (set! mhash-initialized? #f) - unspecific) - -(define (mhash-file hash-type filename) - (call-with-binary-input-file filename - (lambda (port) - (let ((buffer (make-string 4096)) - (context (mhash-init hash-type))) - (dynamic-wind (lambda () - unspecific) - (lambda () - (let loop () - (let ((n (read-substring! buffer 0 4096 port))) - (if (fix:= 0 n) - (mhash-end context) - (begin - (mhash-update context buffer 0 n) - (loop)))))) - (lambda () - (string-fill! buffer #\NUL))))))) - -(define (mhash-string hash-type string) - (mhash-substring hash-type string 0 (string-length string))) - -(define (mhash-substring hash-type string start end) - (let ((context (mhash-init hash-type))) - (mhash-update context string start end) - (mhash-end context))) - -(define (mhash-sum->number sum) - (let ((l (string-length sum))) - (do ((i 0 (fix:+ i 1)) - (n 0 (+ (* n #x100) (vector-8b-ref sum i)))) - ((fix:= i l) n)))) - -(define (mhash-sum->hexadecimal sum) - (let ((n (string-length sum)) - (digits "0123456789abcdef")) - (let ((s (make-string (fix:* 2 n)))) - (do ((i 0 (fix:+ i 1))) - ((fix:= i n)) - (string-set! s (fix:* 2 i) - (string-ref digits - (fix:lsh (vector-8b-ref sum i) -4))) - (string-set! s (fix:+ (fix:* 2 i) 1) - (string-ref digits - (fix:and (vector-8b-ref sum i) #x0F)))) - s))) - -;;;; MD5 - -(define (md5-available?) - (or (mhash-available?) - (%md5-available?))) - -(define (%md5-available?) - (load-library-object-file "prmd5" #f) - (implemented-primitive-procedure? (ucode-primitive md5-init 0))) - -(define (md5-file filename) - (cond ((mhash-available?) - (mhash-file 'MD5 filename)) - ((%md5-available?) - (%md5-file filename)) - (else - (error "This Scheme system was built without MD5 support.")))) - -(define (%md5-file filename) - (call-with-binary-input-file filename - (lambda (port) - (let ((buffer (make-string 4096)) - (context ((ucode-primitive md5-init 0)))) - (dynamic-wind (lambda () - unspecific) - (lambda () - (let loop () - (let ((n (read-substring! buffer 0 4096 port))) - (if (fix:= 0 n) - ((ucode-primitive md5-final 1) context) - (begin - ((ucode-primitive md5-update 4) - context buffer 0 n) - (loop)))))) - (lambda () - (string-fill! buffer #\NUL))))))) - -(define (md5-string string) - (md5-substring string 0 (string-length string))) - -(define (md5-substring string start end) - (cond ((mhash-available?) - (mhash-substring 'MD5 string start end)) - ((%md5-available?) - (%md5-substring string start end)) - (else - (error "This Scheme system was built without MD5 support.")))) - -(define (%md5-substring string start end) - (let ((context ((ucode-primitive md5-init 0)))) - ((ucode-primitive md5-update 4) context string start end) - ((ucode-primitive md5-final 1) context))) - -(define md5-sum->number mhash-sum->number) -(define md5-sum->hexadecimal mhash-sum->hexadecimal) - -;;;; The mcrypt library - -(define mcrypt-initialized?) -(define mcrypt-algorithm-names-vector) -(define mcrypt-mode-names-vector) -(define mcrypt-contexts) -(define-structure mcrypt-context index) - -(define (guarantee-mcrypt-context object procedure) - (if (not (mcrypt-context? object)) - (error:wrong-type-argument object "mcrypt context" procedure)) - (if (not (mcrypt-context-index object)) - (error:bad-range-argument object procedure))) +;;; This package now autoloads plugins that update its bindings when +;;; they load. During a restore, the bindings are UN-assigned. +;;; Restored threads in the midst of a session thus quickly signal +;;; unassigned and can restart or abort as appropriate. It is assumed +;;; a restart begins again with a call to an -available? procedure (or +;;; load-option) thus autoloading the plugin in the restored world. (define (mcrypt-available?) - (load-library-object-file "prmcrypt" #f) - (and (implemented-primitive-procedure? - (ucode-primitive mcrypt_module_open 2)) - (begin - (if (not mcrypt-initialized?) - (begin - (set! mcrypt-contexts - (make-gc-finalizer (ucode-primitive mcrypt_generic_end 1) - mcrypt-context? - mcrypt-context-index - set-mcrypt-context-index!)) - (set! mcrypt-algorithm-names-vector - ((ucode-primitive mcrypt_list_algorithms 0))) - (set! mcrypt-mode-names-vector - ((ucode-primitive mcrypt_list_modes 0))) - (set! mcrypt-initialized? #t))) - #t))) - -(define (reset-mcrypt-variables!) - (set! mcrypt-initialized? #f) - unspecific) - -(define (mcrypt-algorithm-names) - (names-vector->list mcrypt-algorithm-names-vector)) - -(define (mcrypt-mode-names) - (names-vector->list mcrypt-mode-names-vector)) - -(define (mcrypt-open-module algorithm mode) - (without-interruption - (lambda () - (add-to-gc-finalizer! mcrypt-contexts - (make-mcrypt-context - ((ucode-primitive mcrypt_module_open 2) algorithm - mode)))))) - -(define (mcrypt-init context key init-vector) - (guarantee-mcrypt-context context 'MCRYPT-INIT) - (let ((code - ((ucode-primitive mcrypt_generic_init 3) - (mcrypt-context-index context) key init-vector))) - (if (not (= code 0)) - (error "Error code signalled by mcrypt_generic_init:" code)))) - -(define (mcrypt-encrypt context input input-start input-end - output output-start encrypt?) - (guarantee-mcrypt-context context 'MCRYPT-ENCRYPT) - (substring-move! input input-start input-end output output-start) - (let ((code - ((if encrypt? - (ucode-primitive mcrypt_generic 4) - (ucode-primitive mdecrypt_generic 4)) - (mcrypt-context-index context) - output - output-start - (fix:+ output-start (fix:- input-end input-start))))) - (if (not (= code 0)) - (error (string-append "Error code signalled by " - (if encrypt? - "mcrypt_generic" - "mdecrypt_generic") - ":") - code)))) + (autoloaded? 'mcrypt)) -(define (mcrypt-end context) - (remove-from-gc-finalizer! mcrypt-contexts context)) - -(define (mcrypt-generic-unary name context-op module-op) - (lambda (object) - (cond ((mcrypt-context? object) (context-op (mcrypt-context-index object))) - ((string? object) (module-op object)) - (else (error:wrong-type-argument object "mcrypt context" name))))) - -(define mcrypt-self-test - (mcrypt-generic-unary - 'MCRYPT-SELF-TEST - (ucode-primitive mcrypt_enc_self_test 1) - (ucode-primitive mcrypt_module_self_test 1))) - -(define mcrypt-block-algorithm-mode? - (mcrypt-generic-unary - 'MCRYPT-BLOCK-ALGORITHM-MODE? - (ucode-primitive mcrypt_enc_is_block_algorithm_mode 1) - (ucode-primitive mcrypt_module_is_block_algorithm_mode 1))) - -(define mcrypt-block-algorithm? - (mcrypt-generic-unary - 'MCRYPT-BLOCK-ALGORITHM? - (ucode-primitive mcrypt_enc_is_block_algorithm 1) - (ucode-primitive mcrypt_module_is_block_algorithm 1))) - -(define mcrypt-block-mode? - (mcrypt-generic-unary - 'MCRYPT-BLOCK-MODE? - (ucode-primitive mcrypt_enc_is_block_mode 1) - (ucode-primitive mcrypt_module_is_block_mode 1))) - -(define mcrypt-key-size - (mcrypt-generic-unary - 'MCRYPT-KEY-SIZE - (ucode-primitive mcrypt_enc_get_key_size 1) - (ucode-primitive mcrypt_module_get_algo_key_size 1))) - -(define mcrypt-supported-key-sizes - (mcrypt-generic-unary - 'MCRYPT-SUPPORTED-KEY-SIZES - (ucode-primitive mcrypt_enc_get_supported_key_sizes 1) - (ucode-primitive mcrypt_module_get_algo_supported_key_sizes 1))) - -(define (mcrypt-init-vector-size context) - (guarantee-mcrypt-context context 'MCRYPT-INIT-VECTOR-SIZE) - ((ucode-primitive mcrypt_enc_get_iv_size 1) - (mcrypt-context-index context))) - -(define (mcrypt-algorithm-name context) - (guarantee-mcrypt-context context 'MCRYPT-ALGORITHM-NAME) - ((ucode-primitive mcrypt_enc_get_algorithms_name 1) - (mcrypt-context-index context))) - -(define (mcrypt-mode-name context) - (guarantee-mcrypt-context context 'MCRYPT-MODE-NAME) - ((ucode-primitive mcrypt_enc_get_modes_name 1) - (mcrypt-context-index context))) - -(define (mcrypt-encrypt-port algorithm mode input output key init-vector - encrypt?) - ;; Assumes that INPUT is in blocking mode. - (let ((context (mcrypt-open-module algorithm mode)) - (input-buffer (make-string 4096)) - (output-buffer (make-string 4096))) - (mcrypt-init context key init-vector) - (dynamic-wind - (lambda () - unspecific) - (lambda () - (let loop () - (let ((n (input-port/read-string! input input-buffer))) - (if (not (fix:= 0 n)) - (begin - (mcrypt-encrypt context input-buffer 0 n output-buffer 0 - encrypt?) - (write-substring output-buffer 0 n output) - (loop))))) - (mcrypt-end context)) - (lambda () - (string-fill! input-buffer #\NUL) - (string-fill! output-buffer #\NUL))))) - -;;;; Package initialization - -(define (initialize-package!) - (reset-mhash-variables!) - (add-event-receiver! event:after-restart reset-mhash-variables!) - (reset-mcrypt-variables!) - (add-event-receiver! event:after-restart reset-mcrypt-variables!)) - -(define (make-names-vector get-count get-name) - (let ((n (get-count))) - (let ((v (make-vector n))) - (do ((i 0 (fix:+ i 1))) - ((fix:= i n)) - (vector-set! v i - (let ((name (get-name i))) - (and name - (intern name))))) - v))) +(define (md5-available?) + (autoloaded? 'md5)) -(define (names-vector->list v) - (let ((end (vector-length v))) - (let loop ((index 0) (names '())) - (if (fix:< index end) - (loop (fix:+ index 1) - (let ((name (vector-ref v index))) - (if name - (cons name names) - names))) - names)))) \ No newline at end of file +(define (mhash-available?) + (autoloaded? 'mhash)) + +(define (autoloaded? pkg) + (or (memq pkg autoloaded-options) + (and (plugin-available? (symbol-name pkg)) + (begin + (load-option pkg) + (with-thread-mutex-lock autoload-mutex + (lambda () + (if (not (memq pkg autoloaded-options)) + (set! autoloaded-options (cons pkg autoloaded-options))))) + #t)))) + +(define autoloaded-options '()) + +(define autoload-mutex (make-thread-mutex)) + +(define (reset-crypto!) + ;; Need to break any lock on autoload-mutex, to trip up any restored + ;; thread that thinks it still has a lock. + (set! autoloaded-options '()) + (let ((env (->environment '(runtime crypto)))) + (for-each + (lambda (name) + (environment-assign! env name (microcode-object/unassigned))) + '( + ;; mcrypt + mcrypt-algorithm-name + mcrypt-algorithm-names + mcrypt-block-algorithm-mode? + mcrypt-block-algorithm? + mcrypt-block-mode? + mcrypt-context? + mcrypt-encrypt + mcrypt-encrypt-port + mcrypt-end + mcrypt-init + mcrypt-init-vector-size + mcrypt-key-size + mcrypt-mode-name + mcrypt-mode-names + mcrypt-open-module + mcrypt-self-test + mcrypt-supported-key-sizes + + ;; md5 + md5-file + md5-string + md5-substring + md5-sum->hexadecimal + md5-sum->number + + ;; mhash + make-mhash-keygen-type + mhash-context? + mhash-end + mhash-file + mhash-get-block-size + mhash-hmac-end + mhash-hmac-init + mhash-hmac-update + mhash-init + mhash-keygen + mhash-keygen-max-key-size + mhash-keygen-salt-size + mhash-keygen-type-names + mhash-keygen-type? + mhash-keygen-uses-count? + mhash-keygen-uses-hash-algorithm + mhash-keygen-uses-salt? + mhash-string + mhash-substring + mhash-sum->hexadecimal + mhash-sum->number + mhash-type-names + mhash-update + )))) + +(define mcrypt-algorithm-name) +(define mcrypt-algorithm-names) +(define mcrypt-block-algorithm-mode?) +(define mcrypt-block-algorithm?) +(define mcrypt-block-mode?) +(define mcrypt-context?) +(define mcrypt-encrypt) +(define mcrypt-encrypt-port) +(define mcrypt-end) +(define mcrypt-init) +(define mcrypt-init-vector-size) +(define mcrypt-key-size) +(define mcrypt-mode-name) +(define mcrypt-mode-names) +(define mcrypt-open-module) +(define mcrypt-self-test) +(define mcrypt-supported-key-sizes) + +(define md5-file) +(define md5-string) +(define md5-substring) +(define md5-sum->hexadecimal) +(define md5-sum->number) + +(define make-mhash-keygen-type) +(define mhash-context?) +(define mhash-end) +(define mhash-file) +(define mhash-get-block-size) +(define mhash-hmac-end) +(define mhash-hmac-init) +(define mhash-hmac-update) +(define mhash-init) +(define mhash-keygen) +(define mhash-keygen-max-key-size) +(define mhash-keygen-salt-size) +(define mhash-keygen-type-names) +(define mhash-keygen-type?) +(define mhash-keygen-uses-count?) +(define mhash-keygen-uses-hash-algorithm) +(define mhash-keygen-uses-salt?) +(define mhash-string) +(define mhash-substring) +(define mhash-sum->hexadecimal) +(define mhash-sum->number) +(define mhash-type-names) +(define mhash-update) + +(add-event-receiver! event:after-restart reset-crypto!) \ No newline at end of file diff --git a/src/runtime/ed-ffi.scm b/src/runtime/ed-ffi.scm index cdf5309d3..7baaea2d6 100644 --- a/src/runtime/ed-ffi.scm +++ b/src/runtime/ed-ffi.scm @@ -68,7 +68,6 @@ USA. ("gcnote" (runtime gc-notification)) ("gcstat" (runtime gc-statistics)) ("gdatab" (runtime global-database)) - ("gdbm" (runtime gdbm)) ("gencache" (runtime generic-procedure)) ("geneqht" (runtime generic-procedure)) ("generic" (runtime generic-procedure)) @@ -114,7 +113,6 @@ USA. ("parser-buffer" (runtime parser-buffer)) ("partab" (runtime parser-table)) ("pathnm" (runtime pathname)) - ("pgsql" (runtime postgresql)) ("poplat" (runtime population)) ("port" (runtime port)) ("pp" (runtime pretty-printer)) @@ -187,6 +185,5 @@ USA. ("wind" (runtime state-space)) ("wrkdir" (runtime working-directory)) ("wttree" (runtime wt-tree)) - ("x11graph" (runtime X-graphics)) ("xeval" (runtime extended-scode-eval)) ("ystep" (runtime stepper)))) \ No newline at end of file diff --git a/src/runtime/gdbm.scm b/src/runtime/gdbm.scm deleted file mode 100644 index f9c4723b9..000000000 --- a/src/runtime/gdbm.scm +++ /dev/null @@ -1,134 +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 - 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. - -|# - -;;;; gdbm Database Library Interface -;;; package: (runtime gdbm) - -(declare (usual-integrations)) - -(define gdbm-initialized? #f) -(define gdbf-finalizer) - -(define (gdbm-available?) - (load-library-object-file "prgdbm" #f) - (and (implemented-primitive-procedure? (ucode-primitive gdbm-open 4)) - (begin - (if (not gdbm-initialized?) - (begin - (set! gdbf-finalizer - (make-gc-finalizer (ucode-primitive gdbm-close 1) - gdbf? - gdbf-descriptor - set-gdbf-descriptor!)) - (set! gdbm-initialized? #t))) - #t))) - -;; Parameters to gdbm_open for READERS, WRITERS, and WRITERS who can -;; create the database. -(define GDBM_READER 0) ;A reader. -(define GDBM_WRITER 1) ;A writer. -(define GDBM_WRCREAT 2) ;A writer. Create the db if needed. -(define GDBM_NEWDB 3) ;A writer. Always create a new db. -(define GDBM_FAST 16) ;Write fast! => No fsyncs. - -(define (gdbm-open filename block-size flags mode) - (if (not (gdbm-available?)) - (error "This Scheme system was built without gdbm support.")) - (let ((filename (->namestring (merge-pathnames filename)))) - (without-interruption - (lambda () - (add-to-gc-finalizer! - gdbf-finalizer - (make-gdbf (gdbm-error ((ucode-primitive gdbm-open 4) - filename block-size flags mode)) - filename)))))) - -(define (gdbm-close gdbf) - (if (not (gdbf? gdbf)) - (error:wrong-type-argument gdbf "gdbm handle" 'GDBM-CLOSE)) - (remove-from-gc-finalizer! gdbf-finalizer gdbf)) - -;; Parameters to gdbm_store for simple insertion or replacement in the -;; case that the key is already in the database. -(define GDBM_INSERT 0) ;Never replace old data with new. -(define GDBM_REPLACE 1) ;Always replace old data with new. - -(define (gdbm-store gdbf key datum flags) - (gdbm-error - ((ucode-primitive gdbm-store 4) (guarantee-gdbf gdbf 'GDBM-STORE) - key datum flags))) - -(define (gdbm-fetch gdbf key) - ((ucode-primitive gdbm-fetch 2) (guarantee-gdbf gdbf 'GDBM-FETCH) key)) - -(define (gdbm-exists? gdbf key) - ((ucode-primitive gdbm-exists 2) (guarantee-gdbf gdbf 'GDBM-EXISTS?) key)) - -(define (gdbm-delete gdbf key) - (gdbm-error - ((ucode-primitive gdbm-delete 2) (guarantee-gdbf gdbf 'GDBM-DELETE) key))) - -(define (gdbm-firstkey gdbf) - ((ucode-primitive gdbm-firstkey 1) (guarantee-gdbf gdbf 'GDBM-FIRSTKEY))) - -(define (gdbm-nextkey gdbf key) - ((ucode-primitive gdbm-nextkey 2) (guarantee-gdbf gdbf 'GDBM-NEXTKEY) key)) - -(define (gdbm-reorganize gdbf) - (gdbm-error - ((ucode-primitive gdbm-reorganize 1) - (guarantee-gdbf gdbf 'GDBM-REORGANIZE)))) - -(define (gdbm-sync gdbf) - ((ucode-primitive gdbm-sync 1) (guarantee-gdbf gdbf 'GDBM-SYNC))) - -(define (gdbm-version) - ((ucode-primitive gdbm-version 0))) - -;; Parameters to gdbm_setopt, specifing the type of operation to perform. -(define GDBM_CACHESIZE 1) ;Set the cache size. -(define GDBM_FASTMODE 2) ;Toggle fast mode. - -(define (gdbm-setopt gdbf opt val) - (gdbm-error - ((ucode-primitive gdbm-setopt 3) (guarantee-gdbf gdbf 'GDBM-SETOPT) - opt val))) - -(define-structure (gdbf - (print-procedure (simple-unparser-method 'GDBF - (lambda (gdbf) - (list (gdbf-filename gdbf)))))) - descriptor - (filename #f read-only #t)) - -(define (guarantee-gdbf gdbf procedure) - (if (gdbf? gdbf) - (or (gdbf-descriptor gdbf) (error:bad-range-argument gdbf procedure)) - (error:wrong-type-argument gdbf "gdbm handle" procedure))) - -(define (gdbm-error object) - (if (string? object) (error "gdbm error:" object)) - object) \ No newline at end of file diff --git a/src/runtime/krypt.scm b/src/runtime/krypt.scm index 7c6235be9..dbe94bc89 100644 --- a/src/runtime/krypt.scm +++ b/src/runtime/krypt.scm @@ -144,7 +144,8 @@ USA. (define (initialize-key) (if (eq? 'UNKNOWN unlocked?) (set! unlocked? - (and (md5-available?) + (and (ignore-errors (lambda () (load-option 'md5)) + (lambda (condition) condition #f)) (let ((pathname (call-with-current-continuation (lambda (k) @@ -155,10 +156,12 @@ USA. (k #f)) (lambda () (system-library-pathname "krypt.key"))))))) + (define-integrable (alias name) + (environment-lookup #f name)) (and pathname (string=? key-sum - (mhash-sum->hexadecimal - (md5-file pathname))))))))) + ((alias 'mhash-sum->hexadecimal) + ((alias 'md5-file) pathname))))))))) (set! encrypt (lambda (input-string password) diff --git a/src/runtime/make.scm b/src/runtime/make.scm index 724f6e19c..e0e84db46 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -530,7 +530,6 @@ USA. (RUNTIME DEBUGGER) ;; Misc (e.g., version) (RUNTIME) - (RUNTIME CRYPTO) ;; Graphics. The last type initialized is the default for ;; MAKE-GRAPHICS-DEVICE, only the types that are valid for the ;; operating system are actually loaded and initialized. diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 54feee00b..31d31c881 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3360,8 +3360,6 @@ USA. channel-descriptor) (export (runtime microcode-errors) port-error-test) - (export (runtime x-graphics) - have-select?) (export (runtime thread) add-to-select-registry! have-select? @@ -3423,7 +3421,7 @@ USA. register-c-callback set-alien/ctype! update-html-index - update-optiondb) + update-optiondb) (initialization (initialize-package!))) (define-package (runtime program-copier) @@ -3998,134 +3996,7 @@ USA. image/width image? make-graphics-device - make-graphics-device-type) - (export (runtime x-graphics) - make-image-type)) - -(define-package (runtime x-graphics) - (file-case os-type - ((unix) "x11graph") - (else)) - (parent (runtime)) - (export () - create-x-colormap - create-x-image - x-character-bounds/ascent - x-character-bounds/descent - x-character-bounds/lbearing - x-character-bounds/rbearing - x-character-bounds/width - x-close-all-displays - x-colormap/allocate-color - x-colormap/free - x-colormap/query-color - x-colormap/store-color - x-colormap/store-colors - x-colormap? - x-display/name - x-display/properties - x-font-structure/all-chars-exist? - x-font-structure/character-bounds - x-font-structure/default-char - x-font-structure/direction - x-font-structure/max-ascent - x-font-structure/max-bounds - x-font-structure/max-descent - x-font-structure/min-bounds - x-font-structure/name - x-font-structure/start-index - x-geometry-string - x-graphics-default-display-name - x-graphics-default-geometry - x-graphics-device-type - x-graphics/available? - x-graphics/clear - x-graphics/close-display - x-graphics/close-window - x-graphics/color? - x-graphics/coordinate-limits - x-graphics/copy-area - x-graphics/device-coordinate-limits - x-graphics/disable-keyboard-focus - x-graphics/discard-events - x-graphics/display - x-graphics/drag-cursor - x-graphics/draw-arc - x-graphics/draw-circle - x-graphics/draw-line - x-graphics/draw-lines - x-graphics/draw-point - x-graphics/draw-points - x-graphics/draw-text - x-graphics/enable-keyboard-focus - x-graphics/fill-circle - x-graphics/flush - x-graphics/font-structure - x-graphics/get-colormap - x-graphics/get-default - x-graphics/iconify-window - x-graphics/image-depth - x-graphics/lower-window - x-graphics/map-window - x-graphics/move-cursor - x-graphics/move-window - x-graphics/open-display - x-graphics/open-display? - x-graphics/open-window? - x-graphics/query-pointer - x-graphics/raise-window - x-graphics/read-button - x-graphics/read-user-event - x-graphics/reset-clip-rectangle - x-graphics/resize-window - x-graphics/select-user-events - x-graphics/set-background-color - x-graphics/set-border-color - x-graphics/set-border-width - x-graphics/set-clip-rectangle - x-graphics/set-colormap - x-graphics/set-coordinate-limits - x-graphics/set-drawing-mode - x-graphics/set-font - x-graphics/set-foreground-color - x-graphics/set-icon-name - x-graphics/set-input-hint - x-graphics/set-internal-border-width - x-graphics/set-line-style - x-graphics/set-mouse-color - x-graphics/set-mouse-shape - x-graphics/set-window-name - x-graphics/starbase-filename - x-graphics/visual-info - x-graphics/window-id - x-graphics/withdraw-window - x-graphics:auto-raise? - x-image/destroy - x-image/draw - x-image/draw-subimage - x-image/fill-from-byte-vector - x-image/get-pixel - x-image/height - x-image/set-pixel - x-image/width - x-image? - x-visual-class:direct-color - x-visual-class:gray-scale - x-visual-class:pseudo-color - x-visual-class:static-color - x-visual-class:static-gray - x-visual-class:true-color - x-visual-info/bits-per-rgb - x-visual-info/blue-mask - x-visual-info/class - x-visual-info/colormap-size - x-visual-info/depth - x-visual-info/green-mask - x-visual-info/red-mask - x-visual-info/screen - x-visual-info/visual - x-visual-info/visual-id) - (initialization (initialize-package!))) + make-graphics-device-type)) (define-package (runtime starbase-graphics) (file-case os-type @@ -4873,35 +4744,6 @@ USA. ordered-vector-minimum-match search-ordered-subvector search-ordered-vector)) - -(define-package (runtime gdbm) - (file-case options - ((load) "gdbm") - (else)) - (parent (runtime)) - (export () - gdbm-available? - gdbm-close - gdbm-delete - gdbm-exists? - gdbm-fetch - gdbm-firstkey - gdbm-nextkey - gdbm-open - gdbm-reorganize - gdbm-setopt - gdbm-store - gdbm-sync - gdbm-version - gdbm_cachesize - gdbm_fast - gdbm_fastmode - gdbm_insert - gdbm_newdb - gdbm_reader - gdbm_replace - gdbm_wrcreat - gdbm_writer)) (define-package (runtime generic-procedure) (files "gentag" "gencache" "generic") @@ -5671,73 +5513,6 @@ USA. vector-parser) (initialization (initialize-package!))) -(define-package (runtime postgresql) - (file-case options - ((load) "pgsql") - (else)) - (parent (runtime)) - (export () - call-with-pgsql-conn - close-pgsql-conn - condition-type:pgsql-connection-error - condition-type:pgsql-error - condition-type:pgsql-query-error - decode-pgsql-bytea - encode-pgsql-bytea - escape-pgsql-string - exec-pgsql-query - guarantee-pgsql-available - make-empty-pgsql-result - open-pgsql-conn - pgsql-available? - pgsql-bad-response - pgsql-clear - pgsql-cmd-status - pgsql-cmd-tuples - pgsql-command-ok - pgsql-conn-db - pgsql-conn-error-message - pgsql-conn-host - pgsql-conn-open? - pgsql-conn-options - pgsql-conn-pass - pgsql-conn-port - pgsql-conn-reset - pgsql-conn-reset-start - pgsql-conn-status - pgsql-conn-tty - pgsql-conn-user - pgsql-connection-auth-ok - pgsql-connection-awaiting-response - pgsql-connection-bad - pgsql-connection-made - pgsql-connection-ok - pgsql-connection-setenv - pgsql-connection-started - pgsql-copy-in - pgsql-copy-out - pgsql-empty-query - pgsql-fatal-error - pgsql-field-name - pgsql-get-is-null? - pgsql-get-line - pgsql-get-value - pgsql-n-fields - pgsql-n-tuples - pgsql-nonfatal-error - pgsql-polling-active - pgsql-polling-failed - pgsql-polling-ok - pgsql-polling-reading - pgsql-polling-writing - pgsql-put-line - pgsql-result-error-message - pgsql-result-status - pgsql-tuples-ok - poll-pgsql-conn - poll-pgsql-reset)) - - (os-type-case ((nt) (define-package (runtime win32-registry) diff --git a/src/runtime/x11graph.scm b/src/runtime/x11graph.scm deleted file mode 100644 index cdf9985bf..000000000 --- a/src/runtime/x11graph.scm +++ /dev/null @@ -1,1030 +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 - 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 Graphics Interface -;;; package: (runtime x-graphics) - -(declare (usual-integrations)) -(declare (integrate-external "graphics")) - -(define-primitives - (x-close-all-displays 0) - (x-display-descriptor 1) - (x-display-get-default 3) - (x-display-process-events 2) - (x-font-structure 2) - (x-window-beep 1) - (x-window-clear 1) - (x-window-colormap 1) - (x-window-depth 1) - (x-window-event-mask 1) - (x-window-flush 1) - (x-window-iconify 1) - (x-window-id 1) - (x-window-lower 1) - (x-window-map 1) - (x-window-query-pointer 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-event-mask 2) - (x-window-set-font 2) - (x-window-set-foreground-color 2) - (x-window-set-icon-name 2) - (x-window-set-input-hint 2) - (x-window-set-internal-border-width 2) - (x-window-set-mouse-color 2) - (x-window-set-mouse-shape 2) - (x-window-set-name 2) - (x-window-set-position 3) - (x-window-set-size 3) - (x-window-starbase-filename 1) - (x-window-visual 1) - (x-window-withdraw 1) - (x-window-x-size 1) - (x-window-y-size 1) - (x-graphics-copy-area 8) - (x-graphics-drag-cursor 3) - (x-graphics-draw-arc 8) - (x-graphics-draw-line 5) - (x-graphics-draw-lines 3) - (x-graphics-draw-point 3) - (x-graphics-draw-points 3) - (x-graphics-draw-string 4) - (x-graphics-draw-image-string 4) - (x-graphics-fill-polygon 2) - (x-graphics-map-x-coordinate 2) - (x-graphics-map-y-coordinate 2) - (x-graphics-move-cursor 3) - (x-graphics-open-window 3) - (x-graphics-reconfigure 3) - (x-graphics-reset-clip-rectangle 1) - (x-graphics-set-clip-rectangle 5) - (x-graphics-set-dashes 3) - (x-graphics-set-fill-style 2) - (x-graphics-set-function 2) - (x-graphics-set-line-style 2) - (x-graphics-set-vdc-extent 5) - (x-graphics-vdc-extent 1) - (x-bytes-into-image 2) - (x-create-image 3) - (x-destroy-image 1) - (x-display-image 8) - (x-get-pixel-from-image 3) - (x-set-pixel-in-image 4) - (x-allocate-color 4) - (x-create-colormap 3) - (x-free-colormap 1) - (x-query-color 2) - (x-set-window-colormap 2) - (x-store-color 5) - (x-store-colors 2) - (x-visual-deallocate 1)) - -;; These constants must match "microcode/x11base.c" -(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 number-of-event-types 15) - -;; This mask contains button-down, button-up,configure, enter, -;; focus-in, focus-out, key-press, leave, motion, delete-window, map, -;; unmap, and visibility. -(define-integrable event-mask:normal #x5dff) - -;; This mask additionally contains take-focus. -(define-integrable event-mask:ignore-focus #x7dff) - -;; This mask contains button-down. -(define-integrable user-event-mask:default #x0001) - -;;;; X graphics device - -(define (initialize-package!) - (set! x-graphics-device-type - (make-graphics-device-type - 'X - `((available? ,x-graphics/available?) - (clear ,x-graphics/clear) - (close ,x-graphics/close-window) - (color? ,x-graphics/color?) - (coordinate-limits ,x-graphics/coordinate-limits) - (copy-area ,x-graphics/copy-area) - (create-colormap ,create-x-colormap) - (create-image ,x-graphics/create-image) - (device-coordinate-limits ,x-graphics/device-coordinate-limits) - (drag-cursor ,x-graphics/drag-cursor) - (draw-arc ,x-graphics/draw-arc) - (draw-circle ,x-graphics/draw-circle) - (draw-image ,image/draw) - (draw-line ,x-graphics/draw-line) - (draw-lines ,x-graphics/draw-lines) - (draw-point ,x-graphics/draw-point) - (draw-points ,x-graphics/draw-points) - (draw-subimage ,image/draw-subimage) - (draw-text ,x-graphics/draw-text) - (draw-text-opaque ,x-graphics/draw-text-opaque) - (fill-circle ,x-graphics/fill-circle) - (fill-polygon ,x-graphics/fill-polygon) - (flush ,x-graphics/flush) - (font-structure ,x-graphics/font-structure) - (get-colormap ,x-graphics/get-colormap) - (get-default ,x-graphics/get-default) - (iconify-window ,x-graphics/iconify-window) - (image-depth ,x-graphics/image-depth) - (lower-window ,x-graphics/lower-window) - (map-window ,x-graphics/map-window) - (move-cursor ,x-graphics/move-cursor) - (move-window ,x-graphics/move-window) - (open ,x-graphics/open) - (open? ,x-graphics/open-window?) - (query-pointer ,x-graphics/query-pointer) - (raise-window ,x-graphics/raise-window) - (reset-clip-rectangle ,x-graphics/reset-clip-rectangle) - (resize-window ,x-graphics/resize-window) - (set-background-color ,x-graphics/set-background-color) - (set-border-color ,x-graphics/set-border-color) - (set-border-width ,x-graphics/set-border-width) - (set-clip-rectangle ,x-graphics/set-clip-rectangle) - (set-colormap ,x-graphics/set-colormap) - (set-coordinate-limits ,x-graphics/set-coordinate-limits) - (set-drawing-mode ,x-graphics/set-drawing-mode) - (set-font ,x-graphics/set-font) - (set-foreground-color ,x-graphics/set-foreground-color) - (set-icon-name ,x-graphics/set-icon-name) - (set-input-hint ,x-graphics/set-input-hint) - (set-internal-border-width ,x-graphics/set-internal-border-width) - (set-line-style ,x-graphics/set-line-style) - (set-mouse-color ,x-graphics/set-mouse-color) - (set-mouse-shape ,x-graphics/set-mouse-shape) - (set-window-name ,x-graphics/set-window-name) - (starbase-filename ,x-graphics/starbase-filename) - (visual-info ,x-graphics/visual-info) - (withdraw-window ,x-graphics/withdraw-window)))) - (set! display-finalizer - (make-gc-finalizer (ucode-primitive x-close-display 1) - x-display? - x-display/xd - set-x-display/xd!)) - (initialize-image-datatype) - (initialize-colormap-datatype)) - -(define (x-graphics/available?) - (load-library-object-file "prx11" #f) - (implemented-primitive-procedure? - (ucode-primitive x-graphics-open-window 3))) - -(define x-graphics-device-type) - -;;;; Open/Close Displays - -(define display-finalizer) - -(define-structure (x-display - (conc-name x-display/) - (constructor make-x-display (name xd)) - (print-procedure - (simple-unparser-method 'X-DISPLAY - (lambda (display) - (list (x-display/name display)))))) - (name #f read-only #t) - xd - (window-finalizer (make-gc-finalizer (ucode-primitive x-close-window 1) - x-window? - x-window/xw - set-x-window/xw!) - read-only #t) - (previewer-registration #f) - (event-queue (make-queue)) - (properties (make-1d-table) read-only #t)) - -(define (x-graphics/open-display name) - (let ((name - (cond ((not name) - (or x-graphics-default-display-name - (let ((name (get-environment-variable "DISPLAY"))) - (if (not name) - (error "No DISPLAY environment variable.")) - name))) - ((string? name) - name) - (else - (error:wrong-type-argument name - "string or #f" - x-graphics/open-display))))) - (or (search-gc-finalizer display-finalizer - (lambda (display) - (string=? (x-display/name display) name))) - (let ((xd ((ucode-primitive x-open-display 1) name))) - (if (not xd) - (error "Unable to open display:" name)) - (let ((display (make-x-display name xd))) - (add-to-gc-finalizer! display-finalizer display) - (register-event-previewer! display) - display))))) - -(define (x-graphics/close-display display) - (without-interruption - (lambda () - (if (x-display/xd display) - (begin - (remove-all-from-gc-finalizer! (x-display/window-finalizer display)) - (let ((registration (x-display/previewer-registration display))) - (if registration - (begin - (deregister-io-thread-event registration) - (set-x-display/previewer-registration! display #f)))) - (remove-from-gc-finalizer! display-finalizer display)))))) - -(define (x-graphics/open-display? display) - (if (x-display/xd display) #t #f)) - -(define (register-event-previewer! display) - (let ((registration)) - (set! registration - (permanently-register-io-thread-event - (x-display-descriptor (x-display/xd display)) - 'READ - (current-thread) - (lambda (mode) - mode - (call-with-current-continuation - (lambda (continuation) - (bind-condition-handler - (list condition-type:bad-range-argument - condition-type:wrong-type-argument) - (lambda (condition) - ;; If X-DISPLAY-PROCESS-EVENTS or - ;; X-DISPLAY-DESCRIPTOR signals an argument error - ;; on its display argument, that means the - ;; display has been closed. - condition - (deregister-io-thread-event registration) - (continuation unspecific)) - (lambda () - (let loop () - (let ((event - (x-display-process-events (x-display/xd display) - 2))) - (if event - (begin (process-event display event) - (loop)))))))))))) - (set-x-display/previewer-registration! display registration))) - -(define (read-event display) - (letrec ((loop - (let ((queue (x-display/event-queue display))) - (lambda () - (if (queue-empty? queue) - (begin - (%read-and-process-event display) - (loop)) - (dequeue! queue)))))) - (with-thread-events-blocked loop))) - -(define (%read-and-process-event display) - (let ((event - (or (x-display-process-events (x-display/xd display) 2) - (and (eq? 'READ - (test-for-io-on-descriptor - (x-display-descriptor (x-display/xd display)) - #t - 'READ)) - (x-display-process-events (x-display/xd display) 1))))) - (if event - (process-event display event)))) - -(define (discard-events display) - (letrec ((loop - (let ((queue (x-display/event-queue display))) - (lambda () - (cond ((not (queue-empty? queue)) - (dequeue! queue) - (loop)) - ((x-display-process-events (x-display/xd display) 2) - => - (lambda (event) - (process-event display event) - (loop)))))))) - (with-thread-events-blocked loop))) - -(define (process-event display event) - (without-interruption - (lambda () - (let ((window - (search-gc-finalizer (x-display/window-finalizer display) - (let ((xw (vector-ref event 1))) - (lambda (window) - (eq? (x-window/xw window) xw)))))) - (if window - (let ((type (vector-ref event 0))) - (let ((handler (vector-ref event-handlers type))) - (if handler - (handler window event))) - (if (or (fix:= event-type:delete-window type) - (not (fix:= 0 - (fix:and (fix:lsh 1 type) - (x-window/user-event-mask window))))) - (begin - ;; This would prefer to be the graphics device, but - ;; that's not available from here. - (vector-set! event 1 window) - (enqueue!/unsafe (x-display/event-queue display) - event))))))))) - -(define event-handlers - (make-vector number-of-event-types #f)) - -(define-integrable (define-event-handler event-type handler) - (vector-set! event-handlers event-type handler)) - -(define-event-handler event-type:configure - (lambda (window event) - (x-graphics-reconfigure (vector-ref event 1) - (vector-ref event 2) - (vector-ref event 3)) - (if (eq? 'NEVER (x-window/mapped? window)) - (set-x-window/mapped?! window #t)))) - -(define-event-handler event-type:delete-window - (lambda (window event) - event - (close-x-window window))) - -(define-event-handler event-type:map - (lambda (window event) - event - (set-x-window/mapped?! window #t))) - -(define-event-handler event-type:unmap - (lambda (window event) - event - (set-x-window/mapped?! window #f))) - -(define-event-handler event-type:visibility - (lambda (window event) - (case (vector-ref event 2) - ((0) (set-x-window/visibility! window 'UNOBSCURED)) - ((1) (set-x-window/visibility! window 'PARTIALLY-OBSCURED)) - ((2) (set-x-window/visibility! window 'OBSCURED))))) - -(let ((mouse-event-handler - (lambda (window event) - window - (let ((xw (vector-ref event 1))) - (vector-set! event 2 - (x-graphics-map-x-coordinate xw - (vector-ref event 2))) - (vector-set! event 3 - (x-graphics-map-y-coordinate xw - (vector-ref event 3))))))) - ;; ENTER and LEAVE events should be modified to have X,Y coordinates. - (define-event-handler event-type:button-down mouse-event-handler) - (define-event-handler event-type:button-up mouse-event-handler) - (define-event-handler event-type:motion mouse-event-handler)) - -;;;; Standard Operations - -(define x-graphics:auto-raise? #f) - -(define-structure (x-window (conc-name x-window/) - (constructor make-x-window (xw display))) - xw - (display #f read-only #t) - (mapped? 'NEVER) - (visibility #f) - (user-event-mask user-event-mask:default)) - -(define-integrable (x-graphics-device/xw device) - (x-window/xw (graphics-device/descriptor device))) - -(define (x-graphics/display device) - (x-window/display (graphics-device/descriptor device))) - -(define-integrable (x-graphics-device/xd device) - (x-display/xd (x-window/display (graphics-device/descriptor device)))) - -(define-integrable (x-graphics-device/mapped? device) - (eq? #t (x-window/mapped? (graphics-device/descriptor device)))) - -(define-integrable (x-graphics-device/visibility device) - (x-window/visibility (graphics-device/descriptor device))) - -(define (x-graphics/open-window? device) - (if (x-graphics-device/xw device) #t #f)) - -(define (x-graphics/close-window device) - (without-interruption - (lambda () - (close-x-window (graphics-device/descriptor device))))) - -(define (close-x-window window) - (remove-from-gc-finalizer! - (x-display/window-finalizer (x-window/display window)) - window)) - -(define (x-geometry-string x y width height) - (string-append (if (and width height) - (string-append (number->string width) - "x" - (number->string height)) - "") - (if (and x y) - (string-append (if (negative? x) "" "+") - (number->string x) - (if (negative? y) "" "+") - (number->string y)) - ""))) - -(define x-graphics-default-geometry "512x512") -(define x-graphics-default-display-name #f) - -(define (x-graphics/open descriptor->device - #!optional display geometry suppress-map?) - (let ((display - (let ((display - (and (not (default-object? display)) - display))) - (if (x-display? display) - display - (x-graphics/open-display display))))) - (call-with-values - (lambda () - (decode-suppress-map-arg (and (not (default-object? suppress-map?)) - suppress-map?) - 'MAKE-GRAPHICS-DEVICE)) - (lambda (map? resource class) - (let ((xw - (x-graphics-open-window - (x-display/xd display) - (if (default-object? geometry) - x-graphics-default-geometry - geometry) - (vector #f resource class)))) - (x-window-set-event-mask xw event-mask:normal) - (let ((window (make-x-window xw display))) - (add-to-gc-finalizer! (x-display/window-finalizer display) window) - (if map? (map-window window)) - (descriptor->device window))))))) - -(define (map-window window) - (let ((xw (x-window/xw window))) - (x-window-map xw) - ;; If this is the first time that this window has been mapped, we - ;; need to wait for a MAP event before continuing. - (if (not (boolean? (x-window/mapped? window))) - (begin - (x-window-flush xw) - (letrec ((loop - (let ((display (x-window/display window))) - (lambda () - (if (not (eq? #t (x-window/mapped? window))) - (begin - (%read-and-process-event display) - (loop))))))) - (with-thread-events-blocked loop)))))) - -(define (decode-suppress-map-arg suppress-map? procedure) - (cond ((boolean? suppress-map?) - (values (not suppress-map?) "schemeGraphics" "SchemeGraphics")) - ((and (pair? suppress-map?) - (string? (car suppress-map?)) - (string? (cdr suppress-map?))) - (values #f (car suppress-map?) (cdr suppress-map?))) - ((and (vector? suppress-map?) - (fix:= (vector-length suppress-map?) 3) - (boolean? (vector-ref suppress-map? 0)) - (string? (vector-ref suppress-map? 1)) - (string? (vector-ref suppress-map? 2))) - (values (vector-ref suppress-map? 0) - (vector-ref suppress-map? 1) - (vector-ref suppress-map? 2))) - (else - (error:wrong-type-argument suppress-map? - "X suppress-map arg" - procedure)))) - -(define (x-graphics/clear device) - (x-window-clear (x-graphics-device/xw device))) - -(define (x-graphics/coordinate-limits device) - (let ((limits (x-graphics-vdc-extent (x-graphics-device/xw device)))) - (values (vector-ref limits 0) (vector-ref limits 1) - (vector-ref limits 2) (vector-ref limits 3)))) - -(define (x-graphics/device-coordinate-limits device) - (let ((xw (x-graphics-device/xw device))) - (values 0 (- (x-window-y-size xw) 1) (- (x-window-x-size xw) 1) 0))) - -(define (x-graphics/drag-cursor device x y) - (x-graphics-drag-cursor (x-graphics-device/xw device) - (->flonum x) - (->flonum y))) - -(define (x-graphics/draw-line device x-start y-start x-end y-end) - (x-graphics-draw-line (x-graphics-device/xw device) - (->flonum x-start) - (->flonum y-start) - (->flonum x-end) - (->flonum y-end))) - -(define (x-graphics/draw-lines device xv yv) - (x-graphics-draw-lines (x-graphics-device/xw device) xv yv)) - -(define (x-graphics/draw-point device x y) - (x-graphics-draw-point (x-graphics-device/xw device) - (->flonum x) - (->flonum y))) - -(define (x-graphics/draw-points device xv yv) - (x-graphics-draw-points (x-graphics-device/xw device) xv yv)) - -(define (x-graphics/draw-text device x y string) - (x-graphics-draw-string (x-graphics-device/xw device) - (->flonum x) - (->flonum y) - string)) - -(define (x-graphics/draw-text-opaque device x y string) - (x-graphics-draw-image-string (x-graphics-device/xw device) - (->flonum x) - (->flonum y) - string)) - -(define (x-graphics/flush device) - (if (and x-graphics:auto-raise? - (x-graphics-device/mapped? device) - (not (eq? 'UNOBSCURED (x-graphics-device/visibility device)))) - (x-graphics/raise-window device)) - ((ucode-primitive x-display-flush 1) (x-graphics-device/xd device))) - -(define (x-graphics/move-cursor device x y) - (x-graphics-move-cursor (x-graphics-device/xw device) - (->flonum x) - (->flonum y))) - -(define (x-graphics/reset-clip-rectangle device) - (x-graphics-reset-clip-rectangle (x-graphics-device/xw device))) - -(define (x-graphics/set-clip-rectangle device x-left y-bottom x-right y-top) - (x-graphics-set-clip-rectangle (x-graphics-device/xw device) - (->flonum x-left) - (->flonum y-bottom) - (->flonum x-right) - (->flonum y-top))) - -(define (x-graphics/set-coordinate-limits device x-left y-bottom x-right y-top) - (x-graphics-set-vdc-extent (x-graphics-device/xw device) - (->flonum x-left) - (->flonum y-bottom) - (->flonum x-right) - (->flonum y-top))) - -(define (x-graphics/set-drawing-mode device mode) - (x-graphics-set-function (x-graphics-device/xw device) mode)) - -(define (x-graphics/set-line-style device line-style) - (if (not (and (exact-nonnegative-integer? line-style) (< line-style 8))) - (error:wrong-type-argument line-style "graphics line style" - 'SET-LINE-STYLE)) - (let ((xw (x-graphics-device/xw device))) - (if (zero? line-style) - (x-graphics-set-line-style xw 0) - (begin - (x-graphics-set-line-style xw 2) - (x-graphics-set-dashes xw - 0 - (vector-ref '#("\010\010" - "\001\001" - "\015\001\001\001" - "\013\001\001\001\001\001" - "\013\005" - "\014\001\002\001" - "\011\001\002\001\002\001") - (- line-style 1))))))) - -;;;; Appearance Operations - -(define (x-graphics/set-background-color device color) - (x-window-set-background-color (x-graphics-device/xw device) color)) - -(define (x-graphics/set-border-color device color) - (x-window-set-border-color (x-graphics-device/xw device) color)) - -(define (x-graphics/set-border-width device width) - (x-window-set-border-width (x-graphics-device/xw device) width)) - -(define (x-graphics/set-font device font) - (x-window-set-font (x-graphics-device/xw device) font)) - -(define (x-graphics/set-foreground-color device color) - (x-window-set-foreground-color (x-graphics-device/xw device) color)) - -(define (x-graphics/set-internal-border-width device width) - (x-window-set-internal-border-width (x-graphics-device/xw device) width)) - -(define (x-graphics/set-mouse-color device color) - (x-window-set-mouse-color (x-graphics-device/xw device) color)) - -(define (x-graphics/set-mouse-shape device shape) - (x-window-set-mouse-shape (x-graphics-device/xw device) shape)) - -;;;; Miscellaneous Operations - -(define (x-graphics/draw-arc device x y radius-x radius-y - angle-start angle-sweep fill?) - (x-graphics-draw-arc (x-graphics-device/xw device) - (->flonum x) - (->flonum y) - (->flonum radius-x) - (->flonum radius-y) - (->flonum angle-start) - (->flonum angle-sweep) - fill?)) - -(define (x-graphics/draw-circle device x y radius) - (x-graphics-draw-arc (x-graphics-device/xw device) - (->flonum x) - (->flonum y) - (->flonum radius) - (->flonum radius) - 0. - 360. - #f)) - -(define (x-graphics/fill-circle device x y radius) - (x-graphics-draw-arc (x-graphics-device/xw device) - (->flonum x) - (->flonum y) - (->flonum radius) - (->flonum radius) - 0. - 360. - #t)) - -(define (x-graphics/fill-polygon device point-vector) - (x-graphics-fill-polygon (x-graphics-device/xw device) - (vector-map ->flonum point-vector))) - -(define (x-graphics/copy-area device source-x-left source-y-top width height - destination-x-left destination-y-top) - (let ((xw (x-graphics-device/xw device))) - (x-graphics-copy-area xw xw - (->flonum source-x-left) - (->flonum source-y-top) - (->flonum width) - (->flonum height) - (->flonum destination-x-left) - (->flonum destination-y-top)))) - -(define (x-graphics/get-default device resource-name class-name) - (x-display-get-default (x-graphics-device/xd device) - resource-name class-name)) - -(define (x-graphics/starbase-filename device) - (x-window-starbase-filename (x-graphics-device/xw device))) - -(define (x-graphics/window-id device) - (x-window-id (x-graphics-device/xw device))) - -;;;; Event-Handling Operations - -(define (x-graphics/set-input-hint device input?) - (x-window-set-input-hint (x-graphics-device/xw device) input?)) - -(define (x-graphics/disable-keyboard-focus device) - ;; Tell the window to participate in the TAKE-FOCUS protocol. Since - ;; there is no handler for this event, focus will never be given to - ;; the window. - (x-window-set-event-mask (x-graphics-device/xw device) - event-mask:ignore-focus)) - -(define (x-graphics/enable-keyboard-focus device) - (x-window-set-event-mask (x-graphics-device/xw device) event-mask:normal)) - -(define (x-graphics/select-user-events device mask) - (set-x-window/user-event-mask! (graphics-device/descriptor device) mask)) - -(define (x-graphics/query-pointer device) - (let* ((window (x-graphics-device/xw device)) - (result (x-window-query-pointer window))) - (values (x-graphics-map-x-coordinate window (vector-ref result 2)) - (x-graphics-map-y-coordinate window (vector-ref result 3)) - (vector-ref result 4)))) - -(define (x-graphics/read-button device) - (let ((event (read-event-of-type device event-type:button-down))) - (values (vector-ref event 2) - (vector-ref event 3) - (vector-ref event 4)))) - -(define (read-event-of-type device event-type) - (let ((window (graphics-device/descriptor device)) - (display (x-graphics/display device))) - (let loop () - (let ((event (read-event display))) - (if (eq? window (vector-ref event 1)) - (begin - (if (fix:= (vector-ref event 0) event-type:delete-window) - (error "Window closed while waiting to read event.")) - (if (fix:= (vector-ref event 0) event-type) - event - (loop))) - (loop)))))) - -(define (x-graphics/read-user-event device) - (read-event (x-graphics/display device))) - -(define (x-graphics/discard-events device) - (discard-events (x-graphics/display device))) - -;;;; Font Operations - -(define (x-graphics/font-structure device string) - (x-font-structure (x-graphics-device/xd device) string)) - -(define-structure (x-font-structure (conc-name x-font-structure/) - (type vector)) - (name #f read-only #t) - (direction #f read-only #t) - (all-chars-exist? #f read-only #t) - (default-char #f read-only #t) - (min-bounds #f read-only #t) - (max-bounds #f read-only #t) - (start-index #f read-only #t) - (character-bounds #f read-only #t) - (max-ascent #f read-only #t) - (max-descent #f read-only #t)) - -(define-structure (x-character-bounds (conc-name x-character-bounds/) - (type vector)) - (lbearing #f read-only #t) - (rbearing #f read-only #t) - (width #f read-only #t) - (ascent #f read-only #t) - (descent #f read-only #t)) - -;;;; Window Management Operations - -(define (x-graphics/map-window device) - (map-window (graphics-device/descriptor device))) - -(define (x-graphics/withdraw-window device) - (x-window-withdraw (x-graphics-device/xw device))) - -(define (x-graphics/iconify-window device) - (x-window-iconify (x-graphics-device/xw device))) - -(define (x-graphics/raise-window device) - (x-window-raise (x-graphics-device/xw device))) - -(define (x-graphics/lower-window device) - (x-window-lower (x-graphics-device/xw device))) - -(define (x-graphics/set-icon-name device name) - (x-window-set-icon-name (x-graphics-device/xw device) name)) - -(define (x-graphics/set-window-name device name) - (x-window-set-name (x-graphics-device/xw device) name)) - -(define (x-graphics/move-window device x y) - (x-window-set-position (x-graphics-device/xw device) x y)) - -(define (x-graphics/resize-window device width height) - (x-window-set-size (x-graphics-device/xw device) width height)) - -;;;; Images - -;; X-IMAGE is the descriptor of the generic images. - -(define-structure (x-image (conc-name x-image/)) - descriptor - window - width - height) - -(define image-list) - -(define (initialize-image-datatype) - (1d-table/put! - (graphics-type-properties x-graphics-device-type) - 'IMAGE-TYPE - (make-image-type - `((create ,create-x-image) - (destroy ,x-graphics-image/destroy) - (width ,x-graphics-image/width) - (height ,x-graphics-image/height) - (draw ,x-graphics-image/draw) - (draw-subimage ,x-graphics-image/draw-subimage) - (fill-from-byte-vector ,x-graphics-image/fill-from-byte-vector)))) - (set! image-list - (make-gc-finalizer x-destroy-image - x-image? - x-image/descriptor - set-x-image/descriptor!)) - unspecific) - -(define (create-x-image device width height) - (let ((window (x-graphics-device/xw device))) - (add-to-gc-finalizer! image-list - (make-x-image (x-create-image window width height) - window width height)))) - -(define (x-image/destroy image) - (remove-from-gc-finalizer! image-list image)) - -(define (x-image/get-pixel image x y) - (x-get-pixel-from-image (x-image/descriptor image) x y)) - -(define (x-image/set-pixel image x y value) - (x-set-pixel-in-image (x-image/descriptor image) x y value)) - -(define (x-image/draw image window-x window-y) - (x-display-image (x-image/descriptor image) - 0 - 0 - (x-image/window image) - (->flonum window-x) - (->flonum window-y) - (x-image/width image) - (x-image/height image))) - -(define (x-image/draw-subimage image x y width height window-x window-y) - (x-display-image (x-image/descriptor image) - x - y - (x-image/window image) - (->flonum window-x) - (->flonum window-y) - width - height)) - -(define (x-image/fill-from-byte-vector image byte-vector) - (x-bytes-into-image byte-vector (x-image/descriptor image))) - -;; Abstraction layer for generic images - -(define (x-graphics/create-image device width height) - (image/create device width height)) - -;;(define x-graphics-image/create create-x-image) - -(define (x-graphics-image/destroy image) - (x-image/destroy (image/descriptor image))) - -(define (x-graphics-image/width image) - (x-image/width (image/descriptor image))) - -(define (x-graphics-image/height image) - (x-image/height (image/descriptor image))) - -(define (x-graphics-image/draw device x y image) - (let* ((x-image (image/descriptor image)) - (w (x-image/width x-image)) - (h (x-image/height x-image))) - (x-display-image (x-image/descriptor x-image) - 0 - 0 - (x-graphics-device/xw device) - (->flonum x) - (->flonum y) - w - h))) - -(define (x-graphics-image/draw-subimage device x y image im-x im-y w h) - (let ((x-image (image/descriptor image))) - (x-display-image (x-image/descriptor x-image) - im-x - im-y - (x-graphics-device/xw device) - (->flonum x) - (->flonum y) - w - h))) - -(define (x-graphics-image/fill-from-byte-vector image byte-vector) - (x-image/fill-from-byte-vector (image/descriptor image) byte-vector)) - -;;;; Colormaps - -(define-record-type - (%make-colormap descriptor) - x-colormap? - (descriptor colormap/descriptor set-colormap/descriptor!)) - -(define colormap-list) - -(define (initialize-colormap-datatype) - (set! colormap-list - (make-gc-finalizer x-free-colormap - x-colormap? - colormap/descriptor - set-colormap/descriptor!)) - unspecific) - -(define (make-colormap descriptor) - (add-to-gc-finalizer! colormap-list (%make-colormap descriptor))) - -(define (x-graphics/get-colormap device) - (make-colormap (x-window-colormap (x-graphics-device/xw device)))) - -(define (x-graphics/set-colormap device colormap) - (x-set-window-colormap (x-graphics-device/xw device) - (colormap/descriptor colormap))) - -(define (create-x-colormap device writeable?) - (let ((window (x-graphics-device/xw device))) - (let ((visual (x-window-visual window))) - (let ((descriptor (x-create-colormap window visual writeable?))) - (x-visual-deallocate visual) - (make-colormap descriptor))))) - -(define (x-colormap/free colormap) - (remove-from-gc-finalizer! colormap-list colormap)) - -(define (x-colormap/allocate-color colormap r g b) - (x-allocate-color (colormap/descriptor colormap) r g b)) - -(define (x-colormap/query-color colormap position) - (x-query-color (colormap/descriptor colormap) position)) - -(define (x-colormap/store-color colormap position r g b) - (x-store-color (colormap/descriptor colormap) position r g b)) - -(define (x-colormap/store-colors colormap color-vector) - (x-store-colors (colormap/descriptor colormap) color-vector)) - -(define (x-graphics/color? device) - (let ((info (x-graphics/visual-info device))) - (let ((n (vector-length info))) - (let loop ((index 0)) - (and (not (fix:= index n)) - (or (let ((class (x-visual-info/class (vector-ref info index)))) - (or (eq? x-visual-class:static-color class) - (eq? x-visual-class:pseudo-color class) - (eq? x-visual-class:true-color class) - (eq? x-visual-class:direct-color class))) - (loop (fix:+ index 1)))))))) - -(define (x-graphics/image-depth device) - (x-window-depth (x-graphics-device/xw device))) - -(define (x-graphics/visual-info device) - ((ucode-primitive x-get-visual-info 10) (x-graphics-device/xw device) - #f #f #f #f #f #f #f #f #f)) - -(define-structure (visual-info (type vector) (conc-name x-visual-info/)) - (visual #f read-only #t) - (visual-id #f read-only #t) - (screen #f read-only #t) - (depth #f read-only #t) - (class #f read-only #t) - (red-mask #f read-only #t) - (green-mask #f read-only #t) - (blue-mask #f read-only #t) - (colormap-size #f read-only #t) - (bits-per-rgb #f read-only #t)) - -(define-integrable x-visual-class:static-gray 0) -(define-integrable x-visual-class:gray-scale 1) -(define-integrable x-visual-class:static-color 2) -(define-integrable x-visual-class:pseudo-color 3) -(define-integrable x-visual-class:true-color 4) -(define-integrable x-visual-class:direct-color 5) \ No newline at end of file diff --git a/src/x11-screen/Makefile.am b/src/x11-screen/Makefile.am index aa78aa2d9..cf853f032 100644 --- a/src/x11-screen/Makefile.am +++ b/src/x11-screen/Makefile.am @@ -28,9 +28,10 @@ MIT_SCHEME_EXE = @MIT_SCHEME_EXE@ scmlibdir = @MIT_SCHEME_LIBDIR@ scmlib_subdir = $(scmlibdir)x11-screen -sources = x11-screen.scm # x11-key.scm x11-command.scm +sources = x11-screen.scm x11-key.scm x11-command.scm binaries = x11-screen.bci x11-screen.com -# binaries += x11-key.bci x11-key.com x11-command.scm.bci x11-command.scm.com +binaries += x11-key.bci x11-key.com +binaries += x11-command.bci x11-command.com scmlib_sub_DATA = $(sources) scmlib_sub_DATA += $(binaries) @@ -42,10 +43,10 @@ htmldir = $(libdir)/mit-scheme-pucked/doc dvidir = $(libdir)/mit-scheme-pucked/doc pdfdir = $(libdir)/mit-scheme-pucked/doc -#x11-key.bci: stamp-scheme -#x11-key.com: stamp-scheme -#x11-command.scm.bci: stamp-scheme -#x11-command.scm.com: stamp-scheme +x11-key.bci: stamp-scheme +x11-key.com: stamp-scheme +x11-command.bci: stamp-scheme +x11-command.com: stamp-scheme x11-screen.bci: stamp-scheme x11-screen.com: stamp-scheme x11-screen-@MIT_SCHEME_OS_SUFFIX@.pkd: stamp-scheme diff --git a/src/x11-screen/README b/src/x11-screen/README index d4cbc031f..06ad6a407 100644 --- a/src/x11-screen/README +++ b/src/x11-screen/README @@ -1,17 +1,16 @@ The X11-SCREEN option. -This is a drop-in replacement for Edwin's X screen-type that uses the -X11 plugin rather than the x11 microcode module. This plugin is not -part of the core build and can be built outside the core build tree in -the customary way: +This plugin creates an (edwin screen x11-screen) package that +registers an Edwin display type named X11, an exact replacement for +the microcode module based X display type. When this option is +loaded, with the DISPLAY environment variable set, Edwin will display +its frames in X11 windows by default. + +This plugin is built in the customary GNU way: ./configure ... make all check install -The install target copies a shared library shim and compiled Scheme -files into the system library path, and re-writes the optiondb.scm -found there. You can override the default command name "mit-scheme" -(and thus the system library path) by setting MIT_SCHEME_EXE. +To load: -To use: (load-option 'X11-SCREEN). Edwin will then create X11 type -screens rather than X type screens. + (load-option 'X11-SCREEN) diff --git a/src/x11-screen/compile.sh b/src/x11-screen/compile.sh index 5c0d625f9..1468965b3 100755 --- a/src/x11-screen/compile.sh +++ b/src/x11-screen/compile.sh @@ -43,8 +43,8 @@ ${MIT_SCHEME_EXE} --batch-mode <<\EOF (construct-packages-from-file (fasload package-set))) (compile-file "x11-screen" '() (->environment '(edwin screen x11-screen))) - ;;(compile-file "x11-key" '() (->environment '(edwin x-keys))) - ;;(compile-file "x11-com" '() (->environment '(edwin x-commands))) + (compile-file "x11-key" '() (->environment '(edwin x11-keys))) + (compile-file "x11-command" '() (->environment '(edwin x11-commands))) (cref/generate-constructors "x11-screen") ) diff --git a/src/x11-screen/ed-ffi.scm b/src/x11-screen/ed-ffi.scm index 7454c7ae8..08e7d94e6 100644 --- a/src/x11-screen/ed-ffi.scm +++ b/src/x11-screen/ed-ffi.scm @@ -28,6 +28,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ;; This list must be kept in alphabetical order by filename. (standard-scheme-find-file-initialization - '#(("x11-key" (edwin x-keys)) - ("x11-command" (edwin x-commands)) + '#(("x11-key" (edwin x11-keys)) + ("x11-command" (edwin x11-commands)) ("x11-screen" (edwin screen x11-screen)))) \ No newline at end of file diff --git a/src/x11-screen/make.scm b/src/x11-screen/make.scm index f1a8c5138..6a2767df4 100644 --- a/src/x11-screen/make.scm +++ b/src/x11-screen/make.scm @@ -9,68 +9,10 @@ Load the X11-Screen option. |# (load-package-set "x11-screen"))) (add-subsystem-identification! "X11-Screen" '(0 1)) -;; Reassign (edwin x-commands) bindings created by the define- -;; primitives form. Reassign them to their replacements in the (x11) -;; package. -(let ((xcom (->environment '(edwin x-commands))) - (x11 (->environment '(x11)))) - (for-each (lambda (name) - (environment-assign! xcom name (environment-lookup x11 name))) - '(x-list-fonts - x-set-default-font - x-window-clear - x-window-get-position - x-window-get-size - x-window-lower - x-window-raise - x-window-set-background-color - x-window-set-border-color - x-window-set-border-width - x-window-set-cursor-color - x-window-set-font - x-window-set-foreground-color - x-window-set-internal-border-width - x-window-set-mouse-color - x-window-set-mouse-shape - x-window-set-position - x-window-set-size - x-window-x-size - x-window-y-size - xterm-reconfigure - xterm-set-size - xterm-x-size - xterm-y-size))) - -;; Reassign (edwin screen x-screen) bindings exported to (edwin). +;; Reassign these (edwin) package bindings(!). (let ((edwin (->environment '(edwin))) (x11 (->environment '(edwin screen x11-screen)))) (for-each (lambda (name) (environment-assign! edwin name (environment-lookup x11 name))) - '(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!))) - -;; Reassign (edwin screen x-screen) bindings exported to (edwin x-commands). -(let ((edwin (->environment '(edwin x-commands))) - (x11 (->environment '(edwin screen x11-screen)))) - (for-each (lambda (name) - (environment-assign! edwin name (environment-lookup x11 name))) - '(screen-display - screen-xterm - xterm-screen/set-icon-name - xterm-screen/set-name))) - -;; Remove the X display type. If it stays on the list, its available? -;; operation will load the prx11 microcode module which contains -;; conflicting definitions for symbols like xterm_open_window. -(let ((env (->environment '(edwin display-type)))) - (set! (access display-types env) - (filter (lambda (display-type) - (not (eq? 'X ((access display-type/name env) display-type)))) - (access display-types env)))) \ No newline at end of file + '(os/interprogram-cut + os/interprogram-paste))) \ No newline at end of file diff --git a/src/x11-screen/x11-screen-check.sh b/src/x11-screen/x11-screen-check.sh index 00ec66b91..e96b0c908 100755 --- a/src/x11-screen/x11-screen-check.sh +++ b/src/x11-screen/x11-screen-check.sh @@ -10,9 +10,9 @@ ${MIT_SCHEME_EXE} --prepend-library . <<\EOF (or (not (string? display)) (string-null? display))) (warn "DISPLAY not set") - (let ((edwin (->environment '(edwin)))) + (begin (load-option 'X11-SCREEN) - (set! (access os/init-file-name edwin) + (set! (access os/init-file-name (->environment '(edwin))) (let ((pathname (merge-pathnames "x11-screen-test.scm"))) (named-lambda (os/init-file-name/x11-screen-test) pathname))) diff --git a/src/x11-screen/x11-screen.pkg b/src/x11-screen/x11-screen.pkg index a3a84ba04..7bc00f794 100644 --- a/src/x11-screen/x11-screen.pkg +++ b/src/x11-screen/x11-screen.pkg @@ -32,21 +32,15 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-package (edwin screen x11-screen) (files "x11-screen") (parent (edwin screen)) - ;; Until the microcode module based Edwin X Screen is removed, these - ;; bindings are already in (edwin) and (edwin x-commands). They - ;; cannot be exported again, and must be patched by - ;; (load-option 'x11-screen). - #;(export (edwin) + (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) + (export (edwin x11-commands) screen-display screen-xterm xterm-screen/set-icon-name @@ -55,12 +49,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. keyboard-peek-busy-no-hang) (import (edwin process) register-process-output-events) - (import (edwin x-keys) + (import (edwin x11-keys) x-make-special-key) - (import (edwin x-commands) + (import (edwin x11-commands) update-xterm-screen-names!) - ;; Import bindings that, in (edwin screen x-screen), are defined by - ;; a define-primitives form. (import (x11) x-change-property x-close-all-displays @@ -116,8 +108,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. xterm-write-substring! xterm-x-size xterm-y-size) - ;; Import bindings that, in (edwin screen x-screen), are defined by - ;; optimistic stabs at FFI constants. (import (x11) event-type:button-down event-type:button-up @@ -140,75 +130,34 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. event-type:property-notify number-of-event-types)) -#;(define-package (edwin x11-keys) +(define-package (edwin x11-keys) (files "x11-key") - (parent (edwin)) - (export (edwin screen x11-screen) - x-make-special-key)) + (parent (edwin))) -#;(define-package (edwin x-commands) - (files "x11-com") +(define-package (edwin x11-commands) + (files "x11-command") (parent (edwin)) - (import (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$x-screen-icon-name-format - edwin-variable$x-screen-icon-name-length - edwin-variable$x-screen-name-format - edwin-variable$x-screen-name-length - - ;; Convenience exports? Do we need non-X-specific - ;; abstractions to define mouse commands? - ;;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 - ) + (import (x11) + x-list-fonts + x-set-default-font + x-window-clear + x-window-get-position + x-window-get-size + x-window-lower + x-window-raise + x-window-set-background-color + x-window-set-border-color + x-window-set-border-width + x-window-set-cursor-color + x-window-set-font + x-window-set-foreground-color + x-window-set-internal-border-width + x-window-set-mouse-color + x-window-set-mouse-shape + x-window-set-position + xterm-reconfigure + xterm-set-size + xterm-x-size + xterm-y-size) (export (edwin screen x11-screen) update-xterm-screen-names!)) \ No newline at end of file diff --git a/src/x11/README b/src/x11/README index 5c9a8b430..9c84224b6 100644 --- a/src/x11/README +++ b/src/x11/README @@ -1,19 +1,21 @@ The X11 option. -This is a drop-in replacement for the x11 microcode module and -runtime/x11graph.scm. It is not part of the core build and can be -built outside the core build tree in the customary way: +This plugin creates an (x11) package emulating the primitives of the +old x11 microcode module. Its (x11 device) package registers a +graphics device type named X11, an exact replacement for the micro- +module based X graphics type. When this option is loaded, with the +DISPLAY environment variable set, make-graphics-device will display an +X11 window by default. + +This plugin is built in the customary GNU way: ./configure ... make all check install -The install target copies a shared library shim and compiled Scheme -files into the system library path, and re-writes the optiondb.scm -found there. You can override the default command name "mit-scheme" -(and thus the system library path) by setting MIT_SCHEME_EXE. +To load: + + (load-option 'X11) + +To import into a CREF package set, add this to your .pkg file: -To use: (load-option 'X11) and import the bindings you want. They are -not exported to the global environment because they would conflict -with the exports from (runtime x-graphics). Once this option is -loaded, make-graphics-device will create X11 graphics devices rather -than X graphics devices. + (global-definitions x11/) diff --git a/src/x11/make.scm b/src/x11/make.scm index dacdbe01f..cb02af5e5 100644 --- a/src/x11/make.scm +++ b/src/x11/make.scm @@ -5,113 +5,4 @@ Load the X11 option. |# (with-loader-base-uri (system-library-uri "x11/") (lambda () (load-package-set "x11"))) -(add-subsystem-identification! "X11" '(0 1)) - -;; Until the microcode module based X Graphics system is removed, -;; reassign the define-primitives bindings in (runtime x-graphics) to -;; their replacements in (x11). -(let ((x-graphics (->environment '(runtime x-graphics))) - (x11 (->environment '(x11)))) - (for-each (lambda (name) - (environment-assign! x-graphics name - (environment-lookup x11 name))) - '( - x-close-all-displays - x-display-descriptor - x-display-get-default - x-display-process-events - x-font-structure - x-window-beep - x-window-clear - x-window-colormap - x-window-depth - x-window-event-mask - x-window-flush - x-window-iconify - x-window-id - x-window-lower - x-window-map - x-window-query-pointer - x-window-raise - x-window-set-background-color - x-window-set-border-color - x-window-set-border-width - x-window-set-cursor-color - x-window-set-event-mask - x-window-set-font - x-window-set-foreground-color - x-window-set-icon-name - x-window-set-input-hint - x-window-set-internal-border-width - x-window-set-mouse-color - x-window-set-mouse-shape - x-window-set-name - x-window-set-position - x-window-set-size - ;; x-window-starbase-filename No such primitive! - x-window-visual - x-window-withdraw - x-window-x-size - x-window-y-size - x-graphics-copy-area - x-graphics-drag-cursor - x-graphics-draw-arc - x-graphics-draw-line - x-graphics-draw-lines - x-graphics-draw-point - x-graphics-draw-points - x-graphics-draw-string - x-graphics-draw-image-string - x-graphics-fill-polygon - x-graphics-map-x-coordinate - x-graphics-map-y-coordinate - x-graphics-move-cursor - x-graphics-open-window - x-graphics-reconfigure - x-graphics-reset-clip-rectangle - x-graphics-set-clip-rectangle - x-graphics-set-dashes - x-graphics-set-fill-style - x-graphics-set-function - x-graphics-set-line-style - x-graphics-set-vdc-extent - x-graphics-vdc-extent - x-bytes-into-image - x-create-image - x-destroy-image - x-display-image - x-get-pixel-from-image - x-set-pixel-in-image - x-allocate-color - x-create-colormap - x-free-colormap - x-query-color - x-set-window-colormap - x-store-color - x-store-colors - x-visual-deallocate))) - -;; Check that these (integrated!) constants DO "match" the C -;; constants, just because we can (with the FFI's help). -(let ((x-graphics (->environment '(runtime x-graphics))) - (x11 (->environment '(x11)))) - (for-each (lambda (name) - (if (not (equal? (environment-lookup x-graphics name) - (environment-lookup x11 name))) - (warn "Incorrect C constant in (runtime x-graphics):" name))) - '(event-type:button-down - event-type:button-up - event-type:configure - event-type:enter - event-type:focus-in - event-type:focus-out - event-type:key-press - event-type:leave - event-type:motion - event-type:expose - event-type:delete-window - event-type:map - event-type:unmap - event-type:take-focus - event-type:visibility - number-of-event-types))) \ No newline at end of file +(add-subsystem-identification! "X11" '(0 1)) \ No newline at end of file diff --git a/src/x11/x11.pkg b/src/x11/x11.pkg index ea2faa387..edbf9ddf9 100644 --- a/src/x11/x11.pkg +++ b/src/x11/x11.pkg @@ -172,7 +172,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-package (x11 device) (files "x11device") (parent (x11)) - (export (x11) + (export () create-x-colormap create-x-image x-character-bounds/ascent -- 2.25.1