--- /dev/null
+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/.
--- /dev/null
+
+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
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
+ ...))
(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
(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
"comatch"
"display"
"key-w32"
- "key-x11"
"macros"
"make"
"nntp"
"utils"
"win32"
"winren"
- "xform"
- "xterm"))
+ "xform"))
(sf-edwin "tterm" "termcap")
(let ((includes '("struct" "comman" "modes" "buffer" "edtstr")))
(let loop ((files includes) (includes '()))
"webster"
"wincom"
"winout"
- "xcom"
"win32com"
- "world-monitor"
- "xmodef")))
+ "world-monitor")))
(for-each sf-class
'("comwin"
"modwin"
("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))
("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
(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")
(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)))
(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"
"shell" ; shell subprocess commands
"techinfo" ; techinfo commands
"telnet" ; telnet subprocess commands
- "xmodef" ; x bindings for fundamental mode
"manual" ; man page display
"print" ; printer output
))
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")
(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))
(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.")))
(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))
+++ /dev/null
-#| -*-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
(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 ()
(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
+++ /dev/null
-#| -*-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
+++ /dev/null
-#| -*-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
+++ /dev/null
-#| -*-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
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/)
(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?
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
(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
(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))))
(global-definitions "../sos/sos")
(global-definitions "../edwin/edwin")
(global-definitions "../star-parser/parser")
+(global-definitions md5/)
(define-package (edwin imail)
(files "imail-util"
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
+ ...))
(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
(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
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
+ ...))
(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
(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
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
+ ...))
#| -*-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
(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?
[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]]]))
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=
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*)
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],
[
;;
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],
[],
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])
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
SCHEME_EXE=`dirname ${0}`/scheme
-CMD="@CCLD@ @LDFLAGS@ @MODULE_LDFLAGS@ -o ${OUT} ${@}"
+CMD="@CCLD@ @LDFLAGS@ -o ${OUT} ${@}"
echo "${CMD}"
eval "${CMD}"
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) ****
# **** Program definitions ****
aux_PROGRAMS = @AUX_PROGRAMS@
-aux_LIBS = $(MODULE_TARGETS)
+aux_LIBS =
aux_DATA = @AUX_DATA@
EXTRA_PROGRAMS = findprim
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
"cmpint"
"comutl"
-"prbfish"
-"prgdbm"
-"prmcrypt"
-"prmd5"
-"prmhash"
-"prpgsql"
"pruxdld"
"pruxffi"
-"prx11"
"svm1-interp"
"tterm"
"termcap"
"terminfo"
"tparam"
-"x11base"
-"x11color"
-"x11graph"
-"x11term"
#### 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.
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
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)
#### 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
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
+++ /dev/null
-/* -*-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 */
+++ /dev/null
-/* -*-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 */
+++ /dev/null
-/* -*-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 */
+++ /dev/null
-/* -*-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 */
+++ /dev/null
-/* -*-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 */
+++ /dev/null
-/* -*-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) */
+++ /dev/null
-/* -*-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) */
+++ /dev/null
-/* -*-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) */
+++ /dev/null
-/* -*-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) */
+++ /dev/null
-/* -*-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) */
+++ /dev/null
-/* -*-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) */
--- /dev/null
+The POSTGRES option.
+
+This is just the code for the old microcode module prpgsql as cut out
+of microcode/.
--- /dev/null
+
+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
--- /dev/null
+(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
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)
(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
(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
("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))
("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))
("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
+++ /dev/null
-#| -*-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
(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)
(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)
(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.
channel-descriptor)
(export (runtime microcode-errors)
port-error-test)
- (export (runtime x-graphics)
- have-select?)
(export (runtime thread)
add-to-select-registry!
have-select?
register-c-callback
set-alien/ctype!
update-html-index
- update-optiondb)
+ update-optiondb)
(initialization (initialize-package!)))
(define-package (runtime program-copier)
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
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")
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)
+++ /dev/null
-#| -*-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
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)
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
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)
(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")
)
;; 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
(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
(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)))
(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
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
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
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
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/)
(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
(define-package (x11 device)
(files "x11device")
(parent (x11))
- (export (x11)
+ (export ()
create-x-colormap
create-x-image
x-character-bounds/ascent