Punt microcode modules.
authorMatt Birkholz <puck@birchwood-abbey.net>
Fri, 10 Jun 2016 04:43:26 +0000 (21:43 -0700)
committerMatt Birkholz <puck@birchwood-abbey.net>
Fri, 10 Jun 2016 04:43:26 +0000 (21:43 -0700)
76 files changed:
src/berkeley-db/README [new file with mode: 0644]
src/berkeley-db/berkeley-db.scm [moved from src/runtime/berkeley-db.scm with 100% similarity]
src/berkeley-db/configure.ac [new file with mode: 0644]
src/berkeley-db/prdb4.c [moved from src/microcode/prdb4.c with 100% similarity]
src/berkeley-db/prdb4.scm [moved from src/microcode/prdb4.scm with 100% similarity]
src/blowfish/README
src/blowfish/blowfish.pkg
src/blowfish/make.scm
src/edwin/decls.scm
src/edwin/ed-ffi.scm
src/edwin/edwin.ldr
src/edwin/edwin.pkg
src/edwin/edwin.sf
src/edwin/filcom.scm
src/edwin/fileio.scm
src/edwin/key-x11.scm [deleted file]
src/edwin/kilcom.scm
src/edwin/nntp.scm
src/edwin/xcom.scm [deleted file]
src/edwin/xmodef.scm [deleted file]
src/edwin/xterm.scm [deleted file]
src/gdbm/README
src/gdbm/gdbm.pkg
src/gdbm/make.scm
src/imail/imail-mime.scm
src/imail/imail.pkg
src/mcrypt/README
src/mcrypt/make.scm
src/mcrypt/mcrypt.pkg
src/md5/README
src/md5/make.scm
src/md5/md5.pkg
src/mhash/README
src/mhash/make.scm
src/mhash/mhash.pkg
src/microcode/configure.ac
src/microcode/liarc-ld.in
src/microcode/makegen/Makefile.in.in
src/microcode/makegen/files-optional.scm
src/microcode/ntutl/makefile
src/microcode/ntutl/makefile.wcc
src/microcode/prbfish.c [deleted file]
src/microcode/prgdbm.c [deleted file]
src/microcode/prmcrypt.c [deleted file]
src/microcode/prmd5.c [deleted file]
src/microcode/prmhash.c [deleted file]
src/microcode/prx11.c [deleted file]
src/microcode/x11.h [deleted file]
src/microcode/x11base.c [deleted file]
src/microcode/x11color.c [deleted file]
src/microcode/x11graph.c [deleted file]
src/microcode/x11term.c [deleted file]
src/pgsql/README [new file with mode: 0644]
src/pgsql/configure.ac [new file with mode: 0644]
src/pgsql/pgsql.c [moved from src/microcode/prpgsql.c with 100% similarity]
src/pgsql/pgsql.pkg [new file with mode: 0644]
src/pgsql/pgsql.scm [moved from src/runtime/pgsql.scm with 100% similarity]
src/runtime/Makefile-fragment
src/runtime/blowfish.scm
src/runtime/crypto.scm
src/runtime/ed-ffi.scm
src/runtime/gdbm.scm [deleted file]
src/runtime/krypt.scm
src/runtime/make.scm
src/runtime/runtime.pkg
src/runtime/x11graph.scm [deleted file]
src/x11-screen/Makefile.am
src/x11-screen/README
src/x11-screen/compile.sh
src/x11-screen/ed-ffi.scm
src/x11-screen/make.scm
src/x11-screen/x11-screen-check.sh
src/x11-screen/x11-screen.pkg
src/x11/README
src/x11/make.scm
src/x11/x11.pkg

diff --git a/src/berkeley-db/README b/src/berkeley-db/README
new file mode 100644 (file)
index 0000000..a404bc9
--- /dev/null
@@ -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/berkeley-db/configure.ac b/src/berkeley-db/configure.ac
new file mode 100644 (file)
index 0000000..f562343
--- /dev/null
@@ -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 <db.h> 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.h>]],
+               [[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
index 3d283be3c28694cee9227631e830802d856302e5..3ca0db084b2878de38bd8ea38209b176dcff6a58 100644 (file)
@@ -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
+              ...))
index e31f55421ad9277a6013bfdefce409b4272fbe0f..f9131b8506b0d69228f524a0bbed589617fdec5c 100644 (file)
@@ -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
index f472239779fb07e1f47d468c22aacf529c6ec68b..80041e7313a9a02fe666209a1117d94542de21ea 100644 (file)
@@ -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
index 65ee8377e074dc2c7fb97fb100644fc4a2a26890..df13dc6dbb46abb1ae4a639e6058764e0f680a87 100644 (file)
@@ -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"
index 96f5db0ffec92bc06746409f2692e1644cb2d943..5e3bb9376668e40df8b235bbbaa1abf7d4c519f9 100644 (file)
@@ -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
index 012df60cdd025e2e09e123edd61e225f398c9ac9..e3a97fb2eb0b28e66914c4cd3982c83a77496351 100644 (file)
@@ -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)))
index b299c5faf8f751030082b0c7f01fc1ba1e5a96eb..2fc216a484da64d9e9b46e1f702d0a92596efaf5 100644 (file)
@@ -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")
index 9b92cc7c9487897aa95703fbd280ac6e79519955..455f586d22f4faac47cfe0d89a78586e5f9fb196 100644 (file)
@@ -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))
index 2d2826707f927e43280a3b2f90207e8436698966..7e35d98fc853c8c956e475503e44086e4decf8a8 100644 (file)
@@ -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)))
 \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.")))
index 0f5ef1323e189df139409bccd02bd95ea2c5cc2e..dfa65e8ba1d5c153c427698f9d2744ad97c51e6e 100644 (file)
@@ -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 (file)
index 686773f..0000000
+++ /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))
-\f
-(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
index 2d8568219db054aeee2fe301206dae680687784d..79621da6019aeebfaebc8dfb157e10ba321b1838 100644 (file)
@@ -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 ()
index bd63a8194d75ba3cf918fea738fbd407efb28d89..73a20ce162d2e016deaaae0dd409db89f7305d03 100644 (file)
@@ -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)))))))
 \f
 ;;;; NNTP Connection
 
diff --git a/src/edwin/xcom.scm b/src/edwin/xcom.scm
deleted file mode 100644 (file)
index ed7f54e..0000000
+++ /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)))
-\f
-(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))))
-\f
-(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))
-\f
-(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)))
-\f
-(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))))
-\f
-(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"))
-\f
-;;;; 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 (file)
index 90ee585..0000000
+++ /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))
-\f
diff --git a/src/edwin/xterm.scm b/src/edwin/xterm.scm
deleted file mode 100644 (file)
index ca7a048..0000000
+++ /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))
-\f
-(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))
-\f
-;; 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)
-\f
-(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))
-\f
-;;; 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))))
-\f
-(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)))))
-\f
-(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))
-\f
-;;;; 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)))))))))))
-\f
-(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)))))))
-\f
-(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))))
-\f
-(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)))))))
-\f
-(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)))
-\f
-;;;; 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))
-\f
-(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)))))
-\f
-;;;; 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)))))
-\f
-(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)
-\f
-;;;; 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))
-\f
-(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))
-\f
-(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))
-\f
-;;;; 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))
-\f
-(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)
-\f
-;;;; 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))
-\f
-;;;; 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
index 0266920050964c9cfe67664eaa0f9b9ccb518c0a..f49a22d20a468bde5cfeb1503a38b7d66befb1e3 100644 (file)
@@ -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/)
index 145b271b505b0da75df43b2a5e64d690a183afa0..1c92f44fa40eb11403b118988ef0b99d75e84a2e 100644 (file)
@@ -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
index 797efbb5838f616ad85e088bf9ebaa5d8c2875ab..c704d7a1990f188ecc26cc8d011ac0961cd4ca98 100644 (file)
@@ -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
index a2bb0172c928fc1034c27a6531e85828e81eb027..5fa69b5088a8740dd816a7cf5403b2fb80b3141b 100644 (file)
@@ -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))))
 
index 18073d46df9e397663afbb3626d271ed2e1356c3..aee9305af64252c79fc83d77e69bb9cd0211b4a7 100644 (file)
@@ -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"
index 7a73aaf9a97fd3dd4040608a910dd9fced01b43b..a50afd58cae0a67d012e3fb737d25610627a94b1 100644 (file)
@@ -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
+             ...))
index 3769afb047ae00e6a5ab5a422911dddf30f408c0..4105021bbbbdea72e04148105bca3a4db1bdcb8f 100644 (file)
@@ -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
index f536f003c62a6f3dd885bef6a2f0a7929388e8a1..734fd330282750bad2c322d27f2ac6c5b019bcf1 100644 (file)
@@ -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
index d3a4fdda3a738d8263e58b1dfcbaf52513ba6d2b..1da8a79163b99bb8abe043773da991877695f129 100644 (file)
@@ -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
+              ...))
index b84c650c36fde9562a1106787b0869470d7a43d3..fef938874da30801679f23594aeb64b0b4694d07 100644 (file)
@@ -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
index a9a5e4e2d115cfb26dc94997c73e19b183314671..b0ee1a60c78255dce3f733b4a57ce8775b754979 100644 (file)
@@ -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
index f83f43d52217cbb2ad4ad4bb2686323dd2731609..fc01080d812d99303fbb9171d8033bb460add9c5 100644 (file)
@@ -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
+              ...))
index 9f2d5000f9bb88f10dd45fa09f1fd37fab7b84af..d6e478fae16a04fe24215ac63253dd12418dade9 100644 (file)
@@ -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
index 183f3162fc033ac8a3efa0f20e883b7fddb11d29..b1285a17216bb3d1b0e438744476b2c7ce351ff9 100644 (file)
@@ -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?
index 42d8a56707e8759ceb53df9d724fc01dca1a5078..09806080cc9861203455c3c882a7f02f882e046a 100644 (file)
@@ -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 <mhash.h> & <mcrypt.h>,
-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 <mhash.h> 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 <mcrypt.h> 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 <gdbm.h> 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 <db.h> 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.h>]],
-               [[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 <libpq-fe.h> 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
index 5a0f1fd853b7fc45bc759f7693fe2c4164c07146..a0d17e952db41dc40e262a71cfc482941d3aa01c 100644 (file)
@@ -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}"
index 23be62010b3f3fcbb622b80a7392e3a1eb6787cc..4051be7614fcdfe1ba3bd0f019f2cc6101f58326 100644 (file)
@@ -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
index 0dac0eea7b913545f5aa556060ec7abbe9a78d84..e4c45cc4db2804bfd5827db1237b7f42d885a687 100644 (file)
@@ -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"
index 727cd5436398e2006714122e6c44614a22af6d69..02a561354b1e4afb5640c267d8010420131e871f 100644 (file)
 #### Makefile for Scheme under Win32 compiled by Microsoft Visual C++.
 !include <win32.mak>
 
-#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)
index 686c6a53adc5b623197d738baabad13ec8176ae3..590378f6e00fe2c939f411f1e3985d653f1eb903 100644 (file)
@@ -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 (file)
index 8464a3d..0000000
+++ /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 <openssl/blowfish.h>
-#else
-#  ifdef HAVE_BLOWFISH_H
-#    include <blowfish.h>
-#  endif
-#endif
-
-/* This interface uses the Blowfish library from SSLeay.  */
-\f
-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 (file)
index 515c8fb..0000000
+++ /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 <gdbm.h>
-#endif
-\f
-/* 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);
-}
-\f
-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 ();
-}
-\f
-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)))));
-}
-\f
-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 (file)
index 20c37b5..0000000
+++ /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 <mcrypt.h>
-#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);
-    }
-}
-\f
-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)]);
-}
-\f
-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 (file)
index f3ffc38..0000000
+++ /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 <openssl/md5.h>
-#else
-#  ifdef HAVE_MD5_H
-#    include <md5.h>
-#  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
-\f
-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 (file)
index 7a01cc4..0000000
+++ /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 <mhash.h>
-#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);
-    }
-}
-\f
-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);
-}
-\f
-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)
-\f
-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);
-  }
-}
-\f
-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)
-\f
-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 (file)
index 058e98a..0000000
+++ /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 (file)
index 7fc9740..0000000
+++ /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 <X11/Xlib.h>
-#include <X11/cursorfont.h>
-#include <X11/keysym.h>
-#include <X11/Xutil.h>
-#include <X11/Xatom.h>
-\f
-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;
-};
-\f
-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);
-\f
-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);
-\f
-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 (file)
index 427c2e1..0000000
+++ /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 <X11/Xmd.h>
-#include <X11/keysym.h>
-
-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);
-}
-\f
-/* 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);
-}
-\f
-/* 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);
-}
-\f
-/* 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)));
-}
-\f
-/* 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);
-}
-\f
-/* 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);
-    }
-}
-\f
-/* 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));
-    }
-}
-\f
-/* 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);
-}
-\f
-/* 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);
-}
-\f
-/* 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);
-}
-\f
-/* 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)));
-  }
-}
-\f
-/* 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);
-}
-\f
-/* 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);
-}
-\f
-/* 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);
-}
-\f
-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;
-}
-\f
-/* 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);
-    }
-  }
-}
-\f
-/* 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);
-  }
-}
-\f
-/* 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);
-}
-\f
-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);
-    }
-  }
-}
-\f
-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);
-}
-\f
-/* 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);
-}
-\f
-#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 (file)
index 359d11c..0000000
+++ /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"
-\f
-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);
-    }
-  }
-}
-\f
-/* 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);
-}
-\f
-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);
-  }
-}
-\f
-/* 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);
-}
-\f
-#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);
-}
-\f
-#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);
-}
-\f
-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);
-    }
-  }
-}
-\f
-/* 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);
-}
-\f
-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);
-}
-\f
-#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 (file)
index 07f4b50..0000000
+++ /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"
-\f
-#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)))));
-}
-\f
-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);
-}
-\f
-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);
-}
-\f
-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);
-}
-\f
-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));
-      }
-    }
-  }
-}
-\f
-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);
-}
-\f
-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<x1) { /* x-axis flip */
-      int t=x1; x1=x2; x2=t;
-      if (angle1 < 64*180)
-       angle1 = 64*180 - angle1;
-      else
-       angle1 = 64*540 - angle1;
-      angle2 = -angle2;
-    }
-    if (y2<y1) { /* y-axis flip */
-      int t=y1; y1=y2; y2=t;
-      angle1 = 64*360 - angle1;
-      angle2 = -angle2;
-    }
-    width  = x2 - x1;
-    height = y2 - y1;
-    if (ARG_REF(8) == SHARP_F)
-      XDrawArc
-       ((XW_DISPLAY (xw)),
-        (XW_WINDOW (xw)),
-        (XW_NORMAL_GC (xw)),
-        (internal_border_width + x1),
-        (internal_border_width + y1),
-        width, height,  angle1, angle2);
-    else
-      XFillArc
-       ((XW_DISPLAY (xw)),
-        (XW_WINDOW (xw)),
-        (XW_NORMAL_GC (xw)),
-        (internal_border_width + x1),
-        (internal_border_width + y1),
-        width, height,  angle1, angle2);
-  }
-  PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-/**************   TEST PROGRAM FOR X-GRAPHICS-DRAW-ARC  *****************
-(define g (make-graphics-device))
-
-(define (test dx dy a1 a2)
-  (let ((x .3)
-       (y .4)
-       (r .2))
-    (define (fx a) (+ x (* r (cos (* a (asin 1) 1/90)))))
-    (define (fy a) (+ y (* r (sin (* a (asin 1) 1/90)))))
-    (graphics-set-coordinate-limits g (- dx) (- dy) dx dy)
-    (graphics-operation g 'set-foreground-color "black")
-    (graphics-clear g)
-
-    (graphics-draw-text g   0   0 ".")
-
-    (graphics-draw-line g  -1   0 1 0)
-    (graphics-draw-line g   0  -1 0 1)
-    (graphics-draw-line g   0   0 1 1)
-    (graphics-draw-text g  .5   0 "+X")
-    (graphics-draw-text g -.5   0 "-X")
-    (graphics-draw-text g   0  .5 "+Y")
-    (graphics-draw-text g   0 -.5 "-Y")
-
-    ;; The grey wedge is that that 10 degrees of the arc.
-    (graphics-operation g 'set-foreground-color "grey")
-    (graphics-operation g 'draw-arc x y r r a1 a2 #T)
-    (graphics-operation g 'set-foreground-color "black")
-    (graphics-operation g 'draw-arc x y r r a1 (+ a2 (if (< a2 0) 10 -10)) #T)
-
-    (graphics-operation g 'set-foreground-color "red")
-    (graphics-draw-text g x y ".O")
-
-    (let ((b1 (min a1 (+ a1 a2)))
-         (b2 (max a1 (+ a1 a2))))
-      (do ((a b1 (+ a 5)))
-         ((> 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)
- ***********************************************************************/
-\f
-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);
-}
-\f
-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);
-}
-\f
-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);
-  }
-}
-\f
-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);
-  }
-}
-\f
-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);
-  }
-}
-\f
-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);
-  }
-}
-\f
-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)));
-  }
-}
-\f
-#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 (file)
index 81e3036..0000000
+++ /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"
-\f
-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
-\f
-#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)
-{
-}
-\f
-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++);
-  }
-}
-\f
-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);
-       }
-    }
-}
-\f
-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));
-}
-\f
-#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));
-    }
-}
-\f
-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))))));
-  }
-}
-\f
-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));
-  }
-}
-\f
-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);
-}
-\f
-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);
-}
-\f
-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);
-}
-\f
-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);
-}
-\f
-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);
-}
-\f
-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);
-}
-\f
-#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 (file)
index 0000000..ebcad4d
--- /dev/null
@@ -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 (file)
index 0000000..124148b
--- /dev/null
@@ -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 <libpq-fe.h> 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
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 (file)
index 0000000..a5b0123
--- /dev/null
@@ -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
similarity index 100%
rename from src/runtime/pgsql.scm
rename to src/pgsql/pgsql.scm
index e39b9958b6bc0084a86eb2998c1d2a17281616e6..9ee60714b4ed7cef1a382159b8ada6568ea2eeb5 100644 (file)
@@ -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)
index 76e34909507a3c0c85d6d513c93eade2f5540da8..60dc1844195d27eb48c21230fa2622a237f6fb0f 100644 (file)
@@ -29,76 +29,52 @@ USA.
 
 (declare (usual-integrations))
 \f
-(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
index bd60582b4f63d6630070d7968a7ffbdad4ee99b7..d31aef885151f0d0212dbf633dac424f32ff22df 100644 (file)
@@ -29,507 +29,144 @@ USA.
 
 (declare (usual-integrations))
 \f
-;;;; 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))
-\f
-(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))
-\f
-(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)))))
-\f
-(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)))
-\f
-;;;; 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)
-\f
-;;;; 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))))))
-\f
-(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)))
-\f
-(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)))))
-\f
-;;;; 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
index cdf5309d35c9a79f165f2d5cc53646e532f04fda..7baaea2d6eeddb568dbae047f9c6e5ba60907878 100644 (file)
@@ -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 (file)
index f9c4723..0000000
+++ /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))
-\f
-(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
index 7c6235be9447dc98d4ad5fc220d6701459a66582..dbe94bc89741f78013fc1138a3112e2ff7db700e 100644 (file)
@@ -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)
index 724f6e19c998fbcfa9dc3ce5255b73a02091e176..e0e84db460868b7e42eeb52930bfa01f4b48853c 100644 (file)
@@ -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.
index 54feee00b382dd7be9a37f77687a9332ff83ba6d..31d31c881830b8c3b8bddae7a55d1fd8f9541ea5 100644 (file)
@@ -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))
 \f
 (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 (file)
index cdf9985..0000000
+++ /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"))
-\f
-(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))
-\f
-;; 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)
-\f
-;;;; 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)
-\f
-;;;; 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))
-\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)))
-\f
-(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))
-\f
-(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))
-\f
-;;;; 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))
-                    "")))
-\f
-(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))))
-\f
-(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)))
-\f
-(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))
-\f
-;;;; 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)))
-\f
-;;;; 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)))
-\f
-;;;; 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))
-\f
-;;;; 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)))
-\f
-;; 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))
-\f
-;;;; Colormaps
-
-(define-record-type <colormap>
-    (%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))
-\f
-(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
index aa78aa2d9588f5974e0df782c60bd288851d7d7b..cf853f0325f9df13ff088de46756b3777acc7500 100644 (file)
@@ -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
index d4cbc031f22f7c3aa1e2425d6f9bed56df2288a4..06ad6a40722bafc202a0e62d85383babd251f1c7 100644 (file)
@@ -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)
index 5c0d625f92f30f8e31a49d402771ac2730528fa5..1468965b3c0ec7c462f22847f5885f16fc96baed 100755 (executable)
@@ -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")
   )
index 7454c7ae8c03f80d068ac3c41bc084e4b31c8194..08e7d94e6c8f6611fbe7d0f3082bddd395d4153d 100644 (file)
@@ -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
index f1a8c51382c38e26b8eaf99394b50ec006fb4a06..6a2767df449516c6215cdde68938919dbe7097fb 100644 (file)
@@ -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
index 00ec66b919bf8d2552223d48393327ef5efacb93..e96b0c9082164e1f9a57238344a25261afb30fd5 100755 (executable)
@@ -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)))
index a3a84ba04c06f9565cb9bdcc3768977db7647427..7bc00f794d0dc0cb2363b5a5ec2444807dca0b19 100644 (file)
@@ -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
index 5c9a8b430942c75e4ec27e54689f06943c29474b..9c84224b6b4ccbd3c7a3f733346297751fc02317 100644 (file)
@@ -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/)
index dacdbe01fee7dc4e5f86d1b3e1f75aeafe8230dd..cb02af5e5ca469ef6af6a6b0069aeb2ecd4b9dbc 100644 (file)
@@ -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
index ea2faa3874c7266d14f66ed03bd6cbe944a02f0c..edbf9ddf9342deb73b9d20b532bf83a4669f1a53 100644 (file)
@@ -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