From ff99fe9fee46ea2466bb8a8641e19b6021a6ace3 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Fri, 14 Jan 2005 12:39:41 +0000 Subject: [PATCH] Remove old CLOCC CLX library --- src/eclx/README | 59 - src/eclx/RELEASE-NOTES | 13 - src/eclx/attributes.lisp | 635 ------ src/eclx/buffer.lisp | 1551 ------------- src/eclx/bufmac.lisp | 187 -- src/eclx/clx.lisp | 940 -------- src/eclx/compile-and-load.lisp | 64 - src/eclx/debug/debug.lisp | 77 - src/eclx/debug/describe.lisp | 1243 ----------- src/eclx/debug/event-test.lisp | 237 -- src/eclx/debug/keytrans.lisp | 266 --- src/eclx/debug/trace.lisp | 456 ---- src/eclx/debug/util.lisp | 167 -- src/eclx/demo/bezier.lisp | 39 - src/eclx/demo/beziertest.lisp | 81 - src/eclx/demo/hello.lisp | 65 - src/eclx/demo/menu.lisp | 382 ---- src/eclx/demo/qix.lisp | 97 - src/eclx/demo/shape-test.lisp | 26 - src/eclx/demo/zoid.lisp | 58 - src/eclx/depdefs.lisp | 394 ---- src/eclx/dependent.lisp | 1460 ------------ src/eclx/display.lisp | 642 ------ src/eclx/doc.lisp | 3806 -------------------------------- src/eclx/fonts.lisp | 368 --- src/eclx/gcontext.lisp | 974 -------- src/eclx/graphics.lisp | 450 ---- src/eclx/image.lisp | 2673 ---------------------- src/eclx/input.lisp | 1870 ---------------- src/eclx/keysyms.lisp | 162 -- src/eclx/load.lsp.in | 24 - src/eclx/macros.lisp | 1086 --------- src/eclx/manager.lisp | 763 ------- src/eclx/package.lisp | 168 -- src/eclx/requests.lisp | 1494 ------------- src/eclx/resource.lisp | 697 ------ src/eclx/shape.lisp | 192 -- src/eclx/split-sequence.lisp | 243 -- src/eclx/test/image.lisp | 155 -- src/eclx/test/trapezoid.lisp | 72 - src/eclx/text.lisp | 1063 --------- src/eclx/translate.lisp | 559 ----- 42 files changed, 25958 deletions(-) delete mode 100644 src/eclx/README delete mode 100644 src/eclx/RELEASE-NOTES delete mode 100644 src/eclx/attributes.lisp delete mode 100644 src/eclx/buffer.lisp delete mode 100644 src/eclx/bufmac.lisp delete mode 100644 src/eclx/clx.lisp delete mode 100644 src/eclx/compile-and-load.lisp delete mode 100644 src/eclx/debug/debug.lisp delete mode 100644 src/eclx/debug/describe.lisp delete mode 100644 src/eclx/debug/event-test.lisp delete mode 100644 src/eclx/debug/keytrans.lisp delete mode 100644 src/eclx/debug/trace.lisp delete mode 100644 src/eclx/debug/util.lisp delete mode 100644 src/eclx/demo/bezier.lisp delete mode 100644 src/eclx/demo/beziertest.lisp delete mode 100644 src/eclx/demo/hello.lisp delete mode 100644 src/eclx/demo/menu.lisp delete mode 100644 src/eclx/demo/qix.lisp delete mode 100644 src/eclx/demo/shape-test.lisp delete mode 100644 src/eclx/demo/zoid.lisp delete mode 100644 src/eclx/depdefs.lisp delete mode 100644 src/eclx/dependent.lisp delete mode 100644 src/eclx/display.lisp delete mode 100644 src/eclx/doc.lisp delete mode 100644 src/eclx/fonts.lisp delete mode 100644 src/eclx/gcontext.lisp delete mode 100644 src/eclx/graphics.lisp delete mode 100644 src/eclx/image.lisp delete mode 100644 src/eclx/input.lisp delete mode 100644 src/eclx/keysyms.lisp delete mode 100644 src/eclx/load.lsp.in delete mode 100644 src/eclx/macros.lisp delete mode 100644 src/eclx/manager.lisp delete mode 100644 src/eclx/package.lisp delete mode 100644 src/eclx/requests.lisp delete mode 100644 src/eclx/resource.lisp delete mode 100644 src/eclx/shape.lisp delete mode 100644 src/eclx/split-sequence.lisp delete mode 100644 src/eclx/test/image.lisp delete mode 100644 src/eclx/test/trapezoid.lisp delete mode 100644 src/eclx/text.lisp delete mode 100644 src/eclx/translate.lisp diff --git a/src/eclx/README b/src/eclx/README deleted file mode 100644 index ae74a28ab..000000000 --- a/src/eclx/README +++ /dev/null @@ -1,59 +0,0 @@ -Requirements: (working == demo/hello hello-world works) - -- clisp version 2.28 or higher (earlier versions have pathname problems) -- acl (untested by the author) -- lwl (untested by the author) -- cmucl -- sbcl with db-sockets with notes: - + please do - (pushnew :db-sockets *features*) - after loading db-sockets) - + there is a problem with home: as logical pathname, please do: - -(setf (logical-pathname-translations "home") - '(("**;*.*.*" "/home/pvaneynd/**/*.*") - (";**;*.*.*" "/home/pvaneynd/**/*.*"))) - -Problems with: - --lwl: I don't know how to open the unix socket --acl: Didn't have time to download the newst and greatest version yet and - my older licence expired :-( - -How to compile and load clx without common-lisp-controller: - -(load "compile-and-load") - -To test: - -(load "demo/hello") -(xlib::hello-world "") - -With common-lisp-controller: (please note that the patches included in the clocc-port -subdirectory have not yet been send upstream, so the cvs and cclan version won't do) - -Put the source in for example ~/common-lisp/src/clx and add the following to your -startup script ( ~/.sbclrc or ~/.cmucl-init.lisp) - -|;;; -*- Mode: Lisp; Package: USER; Base: 10; Syntax: Common-Lisp -*- -| -|(load "/etc/sbclrc") -| -|(format t "Hello Peter!~%") -| -|(common-lisp-controller:add-project-directory -| #p"/home/pvaneynd/common-lisp/src/" -| #p"/home/pvaneynd/common-lisp/fasl-sbcl/" -| '("CLX") -| "/home/pvaneynd/common-lisp/systems/") - -then you can do: - -* (require :db-sockets) -* (pushnew :db-sockets *features*) -* (require :clocc-port) -* (mk:oos :clx :compile) -* (mk:oos :clx :load) - -comments to: -Peter Van Eynde pvaneynd@debian.org diff --git a/src/eclx/RELEASE-NOTES b/src/eclx/RELEASE-NOTES deleted file mode 100644 index 8e6656615..000000000 --- a/src/eclx/RELEASE-NOTES +++ /dev/null @@ -1,13 +0,0 @@ -This is the second release. Major changes include the addition of the -clxman-sources from Gilbert Baumann and the removal of the clocc-port -dependency. - -Old notes: - -This is a 'get it out of the door' release. The subsystems included have patches -that still have to be integrated with upstream. - -Expect a more polished release soon. But in the mean time I would appriciate -bugreports on this release. If you do encounter problems, please recompile -with debug 3 and send a traceback. - diff --git a/src/eclx/attributes.lisp b/src/eclx/attributes.lisp deleted file mode 100644 index 6fc656eb1..000000000 --- a/src/eclx/attributes.lisp +++ /dev/null @@ -1,635 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; Window Attributes - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; -#+cmu -(ext:file-comment - "$Header$") - -;;; The special variable *window-attributes* is an alist containg: -;;; (drawable attributes attribute-changes geometry geometry-changes) -;;; Where DRAWABLE is the associated window or pixmap -;;; ATTRIBUTES is NIL or a reply-buffer containing the drawable's -;;; attributes for use by the accessors. -;;; ATTRIBUTE-CHANGES is NIL or an array. The first element -;;; of the array is a "value-mask", indicating which -;;; attributes have changed. The other elements are -;;; integers associated with the changed values, ready -;;; for insertion into a server request. -;;; GEOMETRY is like ATTRIBUTES, but for window geometry -;;; GEOMETRY-CHANGES is like ATTRIBUTE-CHANGES, but for window geometry -;;; -;;; Attribute and Geometry accessors and SETF's look on the special variable -;;; *window-attributes* for the drawable. If its not there, the accessor is -;;; NOT within a WITH-STATE, and a server request is made to get or put a value. -;;; If an entry is found in *window-attributes*, the cache buffers are used -;;; for the access. -;;; -;;; All WITH-STATE has to do (re)bind *Window-attributes* to a list including -;;; the new drawable. The caches are initialized to NIL and allocated as needed. - -(in-package :xlib) - -(eval-when (:compile-toplevel :load-toplevel :execute) ;needed by Franz Lisp -(defconstant +attribute-size+ 44) -(defconstant +geometry-size+ 24) -(defconstant +context-size+ (max +attribute-size+ +geometry-size+ (* 16 4)))) - -(defvar *window-attributes* nil) ;; Bound to an alist of (drawable . state) within WITH-STATE - -;; Window Attribute reply buffer resource -(defvar *context-free-list* nil) ;; resource of free reply buffers - -(defun allocate-context () - (or (threaded-atomic-pop *context-free-list* reply-next reply-buffer) - (make-reply-buffer +context-size+))) - -(defun deallocate-context (context) - (declare (type reply-buffer context)) - (threaded-atomic-push context *context-free-list* reply-next reply-buffer)) - -(defmacro state-attributes (state) `(second ,state)) -(defmacro state-attribute-changes (state) `(third ,state)) -(defmacro state-geometry (state) `(fourth ,state)) -(defmacro state-geometry-changes (state) `(fifth ,state)) - -(defmacro drawable-equal-function () - (if (member 'drawable *clx-cached-types*) - ''eq ;; Allows the compiler to use the microcoded ASSQ primitive on LISPM's - ''drawable-equal)) - -(defmacro window-equal-function () - (if (member 'window *clx-cached-types*) - ''eq - ''drawable-equal)) - -(defmacro with-state ((drawable) &body body) - ;; Allows a consistent view to be obtained of data returned by GetWindowAttributes - ;; and GetGeometry, and allows a coherent update using ChangeWindowAttributes and - ;; ConfigureWindow. The body is not surrounded by a with-display. Within the - ;; indefinite scope of the body, on a per-process basis in a multi-process - ;; environment, the first call within an Accessor Group on the specified drawable - ;; (the object, not just the variable) causes the complete results of the protocol - ;; request to be retained, and returned in any subsequent accessor calls. Calls - ;; within a Setf Group are delayed, and executed in a single request on exit from - ;; the body. In addition, if a call on a function within an Accessor Group follows - ;; a call on a function in the corresponding Setf Group, then all delayed setfs for - ;; that group are executed, any retained accessor information for that group is - ;; discarded, the corresponding protocol request is (re)issued, and the results are - ;; (again) retained, and returned in any subsequent accessor calls. - - ;; Accessor Group A (for GetWindowAttributes): - ;; window-visual, window-visual-info, window-class, window-gravity, window-bit-gravity, - ;; window-backing-store, window-backing-planes, window-backing-pixel, - ;; window-save-under, window-colormap, window-colormap-installed-p, - ;; window-map-state, window-all-event-masks, window-event-mask, - ;; window-do-not-propagate-mask, window-override-redirect - - ;; Setf Group A (for ChangeWindowAttributes): - ;; window-gravity, window-bit-gravity, window-backing-store, window-backing-planes, - ;; window-backing-pixel, window-save-under, window-event-mask, - ;; window-do-not-propagate-mask, window-override-redirect, window-colormap, - ;; window-cursor - - ;; Accessor Group G (for GetGeometry): - ;; drawable-root, drawable-depth, drawable-x, drawable-y, drawable-width, - ;; drawable-height, drawable-border-width - - ;; Setf Group G (for ConfigureWindow): - ;; drawable-x, drawable-y, drawable-width, drawable-height, drawable-border-width, - ;; window-priority - (let ((state-entry (gensym))) - ;; alist of (drawable attributes attribute-changes geometry geometry-changes) - `(with-stack-list (,state-entry ,drawable nil nil nil nil) - (with-stack-list* (*window-attributes* ,state-entry *window-attributes*) - (multiple-value-prog1 - (progn ,@body) - (cleanup-state-entry ,state-entry)))))) - -(defun cleanup-state-entry (state) - ;; Return buffers to the free-list - (let ((entry (state-attributes state))) - (when entry (deallocate-context entry))) - (let ((entry (state-attribute-changes state))) - (when entry - (put-window-attribute-changes (car state) entry) - (deallocate-gcontext-state entry))) - (let ((entry (state-geometry state))) - (when entry (deallocate-context entry))) - (let ((entry (state-geometry-changes state))) - (when entry - (put-drawable-geometry-changes (car state) entry) - (deallocate-gcontext-state entry)))) - - - -(defun change-window-attribute (window number value) - ;; Called from window attribute SETF's to alter an attribute value - ;; number is the change-attributes request mask bit number - (declare (type window window) - (type card8 number) - (type card32 value)) - (let ((state-entry nil) - (changes nil)) - (if (and *window-attributes* - (setq state-entry (assoc window (the list *window-attributes*) - :test (window-equal-function)))) - (progn ; Within a WITH-STATE - cache changes - (setq changes (state-attribute-changes state-entry)) - (unless changes - (setq changes (allocate-gcontext-state)) - (setf (state-attribute-changes state-entry) changes) - (setf (aref changes 0) 0)) ;; Initialize mask to zero - (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit - (setf (aref changes (1+ number)) value)) ;; save value - ; Send change to the server - (with-buffer-request ((window-display window) +x-changewindowattributes+) - (window window) - (card32 (ash 1 number) value))))) -;; -;; These two are twins (change-window-attribute change-drawable-geometry) -;; If you change one, you probably need to change the other... -;; -(defun change-drawable-geometry (drawable number value) - ;; Called from drawable geometry SETF's to alter an attribute value - ;; number is the change-attributes request mask bit number - (declare (type drawable drawable) - (type card8 number) - (type card29 value)) - (let ((state-entry nil) - (changes nil)) - (if (and *window-attributes* - (setq state-entry (assoc drawable (the list *window-attributes*) - :test (drawable-equal-function)))) - (progn ; Within a WITH-STATE - cache changes - (setq changes (state-geometry-changes state-entry)) - (unless changes - (setq changes (allocate-gcontext-state)) - (setf (state-geometry-changes state-entry) changes) - (setf (aref changes 0) 0)) ;; Initialize mask to zero - (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit - (setf (aref changes (1+ number)) value)) ;; save value - ; Send change to the server - (with-buffer-request ((drawable-display drawable) +x-configurewindow+) - (drawable drawable) - (card16 (ash 1 number)) - (card29 value))))) - -(defun get-window-attributes-buffer (window) - (declare (type window window)) - (let ((state-entry nil) - (changes nil)) - (or (and *window-attributes* - (setq state-entry (assoc window (the list *window-attributes*) - :test (window-equal-function))) - (null (setq changes (state-attribute-changes state-entry))) - (state-attributes state-entry)) - (let ((display (window-display window))) - (with-display (display) - ;; When SETF's have been done, flush changes to the server - (when changes - (put-window-attribute-changes window changes) - (deallocate-gcontext-state (state-attribute-changes state-entry)) - (setf (state-attribute-changes state-entry) nil)) - ;; Get window attributes - (with-buffer-request-and-reply (display +x-getwindowattributes+ size :sizes (8)) - ((window window)) - (let ((repbuf (or (state-attributes state-entry) (allocate-context)))) - (declare (type reply-buffer repbuf)) - ;; Copy into repbuf from reply buffer - (buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size) - (when state-entry (setf (state-attributes state-entry) repbuf)) - repbuf))))))) - -;; -;; These two are twins (get-window-attributes-buffer get-drawable-geometry-buffer) -;; If you change one, you probably need to change the other... -;; -(defun get-drawable-geometry-buffer (drawable) - (declare (type drawable drawable)) - (let ((state-entry nil) - (changes nil)) - (or (and *window-attributes* - (setq state-entry (assoc drawable (the list *window-attributes*) - :test (drawable-equal-function))) - (null (setq changes (state-geometry-changes state-entry))) - (state-geometry state-entry)) - (let ((display (drawable-display drawable))) - (with-display (display) - ;; When SETF's have been done, flush changes to the server - (when changes - (put-drawable-geometry-changes drawable changes) - (deallocate-gcontext-state (state-geometry-changes state-entry)) - (setf (state-geometry-changes state-entry) nil)) - ;; Get drawable attributes - (with-buffer-request-and-reply (display +x-getgeometry+ size :sizes (8)) - ((drawable drawable)) - (let ((repbuf (or (state-geometry state-entry) (allocate-context)))) - (declare (type reply-buffer repbuf)) - ;; Copy into repbuf from reply buffer - (buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size) - (when state-entry (setf (state-geometry state-entry) repbuf)) - repbuf))))))) - -(defun put-window-attribute-changes (window changes) - ;; change window attributes - ;; Always from Called within a WITH-DISPLAY - (declare (type window window) - (type gcontext-state changes)) - (let* ((display (window-display window)) - (mask (aref changes 0))) - (declare (type display display) - (type mask32 mask)) - (with-buffer-request (display +x-changewindowattributes+) - (window window) - (card32 mask) - (progn ;; Insert a word in the request for each one bit in the mask - (do ((bits mask (ash bits -1)) - (request-size 2) ;Word count - (i 1 (index+ i 1))) ;Entry count - ((zerop bits) - (card16-put 2 (index-incf request-size)) - (index-incf (buffer-boffset display) (index* request-size 4))) - (declare (type mask32 bits) - (type array-index i request-size)) - (when (oddp bits) - (card32-put (index* (index-incf request-size) 4) (aref changes i)))))))) -;; -;; These two are twins (put-window-attribute-changes put-drawable-geometry-changes) -;; If you change one, you probably need to change the other... -;; -(defun put-drawable-geometry-changes (window changes) - ;; change window attributes or geometry (depending on request-number...) - ;; Always from Called within a WITH-DISPLAY - (declare (type window window) - (type gcontext-state changes)) - (let* ((display (window-display window)) - (mask (aref changes 0))) - (declare (type display display) - (type mask16 mask)) - (with-buffer-request (display +x-configurewindow+) - (window window) - (card16 mask) - (progn ;; Insert a word in the request for each one bit in the mask - (do ((bits mask (ash bits -1)) - (request-size 2) ;Word count - (i 1 (index+ i 1))) ;Entry count - ((zerop bits) - (card16-put 2 (incf request-size)) - (index-incf (buffer-boffset display) (* request-size 4))) - (declare (type mask16 bits) - (type fixnum request-size) - (type array-index i)) - (when (oddp bits) - (card29-put (* (incf request-size) 4) (aref changes i)))))))) - -(defmacro with-attributes ((window &rest options) &body body) - `(let ((.with-attributes-reply-buffer. (get-window-attributes-buffer ,window))) - (declare (type reply-buffer .with-attributes-reply-buffer.)) - (prog1 - (with-buffer-input (.with-attributes-reply-buffer. ,@options) ,@body) - (unless *window-attributes* - (deallocate-context .with-attributes-reply-buffer.))))) -;; -;; These two are twins (with-attributes with-geometry) -;; If you change one, you probably need to change the other... -;; -(defmacro with-geometry ((window &rest options) &body body) - `(let ((.with-geometry-reply-buffer. (get-drawable-geometry-buffer ,window))) - (declare (type reply-buffer .with-geometry-reply-buffer.)) - (prog1 - (with-buffer-input (.with-geometry-reply-buffer. ,@options) ,@body) - (unless *window-attributes* - (deallocate-context .with-geometry-reply-buffer.))))) - -;;;----------------------------------------------------------------------------- -;;; Group A: (for GetWindowAttributes) -;;;----------------------------------------------------------------------------- - -(defun window-visual (window) - (declare (type window window)) - (declare (clx-values resource-id)) - (with-attributes (window :sizes 32) - (resource-id-get 8))) - -(defun window-visual-info (window) - (declare (type window window)) - (declare (clx-values visual-info)) - (with-attributes (window :sizes 32) - (visual-info (window-display window) (resource-id-get 8)))) - -(defun window-class (window) - (declare (type window window)) - (declare (clx-values (member :input-output :input-only))) - (with-attributes (window :sizes 16) - (member16-get 12 :copy :input-output :input-only))) - -(defun set-window-background (window background) - (declare (type window window) - (type (or (member :none :parent-relative) pixel pixmap) background)) - (cond ((eq background :none) (change-window-attribute window 0 0)) - ((eq background :parent-relative) (change-window-attribute window 0 1)) - ((integerp background) ;; Background pixel - (change-window-attribute window 0 0) ;; pixmap :NONE - (change-window-attribute window 1 background)) - ((type? background 'pixmap) ;; Background pixmap - (change-window-attribute window 0 (pixmap-id background))) - (t (x-type-error background '(or (member :none :parent-relative) integer pixmap)))) - background) - -(defsetf window-background set-window-background) - -(defun set-window-border (window border) - (declare (type window window) - (type (or (member :copy) pixel pixmap) border)) - (cond ((eq border :copy) (change-window-attribute window 2 0)) - ((type? border 'pixmap) ;; Border pixmap - (change-window-attribute window 2 (pixmap-id border))) - ((integerp border) ;; Border pixel - (change-window-attribute window 3 border)) - (t (x-type-error border '(or (member :copy) integer pixmap)))) - border) - -(defsetf window-border set-window-border) - -(defun window-bit-gravity (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values bit-gravity)) - (with-attributes (window :sizes 8) - (member8-vector-get 14 *bit-gravity-vector*))) - -(defun set-window-bit-gravity (window gravity) - (change-window-attribute - window 4 (encode-type (member-vector *bit-gravity-vector*) gravity)) - gravity) - -(defsetf window-bit-gravity set-window-bit-gravity) - -(defun window-gravity (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values win-gravity)) - (with-attributes (window :sizes 8) - (member8-vector-get 15 *win-gravity-vector*))) - -(defun set-window-gravity (window gravity) - (change-window-attribute - window 5 (encode-type (member-vector *win-gravity-vector*) gravity)) - gravity) - -(defsetf window-gravity set-window-gravity) - -(defun window-backing-store (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values (member :not-useful :when-mapped :always))) - (with-attributes (window :sizes 8) - (member8-get 1 :not-useful :when-mapped :always))) - -(defun set-window-backing-store (window when) - (change-window-attribute - window 6 (encode-type (member :not-useful :when-mapped :always) when)) - when) - -(defsetf window-backing-store set-window-backing-store) - -(defun window-backing-planes (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values pixel)) - (with-attributes (window :sizes 32) - (card32-get 16))) - -(defun set-window-backing-planes (window planes) - (change-window-attribute window 7 (encode-type card32 planes)) - planes) - -(defsetf window-backing-planes set-window-backing-planes) - -(defun window-backing-pixel (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values pixel)) - (with-attributes (window :sizes 32) - (card32-get 20))) - -(defun set-window-backing-pixel (window pixel) - (change-window-attribute window 8 (encode-type card32 pixel)) - pixel) - -(defsetf window-backing-pixel set-window-backing-pixel) - -(defun window-save-under (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values (member :off :on))) - (with-attributes (window :sizes 8) - (member8-get 24 :off :on))) - -(defun set-window-save-under (window when) - (change-window-attribute window 10 (encode-type (member :off :on) when)) - when) - -(defsetf window-save-under set-window-save-under) - -(defun window-override-redirect (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values (member :off :on))) - (with-attributes (window :sizes 8) - (member8-get 27 :off :on))) - -(defun set-window-override-redirect (window when) - (change-window-attribute window 9 (encode-type (member :off :on) when)) - when) - -(defsetf window-override-redirect set-window-override-redirect) - -(defun window-event-mask (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values mask32)) - (with-attributes (window :sizes 32) - (card32-get 36))) - -(defsetf window-event-mask (window) (event-mask) - (let ((em (gensym))) - `(let ((,em ,event-mask)) - (declare (type event-mask ,em)) - (change-window-attribute ,window 11 (encode-event-mask ,em)) - ,em))) - -(defun window-do-not-propagate-mask (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values mask32)) - (with-attributes (window :sizes 32) - (card32-get 40))) - -(defsetf window-do-not-propagate-mask (window) (device-event-mask) - (let ((em (gensym))) - `(let ((,em ,device-event-mask)) - (declare (type device-event-mask ,em)) - (change-window-attribute ,window 12 (encode-device-event-mask ,em)) - ,em))) - -(defun window-colormap (window) - (declare (type window window)) - (declare (clx-values (or null colormap))) - (with-attributes (window :sizes 32) - (let ((id (resource-id-get 28))) - (if (zerop id) nil - (lookup-colormap (window-display window) id))))) - -(defun set-window-colormap (window colormap) - (change-window-attribute - window 13 (encode-type (or (member :copy) colormap) colormap)) - colormap) - -(defsetf window-colormap set-window-colormap) - -(defun window-cursor (window) - (declare (type window window)) - (declare (clx-values cursor)) - window - (error "~S can only be set" 'window-cursor)) - -(defun set-window-cursor (window cursor) - (change-window-attribute - window 14 (encode-type (or (member :none) cursor) cursor)) - cursor) - -(defsetf window-cursor set-window-cursor) - -(defun window-colormap-installed-p (window) - (declare (type window window)) - (declare (clx-values generalized-boolean)) - (with-attributes (window :sizes 8) - (boolean-get 25))) - -(defun window-all-event-masks (window) - (declare (type window window)) - (declare (clx-values mask32)) - (with-attributes (window :sizes 32) - (card32-get 32))) - -(defun window-map-state (window) - (declare (type window window)) - (declare (clx-values (member :unmapped :unviewable :viewable))) - (with-attributes (window :sizes 8) - (member8-get 26 :unmapped :unviewable :viewable))) - - -;;;----------------------------------------------------------------------------- -;;; Group G: (for GetGeometry) -;;;----------------------------------------------------------------------------- - -(defun drawable-root (drawable) - (declare (type drawable drawable)) - (declare (clx-values window)) - (with-geometry (drawable :sizes 32) - (window-get 8 (drawable-display drawable)))) - -(defun drawable-x (drawable) - ;; setf'able - (declare (type drawable drawable)) - (declare (clx-values int16)) - (with-geometry (drawable :sizes 16) - (int16-get 12))) - -(defun set-drawable-x (drawable x) - (change-drawable-geometry drawable 0 (encode-type int16 x)) - x) - -(defsetf drawable-x set-drawable-x) - -(defun drawable-y (drawable) - ;; setf'able - (declare (type drawable drawable)) - (declare (clx-values int16)) - (with-geometry (drawable :sizes 16) - (int16-get 14))) - -(defun set-drawable-y (drawable y) - (change-drawable-geometry drawable 1 (encode-type int16 y)) - y) - -(defsetf drawable-y set-drawable-y) - -(defun drawable-width (drawable) - ;; setf'able - ;; Inside width, excluding border. - (declare (type drawable drawable)) - (declare (clx-values card16)) - (with-geometry (drawable :sizes 16) - (card16-get 16))) - -(defun set-drawable-width (drawable width) - (change-drawable-geometry drawable 2 (encode-type card16 width)) - width) - -(defsetf drawable-width set-drawable-width) - -(defun drawable-height (drawable) - ;; setf'able - ;; Inside height, excluding border. - (declare (type drawable drawable)) - (declare (clx-values card16)) - (with-geometry (drawable :sizes 16) - (card16-get 18))) - -(defun set-drawable-height (drawable height) - (change-drawable-geometry drawable 3 (encode-type card16 height)) - height) - -(defsetf drawable-height set-drawable-height) - -(defun drawable-depth (drawable) - (declare (type drawable drawable)) - (declare (clx-values card8)) - (with-geometry (drawable :sizes 8) - (card8-get 1))) - -(defun drawable-border-width (drawable) - ;; setf'able - (declare (type drawable drawable)) - (declare (clx-values integer)) - (with-geometry (drawable :sizes 16) - (card16-get 20))) - -(defun set-drawable-border-width (drawable width) - (change-drawable-geometry drawable 4 (encode-type card16 width)) - width) - -(defsetf drawable-border-width set-drawable-border-width) - -(defun set-window-priority (mode window sibling) - (declare (type (member :above :below :top-if :bottom-if :opposite) mode) - (type window window) - (type (or null window) sibling)) - (with-state (window) - (change-drawable-geometry - window 6 (encode-type (member :above :below :top-if :bottom-if :opposite) mode)) - (when sibling - (change-drawable-geometry window 5 (encode-type window sibling)))) - mode) - -(defsetf window-priority (window &optional sibling) (mode) - ;; A bit strange, but retains setf form. - `(set-window-priority ,mode ,window ,sibling)) diff --git a/src/eclx/buffer.lisp b/src/eclx/buffer.lisp deleted file mode 100644 index 01a414045..000000000 --- a/src/eclx/buffer.lisp +++ /dev/null @@ -1,1551 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; This file contains definitions for the BUFFER object for Common-Lisp X -;;; windows version 11 - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; -#+cmu -(ext:file-comment - "$Header$") - -;; A few notes: -;; -;; 1. The BUFFER implements a two-way buffered byte / half-word -;; / word stream. Hooks are left for implementing this with a -;; shared memory buffer, or with effenciency hooks to the network -;; code. -;; -;; 2. The BUFFER object uses overlapping displaced arrays for -;; inserting and removing bytes half-words and words. -;; -;; 3. The BYTE component of these arrays is written to a STREAM -;; associated with the BUFFER. The stream has its own buffer. -;; This may be made more efficient by using the Zetalisp -;; :Send-Output-Buffer operation. -;; -;; 4. The BUFFER object is INCLUDED in the DISPLAY object. -;; This was done to reduce access time when sending requests, -;; while maintaing some code modularity. -;; Several buffer functions are duplicated (with-buffer, -;; buffer-force-output, close-buffer) to keep the naming -;; conventions consistent. -;; -;; 5. A nother layer of software is built on top of this for generating -;; both client and server interface routines, given a specification -;; of the protocol. (see the INTERFACE file) -;; -;; 6. Care is taken to leave the buffer pointer (buffer-bbuf) set to -;; a point after a complete request. This is to ensure that a partial -;; request won't be left after aborts (e.g. control-abort on a lispm). - -(in-package :xlib) - -(defconstant +requestsize+ 160) ;; Max request size (excluding variable length requests) - -;;; This is here instead of in bufmac so that with-display can be -;;; compiled without macros and bufmac being loaded. - -(defmacro with-buffer ((buffer &key timeout inline) - &body body &environment env) - ;; This macro is for use in a multi-process environment. It provides - ;; exclusive access to the local buffer object for request generation and - ;; reply processing. - `(macrolet ((with-buffer ((buffer &key timeout) &body body) - ;; Speedup hack for lexically nested with-buffers - `(progn - (progn ,buffer ,@(and timeout `(,timeout)) nil) - ,@body))) - ,(if (and (null inline) (macroexpand '(use-closures) env)) - `(flet ((.with-buffer-body. () ,@body)) - (declare (dynamic-extent #'.with-buffer-body.)) - (with-buffer-function ,buffer ,timeout #'.with-buffer-body.)) - (let ((buf (if (or (symbolp buffer) (constantp buffer)) - buffer - '.buffer.))) - `(let (,@(unless (eq buf buffer) `((,buf ,buffer)))) - ,@(unless (eq buf buffer) `((declare (type buffer ,buf)))) - ,(declare-bufmac) - (when (buffer-dead ,buf) - (x-error 'closed-display :display ,buf)) - (holding-lock ((buffer-lock ,buf) ,buf "CLX Display Lock" - ,@(and timeout `(:timeout ,timeout))) - ,@body)))))) - -(defun with-buffer-function (buffer timeout function) - (declare (type display buffer) - (type (or null number) timeout) - (type function function) - (dynamic-extent function)) - (with-buffer (buffer :timeout timeout :inline t) - (funcall function))) - -;;; The following are here instead of in bufmac so that event-case can -;;; be compiled without macros and bufmac being loaded. - -(defmacro read-card8 (byte-index) - `(aref-card8 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro read-int8 (byte-index) - `(aref-int8 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro read-card16 (byte-index) - `(aref-card16 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro read-int16 (byte-index) - `(aref-int16 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro read-card32 (byte-index) - `(aref-card32 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro read-int32 (byte-index) - `(aref-int32 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro read-card29 (byte-index) - `(aref-card29 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro event-code (reply-buffer) - ;; The reply-buffer structure is used for events. - ;; The size slot is used for the event code. - `(reply-size ,reply-buffer)) - -(defmacro reading-event ((event &rest options) &body body) - (declare (arglist (buffer &key sizes) &body body)) - ;; BODY may contain calls to (READ32 &optional index) etc. - ;; These calls will read from the input buffer at byte - ;; offset INDEX. If INDEX is not supplied, then the next - ;; word, half-word or byte is returned. - `(with-buffer-input (,event ,@options) ,@body)) - -(defmacro with-buffer-input ((reply-buffer &key display (sizes '(8 16 32)) index) - &body body) - (unless (listp sizes) (setq sizes (list sizes))) - ;; 160 is a special hack for client-message-events - (when (set-difference sizes '(0 8 16 32 160 256)) - (error "Illegal sizes in ~a" sizes)) - `(let ((%reply-buffer ,reply-buffer) - ,@(and display `((%buffer ,display)))) - (declare (type reply-buffer %reply-buffer) - ,@(and display '((type display %buffer)))) - ,(declare-bufmac) - ,@(and display '(%buffer)) - (let* ((buffer-boffset (the array-index ,(or index 0))) - (buffer-bbuf (reply-ibuf8 %reply-buffer))) - (declare (type array-index buffer-boffset) - (type buffer-bytes buffer-bbuf) - (ignorable buffer-boffset buffer-bbuf)) - ,@body))) - -(defun make-buffer (output-size constructor &rest options) - (declare (dynamic-extent options)) - ;; Output-Size is the output-buffer size in bytes. - (let ((byte-output (make-array output-size :element-type 'card8 - :initial-element 0))) - (apply constructor - :size output-size - :obuf8 byte-output - options))) - -(defun make-reply-buffer (size) - ;; Size is the buffer size in bytes - (let ((byte-input (make-array size :element-type 'card8 - :initial-element 0))) - (make-reply-buffer-internal - :size size - :ibuf8 byte-input))) - -(defun buffer-ensure-size (buffer size) - (declare (type buffer buffer) - (type array-index size)) - (when (index> size (buffer-size buffer)) - (with-buffer (buffer) - (buffer-flush buffer) - (let* ((new-buffer-size (index-ash 1 (integer-length (index1- size)))) - (new-buffer (make-array new-buffer-size :element-type 'card8 - :initial-element 0))) - (setf (buffer-obuf8 buffer) new-buffer))))) - -(defun buffer-pad-request (buffer pad) - (declare (type buffer buffer) - (type array-index pad)) - (unless (index-zerop pad) - (when (index> (index+ (buffer-boffset buffer) pad) - (buffer-size buffer)) - (buffer-flush buffer)) - (incf (buffer-boffset buffer) pad) - (unless (index-zerop (index-mod (buffer-boffset buffer) 4)) - (buffer-flush buffer)))) - -(declaim (inline buffer-new-request-number)) - -(defun buffer-new-request-number (buffer) - (declare (type buffer buffer)) - (setf (buffer-request-number buffer) - (ldb (byte 16 0) (1+ (buffer-request-number buffer))))) - -(defun with-buffer-request-function (display gc-force request-function) - (declare (type display display) - (type (or null gcontext) gc-force)) - (declare (type function request-function) - (dynamic-extent request-function)) - (with-buffer (display :inline t) - (multiple-value-prog1 - (progn - (when gc-force (force-gcontext-changes-internal gc-force)) - (without-aborts (funcall request-function display))) - (display-invoke-after-function display)))) - -(defun with-buffer-request-function-nolock (display gc-force request-function) - (declare (type display display) - (type (or null gcontext) gc-force)) - (declare (type function request-function) - (dynamic-extent request-function)) - (multiple-value-prog1 - (progn - (when gc-force (force-gcontext-changes-internal gc-force)) - (without-aborts (funcall request-function display))) - (display-invoke-after-function display))) - -(defstruct (pending-command (:copier nil) (:predicate nil)) - (sequence 0 :type card16) - (reply-buffer nil :type (or null reply-buffer)) - (process nil) - (next nil :type (or null pending-command))) - -(defun with-buffer-request-and-reply-function - (display multiple-reply request-function reply-function) - (declare (type display display) - (type generalized-boolean multiple-reply)) - (declare (type function request-function reply-function) - (dynamic-extent request-function reply-function)) - (let ((pending-command nil) - (reply-buffer nil)) - (declare (type (or null pending-command) pending-command) - (type (or null reply-buffer) reply-buffer)) - (unwind-protect - (progn - (with-buffer (display :inline t) - (setq pending-command (start-pending-command display)) - (without-aborts (funcall request-function display)) - (buffer-force-output display) - (display-invoke-after-function display)) - (cond (multiple-reply - (loop - (setq reply-buffer (read-reply display pending-command)) - (when (funcall reply-function display reply-buffer) (return nil)) - (deallocate-reply-buffer (shiftf reply-buffer nil)))) - (t - (setq reply-buffer (read-reply display pending-command)) - (funcall reply-function display reply-buffer)))) - (when reply-buffer (deallocate-reply-buffer reply-buffer)) - (when pending-command (stop-pending-command display pending-command))))) - -;; -;; Buffer stream operations -;; - -(defun buffer-write (vector buffer start end) - ;; Write out VECTOR from START to END into BUFFER - ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER - (declare (type buffer buffer) - (type array-index start end)) - (when (buffer-dead buffer) - (x-error 'closed-display :display buffer)) - (wrap-buf-output (buffer) - (funcall (buffer-write-function buffer) vector buffer start end)) - nil) - -(defun buffer-flush (buffer) - ;; Write the buffer contents to the server stream - doesn't force-output the stream - ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER - (declare (type buffer buffer)) - (unless (buffer-flush-inhibit buffer) - (let ((boffset (buffer-boffset buffer))) - (declare (type array-index boffset)) - (when (index-plusp boffset) - (buffer-write (buffer-obuf8 buffer) buffer 0 boffset) - (setf (buffer-boffset buffer) 0) - (setf (buffer-last-request buffer) nil)))) - nil) - -(defmacro with-buffer-flush-inhibited ((buffer) &body body) - (let ((buf (if (or (symbolp buffer) (constantp buffer)) buffer '.buffer.))) - `(let* (,@(and (not (eq buf buffer)) `((,buf ,buffer))) - (.saved-buffer-flush-inhibit. (buffer-flush-inhibit ,buf))) - (unwind-protect - (progn - (setf (buffer-flush-inhibit ,buf) t) - ,@body) - (setf (buffer-flush-inhibit ,buf) .saved-buffer-flush-inhibit.))))) - -(defun buffer-force-output (buffer) - ;; Output is normally buffered, this forces any buffered output to the server. - (declare (type buffer buffer)) - (when (buffer-dead buffer) - (x-error 'closed-display :display buffer)) - (buffer-flush buffer) - (wrap-buf-output (buffer) - (without-aborts - (funcall (buffer-force-output-function buffer) buffer))) - nil) - -(defun close-buffer (buffer &key abort) - ;; Close the host connection in BUFFER - (declare (type buffer buffer)) - (unless (null (buffer-output-stream buffer)) - (wrap-buf-output (buffer) - (funcall (buffer-close-function buffer) buffer :abort abort)) - (setf (buffer-dead buffer) t) - ;; Zap pointers to the streams, to ensure they're GC'd - (setf (buffer-output-stream buffer) nil) - (setf (buffer-input-stream buffer) nil) - ) - nil) - -(defun buffer-input (buffer vector start end &optional timeout) - ;; Read into VECTOR from the buffer stream - ;; Timeout, when non-nil, is in seconds - ;; Returns non-nil if EOF encountered - ;; Returns :TIMEOUT when timeout exceeded - (declare (type buffer buffer) - (type vector vector) - (type array-index start end) - (type (or null number) timeout)) - (declare (clx-values eof-p)) - (when (buffer-dead buffer) - (x-error 'closed-display :display buffer)) - (unless (= start end) - (let ((result - (wrap-buf-input (buffer) - (funcall (buffer-input-function buffer) - buffer vector start end timeout)))) - (unless (or (null result) (eq result :timeout)) - (close-buffer buffer)) - result))) - -(defun buffer-input-wait (buffer timeout) - ;; Timeout, when non-nil, is in seconds - ;; Returns non-nil if EOF encountered - ;; Returns :TIMEOUT when timeout exceeded - (declare (type buffer buffer) - (type (or null number) timeout)) - (declare (clx-values timeout)) - (when (buffer-dead buffer) - (x-error 'closed-display :display buffer)) - (let ((result - (wrap-buf-input (buffer) - (funcall (buffer-input-wait-function buffer) - buffer timeout)))) - (unless (or (null result) (eq result :timeout)) - (close-buffer buffer)) - result)) - -(defun buffer-listen (buffer) - ;; Returns T if there is input available for the buffer. This should never - ;; block, so it can be called from the scheduler. - (declare (type buffer buffer)) - (declare (clx-values input-available)) - (or (not (null (buffer-dead buffer))) - (wrap-buf-input (buffer) - (funcall (buffer-listen-function buffer) buffer)))) - -;;; Reading sequences of strings - -;;; a list of pascal-strings with card8 lengths, no padding in between -;;; can't use read-sequence-char -(defun read-sequence-string (buffer-bbuf length nitems result-type - &optional (buffer-boffset 0)) - (declare (type buffer-bytes buffer-bbuf) - (type array-index length nitems buffer-boffset)) - length - (with-vector (buffer-bbuf buffer-bytes) - (let ((result (make-sequence result-type nitems))) - (do* ((index 0 (index+ index 1 string-length)) - (count 0 (index1+ count)) - (string-length 0) - (string "")) - ((index>= count nitems) - result) - (declare (type array-index index count string-length) - (type string string)) - (setq string-length (read-card8 index) - string (make-sequence 'string string-length)) - (do ((i (index1+ index) (index1+ i)) - (j 0 (index1+ j))) - ((index>= j string-length) - (setf (elt result count) string)) - (declare (type array-index i j)) - (setf (aref string j) (card8->char (read-card8 i)))))))) - -;;; Reading sequences of chars - -(defun read-sequence-char (reply-buffer result-type nitems &optional transform data - (start 0) (index 0)) - (declare (type reply-buffer reply-buffer) - (type t result-type) ;; CL type - (type array-index nitems start index) - (type (or null sequence) data)) - (declare (type (or null (function (character) t)) transform) - (dynamic-extent transform)) - (if transform - (flet ((card8->char->transform (v) - (declare (type card8 v)) - (funcall transform (card8->char v)))) - (declare (dynamic-extent #'card8->char->transform)) - (read-sequence-card8 - reply-buffer result-type nitems #'card8->char->transform - data start index)) - (read-sequence-card8 - reply-buffer result-type nitems #'card8->char - data start index))) - -;;; Reading sequences of card8's - -(defun read-list-card8 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type list data)) - (with-buffer-input (reply-buffer :sizes (8) :index index) - (do* ((j nitems (index- j 1)) - (lst (nthcdr start data) (cdr lst)) - (index 0 (index+ index 1))) - ((index-zerop j)) - (declare (type array-index j index) - (list lst)) - (setf (car lst) (read-card8 index))))) - -(defun read-list-card8-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type list data)) - (declare (type (function (card8) t) transform) - (dynamic-extent transform)) - (with-buffer-input (reply-buffer :sizes (8) :index index) - (do* ((j nitems (index- j 1)) - (lst (nthcdr start data) (cdr lst)) - (index 0 (index+ index 1))) - ((index-zerop j)) - (declare (type array-index j index) - (list lst)) - (setf (car lst) (funcall transform (read-card8 index)))))) - -(defun read-simple-array-card8 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card8 (*)) data)) - (with-vector (data (simple-array card8 (*))) - (with-buffer-input (reply-buffer :sizes (8)) - (buffer-replace data buffer-bbuf start (index+ start nitems) index)))) - -(defun read-simple-array-card8-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card8 (*)) data)) - (declare (type (function (card8) card8) transform) - (dynamic-extent transform)) - (with-vector (data (simple-array card8 (*))) - (with-buffer-input (reply-buffer :sizes (8) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 1))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card8 (funcall transform (read-card8 index)))))))) - -(defun read-vector-card8 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data) - (optimize #+cmu(ext:inhibit-warnings 3))) - (with-vector (data vector) - (with-buffer-input (reply-buffer :sizes (8) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 1))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (read-card8 index)))))) - -(defun read-vector-card8-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data) - (optimize #+cmu(ext:inhibit-warnings 3))) - (declare (type (function (card8) t) transform) - (dynamic-extent transform)) - (with-vector (data vector) - (with-buffer-input (reply-buffer :sizes (8) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 1))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (funcall transform (read-card8 index))))))) - -(defun read-sequence-card8 (reply-buffer result-type nitems &optional transform data - (start 0) (index 0)) - (declare (type reply-buffer reply-buffer) - (type t result-type) ;; CL type - (type array-index nitems start index) - (type (or null sequence) data)) - (declare (type (or null (function (card8) t)) transform) - (dynamic-extent transform)) - (let ((result (or data (make-sequence result-type nitems)))) - (typecase result - (list - (if transform - (read-list-card8-with-transform - reply-buffer nitems result transform start index) - (read-list-card8 reply-buffer nitems result start index))) - ((simple-array card8 (*)) - (if transform - (read-simple-array-card8-with-transform - reply-buffer nitems result transform start index) - (read-simple-array-card8 reply-buffer nitems result start index))) - (t - (if transform - (read-vector-card8-with-transform - reply-buffer nitems result transform start index) - (read-vector-card8 reply-buffer nitems result start index)))) - result)) - -;;; For now, perhaps performance it isn't worth doing better? - -(defun read-sequence-int8 (reply-buffer result-type nitems &optional transform data - (start 0) (index 0)) - (declare (type reply-buffer reply-buffer) - (type t result-type) ;; CL type - (type array-index nitems start index) - (type (or null sequence) data)) - (declare (type (or null (function (int8) t)) transform) - (dynamic-extent transform)) - (if transform - (flet ((card8->int8->transform (v) - (declare (type card8 v)) - (funcall transform (card8->int8 v)))) - (declare (dynamic-extent #'card8->int8->transform)) - (read-sequence-card8 - reply-buffer result-type nitems #'card8->int8->transform - data start index)) - (read-sequence-card8 - reply-buffer result-type nitems #'card8->int8 - data start index))) - -;;; Reading sequences of card16's - -(defun read-list-card16 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type list data)) - (with-buffer-input (reply-buffer :sizes (16) :index index) - (do* ((j nitems (index- j 1)) - (lst (nthcdr start data) (cdr lst)) - (index 0 (index+ index 2))) - ((index-zerop j)) - (declare (type array-index j index) - (list lst)) - (setf (car lst) (read-card16 index))))) - -(defun read-list-card16-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type list data)) - (declare (type (function (card16) t) transform) - (dynamic-extent transform)) - (with-buffer-input (reply-buffer :sizes (16) :index index) - (do* ((j nitems (index- j 1)) - (lst (nthcdr start data) (cdr lst)) - (index 0 (index+ index 2))) - ((index-zerop j)) - (declare (type array-index j index) - (list lst)) - (setf (car lst) (funcall transform (read-card16 index)))))) - - -(defun read-simple-array-card16 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card16 (*)) data)) - (with-vector (data (simple-array card16 (*))) - (with-buffer-input (reply-buffer :sizes (16) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 2))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card16 (read-card16 index))))))) - -(defun read-simple-array-card16-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card16 (*)) data)) - (declare (type (function (card16) card16) transform) - (dynamic-extent transform)) - (with-vector (data (simple-array card16 (*))) - (with-buffer-input (reply-buffer :sizes (16) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 2))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card16 (funcall transform (read-card16 index)))))))) - -(defun read-vector-card16 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data) - (optimize #+cmu(ext:inhibit-warnings 3))) - (with-vector (data vector) - (with-buffer-input (reply-buffer :sizes (16) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 2))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (read-card16 index)))))) - -(defun read-vector-card16-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data) - (optimize #+cmu(ext:inhibit-warnings 3))) - (declare (type (function (card16) t) transform) - (dynamic-extent transform)) - (with-vector (data vector) - (with-buffer-input (reply-buffer :sizes (16) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 2))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (funcall transform (read-card16 index))))))) - -(defun read-sequence-card16 (reply-buffer result-type nitems &optional transform data - (start 0) (index 0)) - (declare (type reply-buffer reply-buffer) - (type t result-type) ;; CL type - (type array-index nitems start index) - (type (or null sequence) data)) - (declare (type (or null (function (card16) t)) transform) - (dynamic-extent transform)) - (let ((result (or data (make-sequence result-type nitems)))) - (typecase result - (list - (if transform - (read-list-card16-with-transform reply-buffer nitems result transform start index) - (read-list-card16 reply-buffer nitems result start index))) - ((simple-array card16 (*)) - (if transform - (read-simple-array-card16-with-transform - reply-buffer nitems result transform start index) - (read-simple-array-card16 reply-buffer nitems result start index))) - (t - (if transform - (read-vector-card16-with-transform - reply-buffer nitems result transform start index) - (read-vector-card16 reply-buffer nitems result start index)))) - result)) - -;;; For now, perhaps performance it isn't worth doing better? - -(defun read-sequence-int16 (reply-buffer result-type nitems &optional transform data - (start 0) (index 0)) - (declare (type reply-buffer reply-buffer) - (type t result-type) ;; CL type - (type array-index nitems start index) - (type (or null sequence) data)) - (declare (type (or null (function (int16) t)) transform) - (dynamic-extent transform)) - (if transform - (flet ((card16->int16->transform (v) - (declare (type card16 v)) - (funcall transform (card16->int16 v)))) - (declare (dynamic-extent #'card16->int16->transform)) - (read-sequence-card16 - reply-buffer result-type nitems #'card16->int16->transform - data start index)) - (read-sequence-card16 - reply-buffer result-type nitems #'card16->int16 - data start index))) - -;;; Reading sequences of card32's - -(defun read-list-card32 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type list data)) - (with-buffer-input (reply-buffer :sizes (32) :index index) - (do* ((j nitems (index- j 1)) - (lst (nthcdr start data) (cdr lst)) - (index 0 (index+ index 4))) - ((index-zerop j)) - (declare (type array-index j index) - (list lst)) - (setf (car lst) (read-card32 index))))) - -(defun read-list-card32-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type list data)) - (declare (type (function (card32) t) transform) - (dynamic-extent transform)) - (with-buffer-input (reply-buffer :sizes (32) :index index) - (do* ((j nitems (index- j 1)) - (lst (nthcdr start data) (cdr lst)) - (index 0 (index+ index 4))) - ((index-zerop j)) - (declare (type array-index j index) - (list lst)) - (setf (car lst) (funcall transform (read-card32 index)))))) - -(defun read-simple-array-card32 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card32 (*)) data)) - (with-vector (data (simple-array card32 (*))) - (with-buffer-input (reply-buffer :sizes (32) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 4))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card32 (read-card32 index))))))) - -(defun read-simple-array-card32-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card32 (*)) data)) - (declare (type (function (card32) card32) transform) - (dynamic-extent transform)) - (with-vector (data (simple-array card32 (*))) - (with-buffer-input (reply-buffer :sizes (32) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 4))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card32 (funcall transform (read-card32 index)))))))) - -(defun read-vector-card32 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data) - (optimize #+cmu(ext:inhibit-warnings 3))) - (with-vector (data vector) - (with-buffer-input (reply-buffer :sizes (32) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 4))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (read-card32 index)))))) - -(defun read-vector-card32-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data) - (optimize #+cmu(ext:inhibit-warnings 3))) - (declare (type (function (card32) t) transform) - (dynamic-extent transform)) - (with-vector (data vector) - (with-buffer-input (reply-buffer :sizes (32) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 4))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (funcall transform (read-card32 index))))))) - -(defun read-sequence-card32 (reply-buffer result-type nitems &optional transform data - (start 0) (index 0)) - (declare (type reply-buffer reply-buffer) - (type t result-type) ;; CL type - (type array-index nitems start index) - (type (or null sequence) data)) - (declare (type (or null (function (card32) t)) transform) - (dynamic-extent transform)) - (let ((result (or data (make-sequence result-type nitems)))) - (typecase result - (list - (if transform - (read-list-card32-with-transform reply-buffer nitems result transform start index) - (read-list-card32 reply-buffer nitems result start index))) - ((simple-array card32 (*)) - (if transform - (read-simple-array-card32-with-transform - reply-buffer nitems result transform start index) - (read-simple-array-card32 reply-buffer nitems result start index))) - (t - (if transform - (read-vector-card32-with-transform - reply-buffer nitems result transform start index) - (read-vector-card32 reply-buffer nitems result start index)))) - result)) - -;;; For now, perhaps performance it isn't worth doing better? - -(defun read-sequence-int32 (reply-buffer result-type nitems &optional transform data - (start 0) (index 0)) - (declare (type reply-buffer reply-buffer) - (type t result-type) ;; CL type - (type array-index nitems start index) - (type (or null sequence) data)) - (declare (type (or null (function (int32) t)) transform) - (dynamic-extent transform)) - (if transform - (flet ((card32->int32->transform (v) - (declare (type card32 v)) - (funcall transform (card32->int32 v)))) - (declare (dynamic-extent #'card32->int32->transform)) - (read-sequence-card32 - reply-buffer result-type nitems #'card32->int32->transform - data start index)) - (read-sequence-card32 - reply-buffer result-type nitems #'card32->int32 - data start index))) - -;;; Writing sequences of chars - -(defun write-sequence-char - (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare (type buffer buffer) - (type sequence data) - (type array-index boffset start end)) - (declare (type (or null (function (t) character)) transform) - (dynamic-extent transform)) - (if transform - (flet ((transform->char->card8 (x) - (char->card8 (the character (funcall transform x))))) - (declare (dynamic-extent #'transform->char->card8)) - (write-sequence-card8 - buffer boffset data start end #'transform->char->card8)) - (write-sequence-card8 buffer boffset data start end #'char->card8))) - -;;; Writing sequences of card8's - -(defun write-list-card8 (buffer boffset data start end) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (writing-buffer-chunks card8 - ((lst (nthcdr start data))) - ((type list lst)) - (dotimes (j chunk) - (declare (type array-index j)) - (write-card8 j (pop lst)) - )) - nil) - -(defun write-list-card8-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (declare (type (function (t) card8) transform) - (dynamic-extent transform)) - (writing-buffer-chunks card8 - ((lst (nthcdr start data))) - ((type list lst)) - (dotimes (j chunk) - (declare (type array-index j)) - (write-card8 j (funcall transform (pop lst))))) - nil) - -;;; Should really write directly from data, instead of into the buffer first -(defun write-simple-array-card8 (buffer boffset data start end) - (declare (type buffer buffer) - (type (simple-array card8 (*)) data) - (type array-index boffset start end)) - (with-vector (data (simple-array card8 (*))) - (writing-buffer-chunks card8 - ((index start (index+ index chunk))) - ((type array-index index)) - (buffer-replace buffer-bbuf data - buffer-boffset - (index+ buffer-boffset chunk) - index))) - nil) - -(defun write-simple-array-card8-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type (simple-array card8 (*)) data) - (type array-index boffset start end)) - (declare (type (function (card8) card8) transform) - (dynamic-extent transform)) - (with-vector (data (simple-array card8 (*))) - (writing-buffer-chunks card8 - ((index start)) - ((type array-index index)) - (dotimes (j chunk) - (declare (type array-index j)) - (write-card8 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-card8 (buffer boffset data start end) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (with-vector (data vector) - (writing-buffer-chunks card8 - ((index start)) - ((type array-index index)) - (dotimes (j chunk) - (declare (type array-index j)) - (write-card8 j (aref data index)) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-card8-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end)) - (declare (type (function (t) card8) transform) - (dynamic-extent transform)) - (with-vector (data vector) - (writing-buffer-chunks card8 - ((index start)) - ((type array-index index)) - (dotimes (j chunk) - (declare (type array-index j)) - (write-card8 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-sequence-card8 - (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare (type buffer buffer) - (type sequence data) - (type array-index boffset start end)) - (declare (type (or null (function (t) card8)) transform) - (dynamic-extent transform)) - (typecase data - (list - (if transform - (write-list-card8-with-transform buffer boffset data start end transform) - (write-list-card8 buffer boffset data start end))) - ((simple-array card8 (*)) - (if transform - (write-simple-array-card8-with-transform buffer boffset data start end transform) - (write-simple-array-card8 buffer boffset data start end))) - (t - (if transform - (write-vector-card8-with-transform buffer boffset data start end transform) - (write-vector-card8 buffer boffset data start end))))) - -;;; For now, perhaps performance it isn't worth doing better? - -(defun write-sequence-int8 - (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare (type buffer buffer) - (type sequence data) - (type array-index boffset start end)) - (declare (type (or null (function (t) int8)) transform) - (dynamic-extent transform)) - (if transform - (flet ((transform->int8->card8 (x) - (int8->card8 (the int8 (funcall transform x))))) - (declare (dynamic-extent #'transform->int8->card8)) - (write-sequence-card8 - buffer boffset data start end #'transform->int8->card8)) - (write-sequence-card8 buffer boffset data start end #'int8->card8))) - -;;; Writing sequences of card16's - -(defun write-list-card16 (buffer boffset data start end) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (writing-buffer-chunks card16 - ((lst (nthcdr start data))) - ((type list lst)) - ;; Depends upon the chunks being an even multiple of card16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (pop lst)))) - nil) - -(defun write-list-card16-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (declare (type (function (t) card16) transform) - (dynamic-extent transform)) - (writing-buffer-chunks card16 - ((lst (nthcdr start data))) - ((type list lst)) - ;; Depends upon the chunks being an even multiple of card16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (funcall transform (pop lst))))) - nil) - -(defun write-simple-array-card16 (buffer boffset data start end) - (declare (type buffer buffer) - (type (simple-array card16 (*)) data) - (type array-index boffset start end)) - (with-vector (data (simple-array card16 (*))) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (aref data index)) - (setq index (index+ index 1))) - ;; overlapping case - (let ((length (floor chunk 2))) - (buffer-replace buffer-wbuf data - buffer-woffset - (index+ buffer-woffset length) - index) - (setq index (index+ index length))))) - nil) - -(defun write-simple-array-card16-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type (simple-array card16 (*)) data) - (type array-index boffset start end)) - (declare (type (function (card16) card16) transform) - (dynamic-extent transform)) - (with-vector (data (simple-array card16 (*))) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-card16 (buffer boffset data start end) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (with-vector (data vector) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (aref data index)) - (setq index (index+ index 1))) - ;; overlapping case - (let ((length (floor chunk 2))) - (buffer-replace buffer-wbuf data - buffer-woffset - (index+ buffer-woffset length) - index) - (setq index (index+ index length))))) - nil) - -(defun write-vector-card16-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (declare (type (function (t) card16) transform) - (dynamic-extent transform)) - (with-vector (data vector) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-sequence-card16 - (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare (type buffer buffer) - (type sequence data) - (type array-index boffset start end)) - (declare (type (or null (function (t) card16)) transform) - (dynamic-extent transform)) - (typecase data - (list - (if transform - (write-list-card16-with-transform buffer boffset data start end transform) - (write-list-card16 buffer boffset data start end))) - ((simple-array card16 (*)) - (if transform - (write-simple-array-card16-with-transform buffer boffset data start end transform) - (write-simple-array-card16 buffer boffset data start end))) - (t - (if transform - (write-vector-card16-with-transform buffer boffset data start end transform) - (write-vector-card16 buffer boffset data start end))))) - -;;; Writing sequences of int16's - -(defun write-list-int16 (buffer boffset data start end) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (writing-buffer-chunks int16 - ((lst (nthcdr start data))) - ((type list lst)) - ;; Depends upon the chunks being an even multiple of int16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (pop lst)))) - nil) - -(defun write-list-int16-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (declare (type (function (t) int16) transform) - (dynamic-extent transform)) - (writing-buffer-chunks int16 - ((lst (nthcdr start data))) - ((type list lst)) - ;; Depends upon the chunks being an even multiple of int16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (funcall transform (pop lst))))) - nil) - -(defun write-simple-array-int16 (buffer boffset data start end) - (declare (type buffer buffer) - (type (simple-array int16 (*)) data) - (type array-index boffset start end)) - (with-vector (data (simple-array int16 (*))) - (writing-buffer-chunks int16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of int16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (aref data index)) - (setq index (index+ index 1))) - ;; overlapping case - (let ((length (floor chunk 2))) - (buffer-replace buffer-wbuf data - buffer-woffset - (index+ buffer-woffset length) - index) - (setq index (index+ index length))))) - nil) - -(defun write-simple-array-int16-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type (simple-array int16 (*)) data) - (type array-index boffset start end)) - (declare (type (function (int16) int16) transform) - (dynamic-extent transform)) - (with-vector (data (simple-array int16 (*))) - (writing-buffer-chunks int16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of int16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-int16 (buffer boffset data start end) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (with-vector (data vector) - (writing-buffer-chunks int16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of int16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (aref data index)) - (setq index (index+ index 1))) - ;; overlapping case - (let ((length (floor chunk 2))) - (buffer-replace buffer-wbuf data - buffer-woffset - (index+ buffer-woffset length) - index) - (setq index (index+ index length))))) - nil) - -(defun write-vector-int16-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (declare (type (function (t) int16) transform) - (dynamic-extent transform)) - (with-vector (data vector) - (writing-buffer-chunks int16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of int16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-sequence-int16 - (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare (type buffer buffer) - (type sequence data) - (type array-index boffset start end)) - (declare (type (or null (function (t) int16)) transform) - (dynamic-extent transform)) - (typecase data - (list - (if transform - (write-list-int16-with-transform buffer boffset data start end transform) - (write-list-int16 buffer boffset data start end))) - ((simple-array int16 (*)) - (if transform - (write-simple-array-int16-with-transform buffer boffset data start end transform) - (write-simple-array-int16 buffer boffset data start end))) - (t - (if transform - (write-vector-int16-with-transform buffer boffset data start end transform) - (write-vector-int16 buffer boffset data start end))))) - -;;; Writing sequences of card32's - -(defun write-list-card32 (buffer boffset data start end) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (writing-buffer-chunks card32 - ((lst (nthcdr start data))) - ((type list lst)) - ;; Depends upon the chunks being an even multiple of card32's big - (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (pop lst)))) - nil) - -(defun write-list-card32-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (declare (type (function (t) card32) transform) - (dynamic-extent transform)) - (writing-buffer-chunks card32 - ((lst (nthcdr start data))) - ((type list lst)) - ;; Depends upon the chunks being an even multiple of card32's big - (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (funcall transform (pop lst))))) - nil) - -(defun write-simple-array-card32 (buffer boffset data start end) - (declare (type buffer buffer) - (type (simple-array card32 (*)) data) - (type array-index boffset start end)) - (with-vector (data (simple-array card32 (*))) - (writing-buffer-chunks card32 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card32's big - (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (aref data index)) - (setq index (index+ index 1))) - ;; overlapping case - (let ((length (floor chunk 4))) - (buffer-replace buffer-lbuf data - buffer-loffset - (index+ buffer-loffset length) - index) - (setq index (index+ index length))))) - nil) - -(defun write-simple-array-card32-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type (simple-array card32 (*)) data) - (type array-index boffset start end)) - (declare (type (function (card32) card32) transform) - (dynamic-extent transform)) - (with-vector (data (simple-array card32 (*))) - (writing-buffer-chunks card32 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card32's big - (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-card32 (buffer boffset data start end) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (with-vector (data vector) - (writing-buffer-chunks card32 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card32's big - (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (aref data index)) - (setq index (index+ index 1))) - ;; overlapping case - (let ((length (floor chunk 4))) - (buffer-replace buffer-lbuf data - buffer-loffset - (index+ buffer-loffset length) - index) - (setq index (index+ index length))))) - nil) - -(defun write-vector-card32-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (declare (type (function (t) card32) transform) - (dynamic-extent transform)) - (with-vector (data vector) - (writing-buffer-chunks card32 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card32's big - (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-sequence-card32 - (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare (type buffer buffer) - (type sequence data) - (type array-index boffset start end)) - (declare (type (or null (function (t) card32)) transform) - (dynamic-extent transform)) - (typecase data - (list - (if transform - (write-list-card32-with-transform buffer boffset data start end transform) - (write-list-card32 buffer boffset data start end))) - ((simple-array card32 (*)) - (if transform - (write-simple-array-card32-with-transform buffer boffset data start end transform) - (write-simple-array-card32 buffer boffset data start end))) - (t - (if transform - (write-vector-card32-with-transform buffer boffset data start end transform) - (write-vector-card32 buffer boffset data start end))))) - -;;; For now, perhaps performance it isn't worth doing better? - -(defun write-sequence-int32 - (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare (type buffer buffer) - (type sequence data) - (type array-index boffset start end)) - (declare (type (or null (function (t) int32)) transform) - (dynamic-extent transform)) - (if transform - (flet ((transform->int32->card32 (x) - (int32->card32 (the int32 (funcall transform x))))) - (declare (dynamic-extent #'transform->int32->card32)) - (write-sequence-card32 - buffer boffset data start end #'transform->int32->card32)) - (write-sequence-card32 buffer boffset data start end #'int32->card32))) - -(defun read-bitvector256 (buffer-bbuf boffset data) - (declare (type buffer-bytes buffer-bbuf) - (type array-index boffset) - (type (or null (simple-bit-vector 256)) data)) - (let ((result (or data (make-array 256 :element-type 'bit :initial-element 0)))) - (declare (type (simple-bit-vector 256) result)) - (do ((i (index+ boffset 1) (index+ i 1)) ;; Skip first byte - (j 8 (index+ j 8))) - ((index>= j 256)) - (declare (type array-index i j)) - (do ((byte (aref-card8 buffer-bbuf i) (index-ash byte -1)) - (k j (index+ k 1))) - ((zerop byte) - (when data ;; Clear uninitialized bits in data - (do ((end (index+ j 8))) - ((index= k end)) - (declare (type array-index end)) - (setf (aref result k) 0) - (index-incf k)))) - (declare (type array-index k) - (type card8 byte)) - (setf (aref result k) (the bit (logand byte 1))))) - result)) - -(defun write-bitvector256 (buffer boffset map) - (declare (type buffer buffer) - (type array-index boffset) - (type (simple-array bit (*)) map)) - (with-buffer-output (buffer :index boffset :sizes 8) - (do* ((i (index+ buffer-boffset 1) (index+ i 1)) ; Skip first byte - (j 8 (index+ j 8))) - ((index>= j 256)) - (declare (type array-index i j)) - (do ((byte 0) - (bit (index+ j 7) (index- bit 1))) - ((index< bit j) - (aset-card8 byte buffer-bbuf i)) - (declare (type array-index bit) - (type card8 byte)) - (setq byte (the card8 (logior (the card8 (ash byte 1)) (aref map bit)))))))) - -;;; Writing sequences of char2b's - -(defun write-list-char2b (buffer boffset data start end) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (writing-buffer-chunks card16 - ((lst (nthcdr start data))) - ((type list lst)) - (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (pop lst)))) - nil) - -(defun write-list-char2b-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (declare (type (function (t) card16) transform) - (dynamic-extent transform)) - (writing-buffer-chunks card16 - ((lst (nthcdr start data))) - ((type list lst)) - (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (funcall transform (pop lst))))) - nil) - -(defun write-simple-array-char2b (buffer boffset data start end) - (declare (type buffer buffer) - (type (simple-array card16 (*)) data) - (type array-index boffset start end)) - (with-vector (data (simple-array card16 (*))) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (aref data index)) - (setq index (index+ index 1))))) - nil) - -(defun write-simple-array-char2b-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type (simple-array card16 (*)) data) - (type array-index boffset start end)) - (declare (type (function (card16) card16) transform) - (dynamic-extent transform)) - (with-vector (data (simple-array card16 (*))) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-char2b (buffer boffset data start end) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (with-vector (data vector) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (aref data index)) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-char2b-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (declare (type (function (t) card16) transform) - (dynamic-extent transform)) - (with-vector (data vector) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-sequence-char2b - (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare (type buffer buffer) - (type sequence data) - (type array-index boffset start end)) - (declare (type (or null (function (t) card16)) transform) - (dynamic-extent transform)) - (typecase data - (list - (if transform - (write-list-char2b-with-transform buffer boffset data start end transform) - (write-list-char2b buffer boffset data start end))) - ((simple-array card16 (*)) - (if transform - (write-simple-array-char2b-with-transform buffer boffset data start end transform) - (write-simple-array-char2b buffer boffset data start end))) - (t - (if transform - (write-vector-char2b-with-transform buffer boffset data start end transform) - (write-vector-char2b buffer boffset data start end))))) - diff --git a/src/eclx/bufmac.lisp b/src/eclx/bufmac.lisp deleted file mode 100644 index a9fe8e3d3..000000000 --- a/src/eclx/bufmac.lisp +++ /dev/null @@ -1,187 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; This file contains macro definitions for the BUFFER object for Common-Lisp -;;; X windows version 11 - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; -#+cmu -(ext:file-comment - "$Header$") - -(in-package :xlib) - -;;; The read- macros are in buffer.lisp, because event-case depends on (most of) them. - -(defmacro write-card8 (byte-index item) - `(aset-card8 (the card8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro write-int8 (byte-index item) - `(aset-int8 (the int8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro write-card16 (byte-index item) - #+clx-overlapping-arrays - `(aset-card16 (the card16 ,item) buffer-wbuf - (index+ buffer-woffset (index-ash ,byte-index -1))) - #-clx-overlapping-arrays - `(aset-card16 (the card16 ,item) buffer-bbuf - (index+ buffer-boffset ,byte-index))) - -(defmacro write-int16 (byte-index item) - #+clx-overlapping-arrays - `(aset-int16 (the int16 ,item) buffer-wbuf - (index+ buffer-woffset (index-ash ,byte-index -1))) - #-clx-overlapping-arrays - `(aset-int16 (the int16 ,item) buffer-bbuf - (index+ buffer-boffset ,byte-index))) - -(defmacro write-card32 (byte-index item) - #+clx-overlapping-arrays - `(aset-card32 (the card32 ,item) buffer-lbuf - (index+ buffer-loffset (index-ash ,byte-index -2))) - #-clx-overlapping-arrays - `(aset-card32 (the card32 ,item) buffer-bbuf - (index+ buffer-boffset ,byte-index))) - -(defmacro write-int32 (byte-index item) - #+clx-overlapping-arrays - `(aset-int32 (the int32 ,item) buffer-lbuf - (index+ buffer-loffset (index-ash ,byte-index -2))) - #-clx-overlapping-arrays - `(aset-int32 (the int32 ,item) buffer-bbuf - (index+ buffer-boffset ,byte-index))) - -(defmacro write-card29 (byte-index item) - #+clx-overlapping-arrays - `(aset-card29 (the card29 ,item) buffer-lbuf - (index+ buffer-loffset (index-ash ,byte-index -2))) - #-clx-overlapping-arrays - `(aset-card29 (the card29 ,item) buffer-bbuf - (index+ buffer-boffset ,byte-index))) - -;; This is used for 2-byte characters, which may not be aligned on 2-byte boundaries -;; and always are written high-order byte first. -(defmacro write-char2b (byte-index item) - ;; It is impossible to do an overlapping write, so only nonoverlapping here. - `(let ((%item ,item) - (%byte-index (index+ buffer-boffset ,byte-index))) - (declare (type card16 %item) - (type array-index %byte-index)) - (aset-card8 (the card8 (ldb (byte 8 8) %item)) buffer-bbuf %byte-index) - (aset-card8 (the card8 (ldb (byte 8 0) %item)) buffer-bbuf (index+ %byte-index 1)))) - -(defmacro set-buffer-offset (value &environment env) - env - `(let ((.boffset. ,value)) - (declare (type array-index .boffset.)) - (setq buffer-boffset .boffset.) - #+clx-overlapping-arrays - ,@(when (member 16 (macroexpand '(%buffer-sizes) env)) - `((setq buffer-woffset (index-ash .boffset. -1)))) - #+clx-overlapping-arrays - ,@(when (member 32 (macroexpand '(%buffer-sizes) env)) - `((setq buffer-loffset (index-ash .boffset. -2)))) - #+clx-overlapping-arrays - .boffset.)) - -(defmacro advance-buffer-offset (value) - `(set-buffer-offset (index+ buffer-boffset ,value))) - -(defmacro with-buffer-output ((buffer &key (sizes '(8 16 32)) length index) &body body) - (unless (listp sizes) (setq sizes (list sizes))) - `(let ((%buffer ,buffer)) - (declare (type display %buffer)) - ,(declare-bufmac) - ,(when length - `(when (index>= (index+ (buffer-boffset %buffer) ,length) (buffer-size %buffer)) - (buffer-flush %buffer))) - (let* ((buffer-boffset (the array-index ,(or index `(buffer-boffset %buffer)))) - #-clx-overlapping-arrays - (buffer-bbuf (buffer-obuf8 %buffer)) - #+clx-overlapping-arrays - ,@(append - (when (member 8 sizes) - `((buffer-bbuf (buffer-obuf8 %buffer)))) - (when (or (member 16 sizes) (member 160 sizes)) - `((buffer-woffset (index-ash buffer-boffset -1)) - (buffer-wbuf (buffer-obuf16 %buffer)))) - (when (member 32 sizes) - `((buffer-loffset (index-ash buffer-boffset -2)) - (buffer-lbuf (buffer-obuf32 %buffer)))))) - (declare (type array-index buffer-boffset)) - #-clx-overlapping-arrays - (declare (type buffer-bytes buffer-bbuf)) - #+clx-overlapping-arrays - ,@(append - (when (member 8 sizes) - '((declare (type buffer-bytes buffer-bbuf)))) - (when (member 16 sizes) - '((declare (type array-index buffer-woffset)) - (declare (type buffer-words buffer-wbuf)))) - (when (member 32 sizes) - '((declare (type array-index buffer-loffset)) - (declare (type buffer-longs buffer-lbuf))))) - buffer-boffset - #-clx-overlapping-arrays - buffer-bbuf - #+clx-overlapping-arrays - ,@(append - (when (member 8 sizes) '(buffer-bbuf)) - (when (member 16 sizes) '(buffer-woffset buffer-wbuf)) - (when (member 32 sizes) '(buffer-loffset buffer-lbuf))) - #+clx-overlapping-arrays - (macrolet ((%buffer-sizes () ',sizes)) - ,@body) - #-clx-overlapping-arrays - ,@body))) - -;;; This macro is just used internally in buffer - -(defmacro writing-buffer-chunks (type args decls &body body) - (when (> (length body) 2) - (error "writing-buffer-chunks called with too many forms")) - (let* ((size (* 8 (index-increment type))) - (form #-clx-overlapping-arrays - (first body) - #+clx-overlapping-arrays ; XXX type dependencies - (or (second body) - (first body)))) - `(with-buffer-output (buffer :index boffset :sizes ,(reverse (adjoin size '(8)))) - ;; Loop filling the buffer - (do* (,@args - ;; Number of bytes needed to output - (len ,(if (= size 8) - `(index- end start) - `(index-ash (index- end start) ,(truncate size 16))) - (index- len chunk)) - ;; Number of bytes available in buffer - (chunk (index-min len (index- (buffer-size buffer) buffer-boffset)) - (index-min len (index- (buffer-size buffer) buffer-boffset)))) - ((not (index-plusp len))) - (declare ,@decls - (type array-index len chunk)) - ,form - (index-incf buffer-boffset chunk) - ;; Flush the buffer - (when (and (index-plusp len) (index>= buffer-boffset (buffer-size buffer))) - (setf (buffer-boffset buffer) buffer-boffset) - (buffer-flush buffer) - (setq buffer-boffset (buffer-boffset buffer)) - #+clx-overlapping-arrays - ,(case size - (16 '(setq buffer-woffset (index-ash buffer-boffset -1))) - (32 '(setq buffer-loffset (index-ash buffer-boffset -2)))))) - (setf (buffer-boffset buffer) (lround buffer-boffset))))) diff --git a/src/eclx/clx.lisp b/src/eclx/clx.lisp deleted file mode 100644 index 9fdaad5b2..000000000 --- a/src/eclx/clx.lisp +++ /dev/null @@ -1,940 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; -#+cmu -(ext:file-comment - "$Header$") - -;; Primary Interface Author: -;; Robert W. Scheifler -;; MIT Laboratory for Computer Science -;; 545 Technology Square, Room 418 -;; Cambridge, MA 02139 -;; rws@zermatt.lcs.mit.edu - -;; Design Contributors: -;; Dan Cerys, Texas Instruments -;; Scott Fahlman, CMU -;; Charles Hornig, Symbolics -;; John Irwin, Franz -;; Kerry Kimbrough, Texas Instruments -;; Chris Lindblad, MIT -;; Rob MacLachlan, CMU -;; Mike McMahon, Symbolics -;; David Moon, Symbolics -;; LaMott Oren, Texas Instruments -;; Daniel Weinreb, Symbolics -;; John Wroclawski, MIT -;; Richard Zippel, Symbolics - -;; Primary Implementation Author: -;; LaMott Oren, Texas Instruments - -;; Implementation Contributors: -;; Charles Hornig, Symbolics -;; John Irwin, Franz -;; Chris Lindblad, MIT -;; Robert Scheifler, MIT - -;;; -;;; Change history: -;;; -;;; Date Author Description -;;; ------------------------------------------------------------------------------------- -;;; 04/07/87 R.Scheifler Created code stubs -;;; 04/08/87 L.Oren Started Implementation -;;; 05/11/87 L.Oren Included draft 3 revisions -;;; 07/07/87 L.Oren Untested alpha release to MIT -;;; 07/17/87 L.Oren Alpha release -;;; 08/**/87 C.Lindblad Rewrite of buffer code -;;; 08/**/87 et al Various random bug fixes -;;; 08/**/87 R.Scheifler General syntactic and portability cleanups -;;; 08/**/87 R.Scheifler Rewrite of gcontext caching and shadowing -;;; 09/02/87 L.Oren Change events from resource-ids to objects -;;; 12/24/87 R.Budzianowski KCL support -;;; 12/**/87 J.Irwin ExCL 2.0 support -;;; 01/20/88 L.Oren Add server extension mechanisms -;;; 01/20/88 L.Oren Only force output when blocking on input -;;; 01/20/88 L.Oren Uniform support for :event-window on events -;;; 01/28/88 L.Oren Add window manager property functions -;;; 01/28/88 L.Oren Add character translation facility -;;; 02/**/87 J.Irwin Allegro 2.2 support - -;;; This is considered a somewhat changeable interface. Discussion of better -;;; integration with CLOS, support for user-specified subclassess of basic -;;; objects, and the additional functionality to match the C Xlib is still in -;;; progress. Bug reports should be addressed to bug-clx@expo.lcs.mit.edu. - -;; Note: all of the following is in the package XLIB. - -(in-package :xlib) - -(pushnew :clx *features*) -(pushnew :xlib *features*) -(setf *features* (remove :no-clx *features*)) - -(defparameter *version* "MIT R5.02") -(pushnew :clx-mit-r4 *features*) -(pushnew :clx-mit-r5 *features*) - -(defparameter *protocol-major-version* 11.) -(defparameter *protocol-minor-version* 0) - -(defparameter *x-tcp-port*+ 6000) ;; add display number - -(defparameter *protocol-families* - '(;; X11/X.h, Family* - (:internet . 0) - (:decnet . 1) - (:chaos . 2) - ;; X11/Xauth.h "not part of X standard" - (:Local . 256) - (:Wild . 65535) - (:Netname . 254) - (:Krb5Principal . 253) - (:LocalHost . 252))) - -;; Note: if you have read the Version 11 protocol document or C Xlib manual, most of -;; the relationships should be fairly obvious. We have no intention of writing yet -;; another moby document for this interface. - -;; Types employed: display, window, pixmap, cursor, font, gcontext, colormap, color. -;; These types are defined solely by a functional interface; we do not specify -;; whether they are implemented as structures or flavors or ... Although functions -;; below are written using DEFUN, this is not an implementation requirement (although -;; it is a requirement that they be functions as opposed to macros or special forms). -;; It is unclear whether with-slots in the Common Lisp Object System must work on -;; them. - -;; Windows, pixmaps, cursors, fonts, gcontexts, and colormaps are all represented as -;; compound objects, rather than as integer resource-ids. This allows applications -;; to deal with multiple displays without having an explicit display argument in the -;; most common functions. Every function uses the display object indicated by the -;; first argument that is or contains a display; it is an error if arguments contain -;; different displays, and predictable results are not guaranteed. - -;; Each of window, pixmap, cursor, font, gcontext, and colormap have the following -;; five functions: - -;(defun make- (display resource-id) -; ;; This function should almost never be called by applications, except in handling -; ;; events. To minimize consing in some implementations, this may use a cache in -; ;; the display. Make-gcontext creates with :cache-p nil. Make-font creates with -; ;; cache-p true. -; (declare (type display display) -; (type integer resource-id) -; (clx-values ))) - -;(defun -display () -; (declare (type ) -; (clx-values display))) - -;(defun -id () -; (declare (type ) -; (clx-values integer))) - -;(defun -equal (-1 -2) -; (declare (type -1 -2))) - -;(defun -p (-1 -2) -; (declare (type -1 -2) -; (clx-values boolean))) - - -(deftype generalized-boolean () 't) ; (or null (not null)) - -(deftype card32 () '(unsigned-byte 32)) - -(deftype card29 () '(unsigned-byte 29)) - -(deftype card24 () '(unsigned-byte 24)) - -(deftype int32 () '(signed-byte 32)) - -(deftype card16 () '(unsigned-byte 16)) - -(deftype int16 () '(signed-byte 16)) - -(deftype card8 () '(unsigned-byte 8)) - -(deftype int8 () '(signed-byte 8)) - -(deftype card4 () '(unsigned-byte 4)) - -; Note that we are explicitly using a different rgb representation than what -; is actually transmitted in the protocol. - -(deftype rgb-val () '(real 0 1)) - -; Note that we are explicitly using a different angle representation than what -; is actually transmitted in the protocol. - -;;; From cmucl clx: -;;; -;;; This overrides the (probably incorrect) definition in clx.lisp. Since PI -;;; is irrational, there can't be a precise rational representation. In -;;; particular, the different float approximations will always be /=. This -;;; causes problems with type checking, because people might compute an -;;; argument in any precision. What we do is discard all the excess precision -;;; in the value, and see if the protocal encoding falls in the desired range -;;; (64'ths of a degree.) -;;; -(deftype angle () '(satisfies anglep)) - -(defun anglep (x) - (and (typep x 'real) - (<= (* -360 64) - (radians->int16 x) - (* 360 64)))) - -(deftype mask32 () 'card32) - -(deftype mask16 () 'card16) - -(deftype pixel () '(unsigned-byte 32)) -(deftype image-depth () '(integer 0 32)) - -(deftype resource-id () 'card29) - -(deftype keysym () 'card32) - -; The following functions are provided by color objects: - -; The intention is that IHS and YIQ and CYM interfaces will also exist. -; Note that we are explicitly using a different spectrum representation -; than what is actually transmitted in the protocol. - -(def-clx-class (color (:constructor make-color-internal (red green blue)) - (:copier nil) (:print-function print-color)) - (red 0.0 :type rgb-val) - (green 0.0 :type rgb-val) - (blue 0.0 :type rgb-val)) - -(defun print-color (color stream depth) - (declare (type color color) - (ignore depth)) - (print-unreadable-object (color stream :type t) - (prin1 (color-red color) stream) - (write-string " " stream) - (prin1 (color-green color) stream) - (write-string " " stream) - (prin1 (color-blue color) stream))) - -(defun make-color (&key (red 1.0) (green 1.0) (blue 1.0) &allow-other-keys) - (declare (type rgb-val red green blue)) - (declare (clx-values color)) - (make-color-internal red green blue)) - -(defun color-rgb (color) - (declare (type color color)) - (declare (clx-values red green blue)) - (values (color-red color) (color-green color) (color-blue color))) - -(def-clx-class (bitmap-format (:copier nil) (:print-function print-bitmap-format)) - (unit 8 :type (member 8 16 32)) - (pad 8 :type (member 8 16 32)) - (lsb-first-p nil :type generalized-boolean)) - -(defun print-bitmap-format (bitmap-format stream depth) - (declare (type bitmap-format bitmap-format) - (ignore depth)) - (print-unreadable-object (bitmap-format stream :type t) - (format stream "unit ~D pad ~D ~:[M~;L~]SB first" - (bitmap-format-unit bitmap-format) - (bitmap-format-pad bitmap-format) - (bitmap-format-lsb-first-p bitmap-format)))) - -(def-clx-class (pixmap-format (:copier nil) (:print-function print-pixmap-format)) - (depth 0 :type image-depth) - (bits-per-pixel 8 :type (member 1 4 8 16 24 32)) - (scanline-pad 8 :type (member 8 16 32))) - -(defun print-pixmap-format (pixmap-format stream depth) - (declare (type pixmap-format pixmap-format) - (ignore depth)) - (print-unreadable-object (pixmap-format stream :type t) - (format stream "depth ~D bits-per-pixel ~D scanline-pad ~D" - (pixmap-format-depth pixmap-format) - (pixmap-format-bits-per-pixel pixmap-format) - (pixmap-format-scanline-pad pixmap-format)))) - -(defparameter *atom-cache-size* 200) -(defparameter *resource-id-map-size* 500) - -(def-clx-class (display (:include buffer) - (:constructor make-display-internal) - (:print-function print-display) - (:copier nil)) - (host) ; Server Host - (display 0 :type integer) ; Display number on host - (after-function nil) ; Function to call after every request - (event-lock - (make-process-lock "CLX Event Lock")) ; with-event-queue lock - (event-queue-lock - (make-process-lock "CLX Event Queue Lock")) ; new-events/event-queue lock - (event-queue-tail ; last event in the event queue - nil :type (or null reply-buffer)) - (event-queue-head ; Threaded queue of events - nil :type (or null reply-buffer)) - (atom-cache (make-hash-table :test (atom-cache-map-test) :size *atom-cache-size*) - :type hash-table) ; Hash table relating atoms keywords - ; to atom id's - (font-cache nil) ; list of font - (protocol-major-version 0 :type card16) ; Major version of server's X protocol - (protocol-minor-version 0 :type card16) ; minor version of servers X protocol - (vendor-name "" :type string) ; vendor of the server hardware - (resource-id-base 0 :type resource-id) ; resouce ID base - (resource-id-mask 0 :type resource-id) ; resource ID mask bits - (resource-id-byte nil) ; resource ID mask field (used with DPB & LDB) - (resource-id-count 0 :type resource-id) ; resource ID mask count - ; (used for allocating ID's) - (resource-id-map (make-hash-table :test (resource-id-map-test) - :size *resource-id-map-size*) - :type hash-table) ; hash table maps resource-id's to - ; objects (used in lookup functions) - (xid 'resourcealloc) ; allocator function - (byte-order #+clx-little-endian :lsbfirst ; connection byte order - #-clx-little-endian :msbfirst) - (release-number 0 :type card32) ; release of the server - (max-request-length 0 :type card16) ; maximum number 32 bit words in request - (default-screen) ; default screen for operations - (roots nil :type list) ; List of screens - (motion-buffer-size 0 :type card32) ; size of motion buffer - (xdefaults) ; contents of defaults from server - (image-lsb-first-p nil :type generalized-boolean) - (bitmap-format (make-bitmap-format) ; Screen image info - :type bitmap-format) - (pixmap-formats nil :type sequence) ; list of pixmap formats - (min-keycode 0 :type card8) ; minimum key-code - (max-keycode 0 :type card8) ; maximum key-code - (error-handler 'default-error-handler) ; Error handler function - (close-down-mode :destroy) ; Close down mode saved by Set-Close-Down-Mode - (authorization-name "" :type string) - (authorization-data "" :type (or (array (unsigned-byte 8)) string)) - (last-width nil :type (or null card29)) ; Accumulated width of last string - (keysym-mapping nil ; Keysym mapping cached from server - :type (or null (array * (* *)))) - (modifier-mapping nil :type list) ; ALIST of (keysym . state-mask) for all modifier keysyms - (keysym-translation nil :type list) ; An alist of (keysym object function) - ; for display-local keysyms - (extension-alist nil :type list) ; extension alist, which has elements: - ; (name major-opcode first-event first-error) - (event-extensions '#() :type vector) ; Vector mapping X event-codes to event keys - (performance-info) ; Hook for gathering performance info - (trace-history) ; Hook for debug trace - (plist nil :type list) ; hook for extension to hang data - ;; These slots are used to manage multi-process input. - (input-in-progress nil) ; Some process reading from the stream. - ; Updated with CONDITIONAL-STORE. - (pending-commands nil) ; Threaded list of PENDING-COMMAND objects - ; for all commands awaiting replies. - ; Protected by WITH-EVENT-QUEUE-INTERNAL. - (asynchronous-errors nil) ; Threaded list of REPLY-BUFFER objects - ; containing error messages for commands - ; which did not expect replies. - ; Protected by WITH-EVENT-QUEUE-INTERNAL. - (report-asynchronous-errors ; When to report asynchronous errors - '(:immediately) :type list) ; The keywords that can be on this list - ; are :IMMEDIATELY, :BEFORE-EVENT-HANDLING, - ; and :AFTER-FINISH-OUTPUT - (event-process nil) ; Process ID of process awaiting events. - ; Protected by WITH-EVENT-QUEUE. - (new-events nil :type (or null reply-buffer)) ; Pointer to the first new event in the - ; event queue. - ; Protected by WITH-EVENT-QUEUE. - (current-event-symbol ; Bound with PROGV by event handling macros - (list (gensym) (gensym)) :type cons) - (atom-id-map (make-hash-table :test (resource-id-map-test) - :size *atom-cache-size*) - :type hash-table) - ) - -(defun print-display-name (display stream) - (declare (type (or null display) display)) - (cond (display - (princ (display-host display) stream) - (write-string ":" stream) - (princ (display-display display) stream)) - (t - (write-string "(no display)" stream))) - display) - -(defun print-display (display stream depth) - (declare (type display display) - (ignore depth)) - (print-unreadable-object (display stream :type t) - (print-display-name display stream) - (write-string " (" stream) - (write-string (display-vendor-name display) stream) - (write-string " R" stream) - (prin1 (display-release-number display) stream) - (write-string ")" stream))) - -;;(deftype drawable () '(or window pixmap)) - -(def-clx-class (drawable (:copier nil) (:print-function print-drawable)) - (id 0 :type resource-id) - (display nil :type (or null display)) - (plist nil :type list) ; Extension hook - ) - -(defun print-drawable (drawable stream depth) - (declare (type drawable drawable) - (ignore depth)) - (print-unreadable-object (drawable stream :type t) - (print-display-name (drawable-display drawable) stream) - (write-string " " stream) - (prin1 (drawable-id drawable) stream))) - -(def-clx-class (window (:include drawable) (:copier nil) - (:print-function print-drawable)) - ) - -(def-clx-class (pixmap (:include drawable) (:copier nil) - (:print-function print-drawable)) - ) - -(def-clx-class (visual-info (:copier nil) (:print-function print-visual-info)) - (id 0 :type resource-id) - (display nil :type (or null display)) - (class :static-gray :type (member :static-gray :static-color :true-color - :gray-scale :pseudo-color :direct-color)) - (red-mask 0 :type pixel) - (green-mask 0 :type pixel) - (blue-mask 0 :type pixel) - (bits-per-rgb 1 :type card8) - (colormap-entries 0 :type card16) - (plist nil :type list) ; Extension hook - ) - -(defun print-visual-info (visual-info stream depth) - (declare (type visual-info visual-info) - (ignore depth)) - (print-unreadable-object (visual-info stream :type t) - (prin1 (visual-info-bits-per-rgb visual-info) stream) - (write-string "-bit " stream) - (princ (visual-info-class visual-info) stream) - (write-string " " stream) - (print-display-name (visual-info-display visual-info) stream) - (write-string " " stream) - (prin1 (visual-info-id visual-info) stream))) - -(def-clx-class (colormap (:copier nil) (:print-function print-colormap)) - (id 0 :type resource-id) - (display nil :type (or null display)) - (visual-info nil :type (or null visual-info)) - ) - -(defun print-colormap (colormap stream depth) - (declare (type colormap colormap) - (ignore depth)) - (print-unreadable-object (colormap stream :type t) - (when (colormap-visual-info colormap) - (princ (visual-info-class (colormap-visual-info colormap)) stream) - (write-string " " stream)) - (print-display-name (colormap-display colormap) stream) - (write-string " " stream) - (prin1 (colormap-id colormap) stream))) - -(def-clx-class (cursor (:copier nil) (:print-function print-cursor)) - (id 0 :type resource-id) - (display nil :type (or null display)) - ) - -(defun print-cursor (cursor stream depth) - (declare (type cursor cursor) - (ignore depth)) - (print-unreadable-object (cursor stream :type t) - (print-display-name (cursor-display cursor) stream) - (write-string " " stream) - (prin1 (cursor-id cursor) stream))) - -; Atoms are accepted as strings or symbols, and are always returned as keywords. -; Protocol-level integer atom ids are hidden, using a cache in the display object. - -(deftype xatom () '(or string symbol)) - -(defparameter *predefined-atoms* - '#(nil :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)) - -(deftype stringable () '(or string symbol)) - -(deftype fontable () '(or stringable font)) - -; Nil stands for CurrentTime. - -(deftype timestamp () '(or null card32)) - -(defparameter *bit-gravity-vector* - '#(:forget :north-west :north :north-east :west - :center :east :south-west :south - :south-east :static)) - -(deftype bit-gravity () - '(member :forget :north-west :north :north-east :west - :center :east :south-west :south :south-east :static)) - -(defparameter *win-gravity-vector* - '#(:unmap :north-west :north :north-east :west - :center :east :south-west :south :south-east - :static)) - -(deftype win-gravity () - '(member :unmap :north-west :north :north-east :west - :center :east :south-west :south :south-east :static)) - -(deftype grab-status () - '(member :success :already-grabbed :invalid-time :not-viewable)) - -; An association list. - -(deftype alist (key-type-and-name datum-type-and-name) - (declare (ignore key-type-and-name datum-type-and-name)) - 'list) - -(deftype clx-list (&optional element-type) (declare (ignore element-type)) 'list) -(deftype clx-sequence (&optional element-type) (declare (ignore element-type)) 'sequence) - -; A sequence, containing zero or more repetitions of the given elements, -; with the elements expressed as (type name). - -(deftype repeat-seq (&rest elts) elts 'sequence) - -(deftype point-seq () '(repeat-seq (int16 x) (int16 y))) - -(deftype seg-seq () '(repeat-seq (int16 x1) (int16 y1) (int16 x2) (int16 y2))) - -(deftype rect-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height))) - -(deftype arc-seq () - '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height) - (angle angle1) (angle angle2))) - -(deftype gcontext-state () 'simple-vector) - -(def-clx-class (gcontext (:copier nil) (:print-function print-gcontext)) - ;; The accessors convert to CLX data types. - (id 0 :type resource-id) - (display nil :type (or null display)) - (drawable nil :type (or null drawable)) - (cache-p t :type generalized-boolean) - (server-state (allocate-gcontext-state) :type gcontext-state) - (local-state (allocate-gcontext-state) :type gcontext-state) - (plist nil :type list) ; Extension hook - (next nil :type (or null gcontext)) - ) - -(defun print-gcontext (gcontext stream depth) - (declare (type gcontext gcontext) - (ignore depth)) - (print-unreadable-object (gcontext stream :type t) - (print-display-name (gcontext-display gcontext) stream) - (write-string " " stream) - (prin1 (gcontext-id gcontext) stream))) - -(defparameter *event-mask-vector* - '#(:key-press :key-release :button-press :button-release - :enter-window :leave-window :pointer-motion :pointer-motion-hint - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion :keymap-state :exposure :visibility-change - :structure-notify :resize-redirect :substructure-notify :substructure-redirect - :focus-change :property-change :colormap-change :owner-grab-button)) - -(deftype event-mask-class () - '(member :key-press :key-release :owner-grab-button :button-press :button-release - :enter-window :leave-window :pointer-motion :pointer-motion-hint - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion :exposure :visibility-change - :structure-notify :resize-redirect :substructure-notify :substructure-redirect - :focus-change :property-change :colormap-change :keymap-state)) - -(deftype event-mask () - '(or mask32 (clx-list event-mask-class))) - -(defparameter *pointer-event-mask-vector* - '#(%error %error :button-press :button-release - :enter-window :leave-window :pointer-motion :pointer-motion-hint - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion :keymap-state)) - -(deftype pointer-event-mask-class () - '(member :button-press :button-release - :enter-window :leave-window :pointer-motion :pointer-motion-hint - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion :keymap-state)) - -(deftype pointer-event-mask () - '(or mask32 (clx-list pointer-event-mask-class))) - -(defparameter *device-event-mask-vector* - '#(:key-press :key-release :button-press :button-release :pointer-motion - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion)) - -(deftype device-event-mask-class () - '(member :key-press :key-release :button-press :button-release :pointer-motion - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion)) - -(deftype device-event-mask () - '(or mask32 (clx-list device-event-mask-class))) - -(defparameter *state-mask-vector* - '#(:shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5 - :button-1 :button-2 :button-3 :button-4 :button-5)) - -(deftype modifier-key () - '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5)) - -(deftype modifier-mask () - '(or (member :any) mask16 (clx-list modifier-key))) - -(deftype state-mask-key () - '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5))) - -(defparameter *gcontext-components* - '(:function :plane-mask :foreground :background - :line-width :line-style :cap-style :join-style :fill-style - :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode - :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes - :arc-mode)) - -(deftype gcontext-key () - '(member :function :plane-mask :foreground :background - :line-width :line-style :cap-style :join-style :fill-style - :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode - :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes - :arc-mode)) - -(deftype event-key () - '(member :key-press :key-release :button-press :button-release :motion-notify - :enter-notify :leave-notify :focus-in :focus-out :keymap-notify - :exposure :graphics-exposure :no-exposure :visibility-notify - :create-notify :destroy-notify :unmap-notify :map-notify :map-request - :reparent-notify :configure-notify :gravity-notify :resize-request - :configure-request :circulate-notify :circulate-request :property-notify - :selection-clear :selection-request :selection-notify - :colormap-notify :client-message :mapping-notify)) - -(deftype error-key () - '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice - :illegal-request :implementation :length :match :name :pixmap :value :window)) - -(deftype draw-direction () - '(member :left-to-right :right-to-left)) - -(defparameter *boole-vector* - '#(#.boole-clr #.boole-and #.boole-andc2 #.boole-1 - #.boole-andc1 #.boole-2 #.boole-xor #.boole-ior - #.boole-nor #.boole-eqv #.boole-c2 #.boole-orc2 - #.boole-c1 #.boole-orc1 #.boole-nand #.boole-set)) - -(deftype boole-constant () - `(member ,boole-clr ,boole-and ,boole-andc2 ,boole-1 - ,boole-andc1 ,boole-2 ,boole-xor ,boole-ior - ,boole-nor ,boole-eqv ,boole-c2 ,boole-orc2 - ,boole-c1 ,boole-orc1 ,boole-nand ,boole-set)) - -(def-clx-class (screen (:copier nil) (:print-function print-screen)) - (root nil :type (or null window)) - (width 0 :type card16) - (height 0 :type card16) - (width-in-millimeters 0 :type card16) - (height-in-millimeters 0 :type card16) - (depths nil :type (alist (image-depth depth) ((clx-list visual-info) visuals))) - (root-depth 1 :type image-depth) - (root-visual-info nil :type (or null visual-info)) - (default-colormap nil :type (or null colormap)) - (white-pixel 0 :type pixel) - (black-pixel 1 :type pixel) - (min-installed-maps 1 :type card16) - (max-installed-maps 1 :type card16) - (backing-stores :never :type (member :never :when-mapped :always)) - (save-unders-p nil :type generalized-boolean) - (event-mask-at-open 0 :type mask32) - (plist nil :type list) ; Extension hook - ) - -(defun print-screen (screen stream depth) - (declare (type screen screen) - (ignore depth)) - (print-unreadable-object (screen stream :type t) - (let ((display (drawable-display (screen-root screen)))) - (print-display-name display stream) - (write-string "." stream) - (princ (position screen (display-roots display)) stream)) - (write-string " " stream) - (prin1 (screen-width screen) stream) - (write-string "x" stream) - (prin1 (screen-height screen) stream) - (write-string "x" stream) - (prin1 (screen-root-depth screen) stream) - (when (screen-root-visual-info screen) - (write-string " " stream) - (princ (visual-info-class (screen-root-visual-info screen)) stream)))) - -(defun screen-root-visual (screen) - (declare (type screen screen) - (clx-values resource-id)) - (visual-info-id (screen-root-visual-info screen))) - -;; The list contains alternating keywords and integers. -(deftype font-props () 'list) - -(def-clx-class (font-info (:copier nil) (:predicate nil)) - (direction :left-to-right :type draw-direction) - (min-char 0 :type card16) ;; First character in font - (max-char 0 :type card16) ;; Last character in font - (min-byte1 0 :type card8) ;; The following are for 16 bit fonts - (max-byte1 0 :type card8) ;; and specify min&max values for - (min-byte2 0 :type card8) ;; the two character bytes - (max-byte2 0 :type card8) - (all-chars-exist-p nil :type generalized-boolean) - (default-char 0 :type card16) - (min-bounds nil :type (or null vector)) - (max-bounds nil :type (or null vector)) - (ascent 0 :type int16) - (descent 0 :type int16) - (properties nil :type font-props)) - -(def-clx-class (font (:constructor make-font-internal) (:copier nil) - (:print-function print-font)) - (id-internal nil :type (or null resource-id)) ;; NIL when not opened - (display nil :type (or null display)) - (reference-count 0 :type fixnum) - (name "" :type (or null string)) ;; NIL when ID is for a GContext - (font-info-internal nil :type (or null font-info)) - (char-infos-internal nil :type (or null (simple-array int16 (*)))) - (local-only-p t :type generalized-boolean) ;; When T, always calculate text extents locally - (plist nil :type list) ; Extension hook - ) - -(defun print-font (font stream depth) - (declare (type font font) - (ignore depth)) - (print-unreadable-object (font stream :type t) - (if (font-name font) - (princ (font-name font) stream) - (write-string "(gcontext)" stream)) - (write-string " " stream) - (print-display-name (font-display font) stream) - (when (font-id-internal font) - (write-string " " stream) - (prin1 (font-id font) stream)))) - -(defun font-id (font) - ;; Get font-id, opening font if needed - (or (font-id-internal font) - (open-font-internal font))) - -(defun font-font-info (font) - (or (font-font-info-internal font) - (query-font font))) - -(defun font-char-infos (font) - (or (font-char-infos-internal font) - (progn (query-font font) - (font-char-infos-internal font)))) - -(defun make-font (&key id - display - (reference-count 0) - (name "") - (local-only-p t) - font-info-internal) - (make-font-internal :id-internal id - :display display - :reference-count reference-count - :name name - :local-only-p local-only-p - :font-info-internal font-info-internal)) - -; For each component ( :type ) of font-info, -; there is a corresponding function: - -;(defun font- (font) -; (declare (type font font) -; (clx-values ))) - -(macrolet ((make-font-info-accessors (useless-name &body fields) - `(within-definition (,useless-name make-font-info-accessors) - ,@(mapcar - #'(lambda (field) - (let* ((type (second field)) - (n (string (first field))) - (name (xintern 'font- n)) - (accessor (xintern 'font-info- n))) - `(defun ,name (font) - (declare (type font font)) - (declare (clx-values ,type)) - (,accessor (font-font-info font))))) - fields)))) - (make-font-info-accessors ignore - (direction draw-direction) - (min-char card16) - (max-char card16) - (min-byte1 card8) - (max-byte1 card8) - (min-byte2 card8) - (max-byte2 card8) - (all-chars-exist-p generalized-boolean) - (default-char card16) - (min-bounds vector) - (max-bounds vector) - (ascent int16) - (descent int16) - (properties font-props))) - -(defun font-property (font name) - (declare (type font font) - (type keyword name)) - (declare (clx-values (or null int32))) - (getf (font-properties font) name)) - -(macrolet ((make-mumble-equal (type) - ;; When cached, EQ works fine, otherwise test resource id's and displays - (let ((predicate (xintern type '-equal)) - (id (xintern type '-id)) - (dpy (xintern type '-display))) - (if (member type *clx-cached-types*) - `(within-definition (,type make-mumble-equal) - (declaim (inline ,predicate)) - (defun ,predicate (a b) (eq a b))) - `(within-definition (,type make-mumble-equal) - (defun ,predicate (a b) - (declare (type ,type a b)) - (and (= (,id a) (,id b)) - (eq (,dpy a) (,dpy b))))))))) - (make-mumble-equal window) - (make-mumble-equal pixmap) - (make-mumble-equal cursor) - (make-mumble-equal font) - (make-mumble-equal gcontext) - (make-mumble-equal colormap) - (make-mumble-equal drawable)) - -;;; -;;; Event-mask encode/decode functions -;;; Converts from keyword-lists to integer and back -;;; -(defun encode-mask (key-vector key-list key-type) - ;; KEY-VECTOR is a vector containg bit-position keywords. The position of the - ;; keyword in the vector indicates its bit position in the resulting mask - ;; KEY-LIST is either a mask or a list of KEY-TYPE - ;; Returns NIL when KEY-LIST is not a list or mask. - (declare (type (simple-array keyword (*)) key-vector) - (type (or mask32 list) key-list)) - (declare (clx-values (or mask32 null))) - (typecase key-list - (mask32 key-list) - (list (let ((mask 0)) - (dolist (key key-list mask) - (let ((bit (position key (the vector key-vector) :test #'eq))) - (unless bit - (x-type-error key key-type)) - (setq mask (logior mask (ash 1 bit))))))))) - -(defun decode-mask (key-vector mask) - (declare (type (simple-array keyword (*)) key-vector) - (type mask32 mask)) - (declare (clx-values list)) - (do ((m mask (ash m -1)) - (bit 0 (1+ bit)) - (len (length key-vector)) - (result nil)) - ((or (zerop m) (>= bit len)) result) - (declare (type mask32 m) - (fixnum bit len) - (list result)) - (when (oddp m) - (push (aref key-vector bit) result)))) - -(defun encode-event-mask (event-mask) - (declare (type event-mask event-mask)) - (declare (clx-values mask32)) - (or (encode-mask *event-mask-vector* event-mask 'event-mask-class) - (x-type-error event-mask 'event-mask))) - -(defun make-event-mask (&rest keys) - ;; This is only defined for core events. - ;; Useful for constructing event-mask, pointer-event-mask, device-event-mask. - (declare (type (clx-list event-mask-class) keys)) - (declare (clx-values mask32)) - (encode-mask *event-mask-vector* keys 'event-mask-class)) - -(defun make-event-keys (event-mask) - ;; This is only defined for core events. - (declare (type mask32 event-mask)) - (declare (clx-values (clx-list event-mask-class))) - (decode-mask *event-mask-vector* event-mask)) - -(defun encode-device-event-mask (device-event-mask) - (declare (type device-event-mask device-event-mask)) - (declare (clx-values mask32)) - (or (encode-mask *device-event-mask-vector* device-event-mask - 'device-event-mask-class) - (x-type-error device-event-mask 'device-event-mask))) - -(defun encode-modifier-mask (modifier-mask) - (declare (type modifier-mask modifier-mask)) - (declare (clx-values mask16)) - (or (and (eq modifier-mask :any) #x8000) - (encode-mask *state-mask-vector* modifier-mask 'modifier-key) - (x-type-error modifier-mask 'modifier-mask))) - -(defun encode-state-mask (state-mask) - (declare (type (or mask16 (clx-list state-mask-key)) state-mask)) - (declare (clx-values mask16)) - (or (encode-mask *state-mask-vector* state-mask 'state-mask-key) - (x-type-error state-mask '(or mask16 (clx-list state-mask-key))))) - -(defun make-state-mask (&rest keys) - ;; Useful for constructing modifier-mask, state-mask. - (declare (type (clx-list state-mask-key) keys)) - (declare (clx-values mask16)) - (encode-mask *state-mask-vector* keys 'state-mask-key)) - -(defun make-state-keys (state-mask) - (declare (type mask16 state-mask)) - (declare (clx-values (clx-list state-mask-key))) - (decode-mask *state-mask-vector* state-mask)) - -(defun encode-pointer-event-mask (pointer-event-mask) - (declare (type pointer-event-mask pointer-event-mask)) - (declare (clx-values mask32)) - (or (encode-mask *pointer-event-mask-vector* pointer-event-mask - 'pointer-event-mask-class) - (x-type-error pointer-event-mask 'pointer-event-mask))) diff --git a/src/eclx/compile-and-load.lisp b/src/eclx/compile-and-load.lisp deleted file mode 100644 index 5f5fce385..000000000 --- a/src/eclx/compile-and-load.lisp +++ /dev/null @@ -1,64 +0,0 @@ -;;; -*- Mode: Lisp; Package: USER; Base: 10; Syntax: Common-Lisp -*- - -(in-package "COMMON-LISP-USER") - -(pushnew :clx-debugging *features*) - - -;;; Aid function: - -(defun comf (file) - (let ((output-file - (compile-file - (merge-pathnames - (pathname file) - *load-pathname*)))) - (load output-file))) - -(defvar *clocc-root* - (pathname-directory *load-pathname*)) - -(setf (logical-pathname-translations "clocc") - `(("src;port;sys;**;*" "**/*") - ("**;*.*" "**/*.*"))) -;;; First compile and load port: - -(comf (make-pathname :directory '(:relative "clocc-port") :name "ext")) -(comf (make-pathname :directory '(:relative "clocc-port") :name "gray")) -(comf (make-pathname :directory '(:relative "clocc-port") :name "path")) -(comf (make-pathname :directory '(:relative "clocc-port") :name "sys")) -(comf (make-pathname :directory '(:relative "clocc-port") :name "net")) -(comf (make-pathname :directory '(:relative "clocc-port") :name "proc")) - - -;;; Then split-sequence - -(comf (make-pathname :directory '(:relative "cclan") :name "split-sequence")) - -;;; Then compile and load the true system: - -(dolist (file (list - "package" - "depdefs" - "clx" - "dependent" - "macros" ; these are just macros - "bufmac" ; these are just macros - "buffer" - "display" - "gcontext" - "input" - "requests" - "fonts" - "graphics" - "text" - "attributes" - "translate" - "keysyms" - "manager" - "image" - "resource")) - (comf file)) - - - diff --git a/src/eclx/debug/debug.lisp b/src/eclx/debug/debug.lisp deleted file mode 100644 index 69f3dd636..000000000 --- a/src/eclx/debug/debug.lisp +++ /dev/null @@ -1,77 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES; Patch-file:T -*- - -;;; CLX debugging code - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -;;; Created 04/09/87 14:30:41 by LaMott G. OREN - -(in-package :xlib) - -(export '(display-listen - readflush - check-buffer - check-finish - check-force - clear-next)) - -(defun display-listen (display) - (listen (display-input-stream display))) - -(defun readflush (display) - ;; Flushes Display's input stream, returning what was there - (let ((stream (display-input-stream display))) - (loop while (listen stream) collect (read-byte stream)))) - -;;----------------------------------------------------------------------------- -;; The following are useful display-after functions - -(defun check-buffer (display) - ;; Ensure the output buffer in display is correct - (with-buffer-output (display :length :none :sizes (8 16)) - (do* ((i 0 (+ i length)) - request - length) - ((>= i buffer-boffset) - (unless (= i buffer-boffset) - (warn "Buffer size ~d Requests end at ~d" buffer-boffset i))) - - (let ((buffer-boffset 0) - #+clx-overlapping-arrays - (buffer-woffset 0)) - (setq request (card8-get i)) - (setq length (* 4 (card16-get (+ i 2))))) - (when (zerop request) - (warn "Zero request in buffer") - (return nil)) - (when (zerop length) - (warn "Zero length in buffer") - (return nil))))) - -(defun check-finish (display) - (check-buffer display) - (display-finish-output display)) - -(defun check-force (display) - (check-buffer display) - (display-force-output display)) - -(defun clear-next (display) - ;; Never append requests - (setf (display-last-request display) nil)) - -;; End of file diff --git a/src/eclx/debug/describe.lisp b/src/eclx/debug/describe.lisp deleted file mode 100644 index 00371fc95..000000000 --- a/src/eclx/debug/describe.lisp +++ /dev/null @@ -1,1243 +0,0 @@ -;;; -*- Mode: Lisp; Package: XLIB; Syntax: COMMON-LISP; Base: 10; Lowercase: Yes; -*- - -;;; Describe X11 protocol requests - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -;;; Created 07/15/87 by LaMott G. OREN - -(in-package :xlib) - -(defparameter *request-parameters* (make-array (length *request-names*))) - -(defmacro x-request (name &rest fields) - (unless (zerop (mod (length fields) 3)) - (format t "~%Field length not a multiple of 3 for ~a" name)) - (let ((request (position name *request-names* :test #'string-equal))) - (if request - `(setf (aref *request-parameters* ,request) ',fields) - `(format t "~%~s isn't an X11 request name" ',name)))) - -(defun print-history-description (buffer &optional (start 0)) - ;; Display an output history - (reading-event (buffer) - (let ((request (card8-get start)) - (length (* 4 (card16-get (+ start 2)))) - (margin 5)) - (format t "~a (~d) length ~d" - (request-name request) request length) - (when (>= request (length *request-parameters*)) - (setq request 0)) - (do ((parms (aref *request-parameters* request) (cdddr parms)) - (j start)) - ((or (endp parms) (>= j length))) - (let ((len (first parms)) - (type (second parms)) - (doc (third parms)) - value) - (setq value (case len - (1 (card8-get j)) - (2 (card16-get j)) - (4 (card32-get j)))) - (format t "~%~v@t" margin) - (if value - (progn - (print-value j value type doc) - (incf j len)) - (progn - (format t "~2d ~10a ~a" - j type doc) - (case type - ((listofvalue listofcard32 listofatom) - (format t " Words:~%~v@t" margin) - (dotimes (k (floor (- length (- j start)) 4)) - (format t " ~d" (card32-get j)) - (incf j 4))) - (listofrectangle - (format t " Half-Words:~%~v@t" margin) - (dotimes (k (floor (- length (- j start)) 2)) - (format t " ~d" (card16-get j)) - (incf j 2))) - (x (when (integerp len) (incf j len))) ; Unused - (string8 - (format t " Bytes:~%~v@t" margin) - (dotimes (k (- length (- j start))) - (format t "~a" (int-char (card8-get j))) - (incf j))) - (otherwise - (format t " Bytes:~%~v@t" margin) - (dotimes (k (- length (- j start))) - (format t " ~d" (card8-get j)) - (incf j))))))))))) - -(defun print-value (i value type doc &aux temp) - (format t "~2d ~3d " i value) - (if (consp type) - (case (first type) - (bitmask (format t "~a" (nreverse (decode-mask (symbol-value (second type)) value))) - (setq type (car type))) - (member (if (null (setq temp (nth value (cdr type)))) - (format t "*****ERROR*****") - (format t "~a" temp)) - (setq type (car type)))) - (case type - ((window pixmap drawable cursor font gcontext colormap atom) - (format t "[#x~x]" value) - #+comment - (let ((temp (lookup-resource-id display value))) - (when (eq (first type) 'atom) - (setq temp (lookup-xatom display value))) - (when temp (format t " (~s)" (type-of temp))))) - (int16 (setq temp (card16->int16 value)) - (when (minusp temp) (format t "~d" temp))) - (otherwise - (when (and (numberp type) (not (= type value))) - (format t "*****ERROR*****"))))) - (format t "~30,10t ~10a ~a" type doc)) - -(x-request Error - 1 1 opcode - 1 CARD8 data - 2 8+n request-length - n LISTofBYTE data - ) - -(x-request CreateWindow - 1 1 opcode - 1 CARD8 depth - 2 8+n request-length - 4 WINDOW wid - 4 WINDOW parent - 2 INT16 x - 2 INT16 y - 2 CARD16 width - 2 CARD16 height - 2 CARD16 border-width - 2 (MEMBER CopyFromParent InputOutput InputOnly) class - 4 (OR (MEMBER CopyFromParent) VISUALID) visual - 4 (BITMASK *create-bitmask*) value-mask - 4n LISTofVALUE value-list - ) - -(defparameter *create-bitmask* - #(background-pixmap background-pixel border-pixmap border-pixel bit-gravity - win-gravity backing-store backing-planes backing-pixel override-redirect - save-under event-mask do-not-propagate-mask colormap cursor)) - -(x-request ChangeWindowAttributes - 1 2 opcode - 1 x unused - 2 3+n request-length - 4 WINDOW window - 4 (BITMASK *create-bitmask*) value-mask - 4n LISTofVALUE value-list - ) - -(x-request GetWindowAttributes - 1 3 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request DestroyWindow - 1 4 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request DestroySubwindows - 1 5 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request ChangeSaveSet - 1 6 opcode - 1 (MEMBER insert delete) mode - 2 2 request-length - 4 WINDOW window -) - -(x-request ReparentWindow - 1 7 opcode - 1 x unused - 2 4 request-length - 4 WINDOW window - 4 WINDOW parent - 2 INT16 x - 2 INT16 y -) - -(x-request MapWindow - 1 8 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request MapSubwindows - 1 9 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request UnmapWindow - 1 10 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request UnmapSubwindows - 1 11 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request ConfigureWindow - 1 12 opcode - 1 x unused - 2 3+n request-length - 4 WINDOW window - 2 BITMASK value-mask - 2 x unused - 4n LISTofVALUE value-list -) - -(x-request CirculateWindow - 1 13 opcode - 1 (MEMBER RaiseLowest LowerHighest) direction - 2 2 request-length - 4 WINDOW window -) - -(x-request GetGeometry - 1 14 opcode - 1 x unused - 2 2 request-length - 4 DRAWABLE drawable -) - -(x-request QueryTree - 1 15 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request InternAtom - 1 16 opcode - 1 BOOL only-if-exists - 2 |2+(n+p)/4| request-length - 2 n length-of-name - 2 x unused - n STRING8 name - p x unused -) - -(x-request GetAtomName - 1 17 opcode - 1 x unused - 2 2 request-length - 4 ATOM atom -) - -(x-request ChangeProperty - 1 18 opcode - 1 (MEMBER replace prepend append) mode - 2 |6+(n+p)/4| request-length - 4 WINDOW window - 4 ATOM property - 4 ATOM type - 1 CARD8 format - 3 x unused - 4 CARD32 length-of-data-in-format-units - n LISTofBYTE data - p x unused -) - -(x-request DeleteProperty - 1 19 opcode - 1 x unused - 2 3 request-length - 4 WINDOW window - 4 ATOM property -) - -(x-request GetProperty - 1 20 opcode - 1 BOOL delete - 2 6 request-length - 4 WINDOW window - 4 ATOM property - 4 (OR (MEMBER anypropertytype) ATOM) type - 4 CARD32 long-offset - 4 CARD32 long-length -) - -(x-request ListProperties - 1 21 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request SetSelectionOwner - 1 22 opcode - 1 x unused - 2 4 request-length - 4 (OR (MEMBER none) WINDOW) owner - 4 ATOM selection - 4 (OR (MEMBER currenttime) TIMESTAMP) time -) - -(x-request GetSelectionOwner - 1 23 opcode - 1 x unused - 2 2 request-length - 4 ATOM selection -) - -(x-request ConvertSelection - 1 24 opcode - 1 x unused - 2 6 request-length - 4 WINDOW requestor - 4 ATOM selection - 4 ATOM target - 4 (OR (MEMBER none) ATOM) property - 4 (OR (MEMBER currenttime) TIMESTAMP) time -) - -(x-request SendEvent - 1 25 opcode - 1 BOOL propagate - 2 11 request-length - 4 (OR (MEMBER pointerwindow inputfocus) WINDOW) destination - 4 SETofEVENT event-mask - 32 n event -) - -(x-request GrabPointer - 1 26 opcode - 1 BOOL owner-events - 2 6 request-length - 4 WINDOW grab-window - 2 SETofPOINTEREVENT event-mask - 1 (MEMBER Synchronous Asynchronous) pointer-mode - 1 (MEMBER Synchronous Asynchronous) keyboard-mode - 4 (OR (MEMBER none) WINDOW) confine-to - 4 (OR (MEMBER none) CURSOR) cursor - 4 (OR (MEMBER currenttime) TIMESTAMP) timestamp -) - -(x-request UngrabPointer - 1 27 opcode - 1 x unused - 2 2 request-length - 4 (OR (MEMBER currenttime) TIMESTAMP) time -) - -(x-request GrabButton - 1 28 opcode - 1 BOOL owner-events - 2 6 request-length - 4 WINDOW grab-window - 2 SETofPOINTEREVENT event-mask - 1 (MEMBER Synchronous Asynchronous) pointer-mode - 1 (MEMBER Synchronous Asynchronous) keyboard-mode - 4 (OR (MEMBER none) WINDOW) confine-to - 4 (OR (MEMBER none) CURSOR) cursor - 1 (OR (MEMBER anybutton) BUTTON)button - 1 x unused - 2 SETofKEYMASK modifiers -) - -(x-request UngrabButton - 1 29 opcode - 1 (OR (MEMBER anybutton) BUTTON) button - 2 3 request-length - 4 WINDOW grab-window - 2 SETofKEYMASK modifiers - 2 x unused -) - -(x-request ChangeActivePointerGrab - 1 30 opcode - 1 x unused - 2 4 request-length - 4 (OR (MEMBER none) CURSOR) cursor - 4 (OR (MEMBER currenttime) TIMESTAMP) time - 2 SETofPOINTEREVENT event-mask - 2 x unused -) - -(x-request GrabKeyboard - 1 31 opcode - 1 BOOL owner-events - 2 4 request-length - 4 WINDOW grab-window - 4 (OR (MEMBER currenttime) TIMESTAMP) time - 1 (MEMBER Synchronous Asynchronous) pointer-mode - 1 (MEMBER Synchronous Asynchronous) keyboard-mode - 2 x unused -) - -(x-request UngrabKeyboard - 1 32 opcode - 1 x unused - 2 2 request-length - 4 (OR (MEMBER currenttime) TIMESTAMP) time -) - -(x-request GrabKey - 1 33 opcode - 1 BOOL owner-events - 2 4 request-length - 4 WINDOW grab-window - 2 SETofKEYMASK modifiers - 1 (OR (MEMBER anykey) KEYCODE) key - 1 (MEMBER Synchronous Asynchronous) pointer-mode - 1 (MEMBER Synchronous Asynchronous) keyboard-mode - 3 x unused -) - -(x-request UngrabKey - 1 34 opcode - 1 (OR (MEMBER anykey) KEYCODE) key - 2 3 request-length - 4 WINDOW grab-window - 2 SETofKEYMASK modifiers - 2 x unused -) - -(x-request AllowEvents - 1 35 opcode - 1 (MEMBER AsyncPointer SyncPointer ReplayPointer AsyncKeyboard SyncKeyboard ReplayKeyboard) mode - 2 2 request-length - 4 (OR (MEMBER currenttime) TIMESTAMP) time -) - -(x-request GrabServer - 1 36 opcode - 1 x unused - 2 1 request-length -) - -(x-request UngrabServer - 1 37 opcode - 1 x unused - 2 1 request-length -) - -(x-request QueryPointer - 1 38 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request GetMotionEvents - 1 39 opcode - 1 x unused - 2 4 request-length - 4 WINDOW window - 4 (OR (MEMBER CURRENTTIME) TIMESTAMP) start - 4 (OR (MEMBER CURRENTTIME) TIMESTAMP) stop -) - -(x-request TranslateCoords - 1 40 opcode - 1 x unused - 2 4 request-length - 4 WINDOW src-window - 4 WINDOW dst-window - 2 INT16 src-x - 2 INT16 src-y -) - -(x-request WarpPointer - 1 41 opcode - 1 x unused - 2 6 request-length - 4 (OR (MEMBER none) WINDOW) src-window - 4 WINDOW dst-window - 2 INT16 src-x - 2 INT16 src-y - 2 CARD16 src-width - 2 CARD16 src-height - 2 INT16 dst-x - 2 INT16 dst-y -) - -(x-request SetInputFocus - 1 42 opcode - 1 (MEMBER none pointerroot parent) revert-to - 2 3 request-length - 4 (OR (MEMBER none pointerroot) WINDOW) focus - 4 (OR (MEMBER CURRENTTIME) TIMESTAMP) time -) - -(x-request GetInputFocus - 1 43 opcode - 1 x unused - 2 1 request-length -) - -(x-request QueryKeymap - 1 44 opcode - 1 x unused - 2 1 request-length -) - -(x-request OpenFont - 1 45 opcode - 1 x unused - 2 |3+(n+p)/4| request-length - 4 FONT fid - 2 n length-of-name - 2 x unused - n STRING8 name - p x unused -) - -(x-request CloseFont - 1 46 opcode - 1 x unused - 2 2 request-length - 4 FONT font -) - -(x-request QueryFont - 1 47 opcode - 1 x unused - 2 2 request-length - 4 FONTABLE font -) - -(x-request QueryTextExtents - 1 48 opcode - 1 BOOL odd-length-p - 2 |2+(2n+p)/4| request-length - 4 FONTABLE font - 2n STRING16 string - p x unused -) - -(x-request ListFonts - 1 49 opcode - 1 x unused - 2 |2+(n+p)/4| request-length - 2 CARD16 max-names - 2 n length-of-pattern - n STRING8 pattern - p x unused -) - -(x-request ListFontsWithInfo - 1 50 opcode - 1 x unused - 2 |2+(n+p)/4| request-length - 2 CARD16 max-names - 2 n length-of-pattern - n STRING8 pattern - p x unused -) - -(x-request SetFontPath - 1 51 opcode - 1 x unused - 2 |2+(n+p)/4| request-length - 2 CARD16 number-of-STRs-in-path - 2 x unused - n LISTofSTR path - p x unused -) - -(x-request GetFontPath - 1 52 opcode - 1 x unused - 2 1 request-list -) - -(x-request CreatePixmap - 1 53 opcode - 1 CARD8 depth - 2 4 request-length - 4 PIXMAP pid - 4 DRAWABLE drawable - 2 CARD16 width - 2 CARD16 height -) - -(x-request FreePixmap - 1 54 opcode - 1 x unused - 2 2 request-length - 4 PIXMAP pixmap -) - -(x-request CreateGC - 1 55 opcode - 1 x unused - 2 4+n request-length - 4 GCONTEXT cid - 4 DRAWABLE drawable - 4 (BITMASK *gc-bitmask*) value-mask - 4n LISTofVALUE value-list -) - -(defconstant *gc-bitmask* - #(function plane-mask foreground - background line-width line-style cap-style join-style - fill-style fill-rule tile stipple tile-stipple-x-origin - tile-stipple-y-origin font subwindow-mode graphics-exposures clip-x-origin - clip-y-origin clip-mask dash-offset dashes arc-mode)) - - -(x-request ChangeGC - 1 56 opcode - 1 x unused - 2 3+n request-length - 4 GCONTEXT gc - 4 (BITMASK *gc-bitmask*) value-mask - 4n LISTofVALUE value-list -) - -(x-request CopyGC - 1 57 opcode - 1 x unused - 2 4 request-length - 4 GCONTEXT src-gc - 4 GCONTEXT dst-gc - 4 (BITMASK *gc-bitmask*) value-mask -) - -(x-request SetDashes - 1 58 opcode - 1 x unused - 2 |3+(n+p)/4| request-length - 4 GCONTEXT gc - 2 CARD16 dash-offset - 2 n length-of-dashes - n LISTofCARD8 dashes - p x unused -) - -(x-request SetClipRectangles - 1 59 opcode - 1 (MEMBER UnSorted YSorted YXSorted YXBanded) ordering - 2 3+2n request-length - 4 GCONTEXT gc - 2 INT16 clip-x-origin - 2 INT16 clip-y-origin - 8n LISTofRECTANGLE rectangles -) - -(x-request FreeGC - 1 60 opcode - 1 x unused - 2 2 request-length - 4 GCONTEXT gc -) - -(x-request ClearToBackground - 1 61 opcode - 1 BOOL exposures - 2 4 request-length - 4 WINDOW window - 2 INT16 x - 2 INT16 y - 2 CARD16 width - 2 CARD16 height -) - -(x-request CopyArea - 1 62 opcode - 1 x unused - 2 7 request-length - 4 DRAWABLE src-drawable - 4 DRAWABLE dst-drawable - 4 GCONTEXT gc - 2 INT16 src-x - 2 INT16 src-y - 2 INT16 dst-x - 2 INT16 dst-y - 2 CARD16 width - 2 CARD16 height -) - -(x-request CopyPlane - 1 63 opcode - 1 x unused - 2 8 request-length - 4 DRAWABLE src-drawable - 4 DRAWABLE dst-drawable - 4 GCONTEXT gc - 2 INT16 src-x - 2 INT16 src-y - 2 INT16 dst-x - 2 INT16 dst-y - 2 CARD16 width - 2 CARD16 height - 4 CARD32 bit-plane -) - -(x-request PolyPoint - 1 64 opcode - 1 (MEMBER origin previous) coordinate-mode - 2 3+n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 4n LISTofPOINT points -) - -(x-request PolyLine - 1 65 opcode - 1 (MEMBER origin previous) coordinate-mode - 2 3+n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 4n LISTofPOINT points -) - -(x-request PolySegment - 1 66 opcode - 1 x unused - 2 3+2n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 8n LISTofSEGMENT segments -) - -(x-request PolyRectangle - 1 67 opcode - 1 x unused - 2 3+2n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 8n LISTofRECTANGLE rectangles -) - -(x-request PolyArc - 1 68 opcode - 1 x unused - 2 3+3n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 12n LISTofARC arcs -) - -(x-request FillPoly - 1 69 opcode - 1 x unused - 2 4+n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 1 (MEMBER complex nonconvex convex) shape - 1 (MEMBER origin previous) coordinate-mode - 2 x unused - 4n LISTofPOINT points -) - -(x-request PolyFillRectangle - 1 70 opcode - 1 x unused - 2 3+2n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 8n LISTofRECTANGLE rectangles -) - -(x-request PolyFillArc - 1 71 opcode - 1 x unused - 2 3+3n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 12n LISTofARC arcs -) - -(x-request PutImage - 1 72 opcode - 1 (bitmap xypixmap zpixmap) format - 2 |6+(n+p)/4| request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 2 CARD16 width - 2 CARD16 height - 2 INT16 dst-x - 2 INT16 dst-y - 1 CARD8 left-pad - 1 CARD8 depth - 2 x unused - n LISTofBYTE data - p x unused -) - -(x-request GetImage - 1 73 opcode - 1 (MEMBER error xypixmap zpixmap) format - 2 5 request-length - 4 DRAWABLE drawable - 2 INT16 x - 2 INT16 y - 2 CARD16 width - 2 CARD16 height - 4 CARD32 plane-mask -) - -(x-request PolyText8 - 1 74 opcode - 1 x unused - 2 |4+(n+p)/4| request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 2 INT16 x - 2 INT16 y - n LISTofTEXTITEM8 items - p x unused -) - -(x-request PolyText16 - 1 75 opcode - 1 x unused - 2 |4+(n+p)/4| request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 2 INT16 x - 2 INT16 y - n LISTofTEXTITEM16 items - p x unused -) - -(x-request ImageText8 - 1 76 opcode - 1 n length-of-string - 2 |4+(n+p)/4| request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 2 INT16 x - 2 INT16 y - n STRING8 string - p x unused -) - -(x-request ImageText16 - 1 77 opcode - 1 n number-of-CHAR2Bs-in-string - 2 |4+(2n+p)/4| request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 2 INT16 x - 2 INT16 y - 2n STRING16 string - p x unused -) - -(x-request CreateColormap - 1 78 opcode - 1 (MEMBER none all) alloc - 2 4 request-length - 4 COLORMAP mid - 4 WINDOW window - 4 VISUALID visual -) - -(x-request FreeColormap - 1 79 opcode - 1 x unused - 2 2 request-length - 4 COLORMAP cmap -) - -(x-request CopyColormapAndFree - 1 80 opcode - 1 x unused - 2 3 request-length - 4 COLORMAP mid - 4 COLORMAP src-cmap -) - -(x-request InstallColormap - 1 81 opcode - 1 x unused - 2 2 request-length - 4 COLORMAP cmap -) - -(x-request UninstallColormap - 1 82 opcode - 1 x unused - 2 2 request-length - 4 COLORMAP cmap -) - -(x-request ListInstalledColormaps - 1 83 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request AllocColor - 1 84 opcode - 1 x unused - 2 4 request-length - 4 COLORMAP cmap - 2 CARD16 red - 2 CARD16 green - 2 CARD16 blue - 2 x unused -) - -(x-request AllocNamedColor - 1 85 opcode - 1 x unused - 2 |3+(n+p)/4| request-length - 4 COLORMAP cmap - 2 n length-of-name - 2 x unused - n STRING8 name - p x unused -) - -(x-request AllocColorCells - 1 86 opcode - 1 BOOL contiguous - 2 3 request-length - 4 COLORMAP cmap - 2 CARD16 colors - 2 CARD16 planes -) - -(x-request AllocColorPlanes - 1 87 opcode - 1 BOOL contiguous - 2 4 request-length - 4 COLORMAP cmap - 2 CARD16 colors - 2 CARD16 reds - 2 CARD16 greens - 2 CARD16 blues -) - -(x-request FreeColors - 1 88 opcode - 1 x unused - 2 3+n request-length - 4 COLORMAP cmap - 4 CARD32 plane-mask - 4n LISTofCARD32 pixels -) - -(x-request StoreColors - 1 89 opcode - 1 x unused - 2 2+3n request-length - 4 COLORMAP cmap - 12n LISTofCOLORITEM items -) - -(x-request StoreNamedColor - 1 90 opcode - 1 color-mask do-red_do-green_do-blue - 2 |4+(n+p)/4| request-length - 4 COLORMAP cmap - 4 CARD32 pixel - 2 n length-of-name - 2 x unused - n STRING8 name - p x unused -) - -(x-request QueryColors - 1 91 opcode - 1 x unused - 2 2+n request-length - 4 COLORMAP cmap - 4n LISTofCARD32 pixels -) - -(x-request LookupColor - 1 92 opcode - 1 x unused - 2 |3+(n+p)/4| request-length - 4 COLORMAP cmap - 2 n length-of-name - 2 x unused - n STRING8 name - p x unused -) - -(x-request CreateCursor - 1 93 opcode - 1 x unused - 2 8 request-length - 4 CURSOR cid - 4 PIXMAP source - 4 (OR (MEMBER none) PIXMAP) mask - 2 CARD16 fore-red - 2 CARD16 fore-green - 2 CARD16 fore-blue - 2 CARD16 back-red - 2 CARD16 back-green - 2 CARD16 back-blue - 2 CARD16 x - 2 CARD16 y -) - -(x-request CreateGlyphCursor - 1 94 CreateGlyphCursor - 1 x unused - 2 8 request-length - 4 CURSOR cid - 4 FONT source-font - 4 (OR (MEMBER none) FONT) mask-font - 2 CARD16 source-char - 2 CARD16 mask-char - 2 CARD16 fore-red - 2 CARD16 fore-green - 2 CARD16 fore-blue - 2 CARD16 back-red - 2 CARD16 back-green - 2 CARD16 back-blue -) - -(x-request FreeCursor - 1 95 opcode - 1 x unused - 2 2 request-length - 4 CURSOR cursor -) - -(x-request RecolorCursor - 1 96 opcode - 1 x unused - 2 5 request-length - 4 CURSOR cursor - 2 CARD16 fore-red - 2 CARD16 fore-green - 2 CARD16 fore-blue - 2 CARD16 back-red - 2 CARD16 back-green - 2 CARD16 back-blue -) - -(x-request QueryBestSize - 1 97 opcode - 1 (MEMBER cursor tile stipple) class - 2 3 request-length - 4 DRAWABLE drawable - 2 CARD16 width - 2 CARD16 height -) - -(x-request QueryExtension - 1 98 opcode - 1 x unused - 2 |2+(n+p)/4| request-length - 2 n length-of-name - 2 x unused - n STRING8 name - p x unused -) - -(x-request ListExtensions - 1 99 opcode - 1 x unused - 2 1 request-length -) - -(x-request SetKeyboardMapping - 1 100 opcode - 1 n keycode-count - 2 2+nm request-length - 1 KEYCODE first-keycode - 1 m keysyms-per-keycode - 2 x unused - 4nm LISTofKEYSYM keysyms -) - -(x-request GetKeyboardMapping - 1 101 opcode - 1 x unused - 2 2 request-length - 1 KEYCODE first-keycode - 1 CARD8 count - 2 x unused -) - -(x-request ChangeKeyboardControl - 1 102 opcode - 1 x unused - 2 2+n request-length - 4 BITMASK value-mask - 4n LISTofVALUE value-list -) - -(x-request GetKeyboardControl - 1 103 opcode - 1 x unused - 2 1 request-length -) - -(x-request Bell - 1 104 opcode - 1 INT8 percent - 2 1 request-length -) - -(x-request ChangePointerControl - 1 105 opcode - 1 x unused - 2 3 request-length - 2 INT16 acceleration-numerator - 2 INT16 acceleration-denominator - 2 INT16 threshold - 1 BOOL do-acceleration - 1 BOOL do-threshold -) - -(x-request GetPointerControl - 1 106 GetPointerControl - 1 x unused - 2 1 request-length -) - -(x-request SetScreenSaver - 1 107 opcode - 1 x unused - 2 3 request-length - 2 INT16 timeout - 2 INT16 interval - 1 (MEMBER no yes default) prefer-blanking - 1 (MEMBER no yes default) allow-exposures - 2 x unused -) - -(x-request GetScreenSaver - 1 108 opcode - 1 x unused - 2 1 request-length -) - -(x-request ChangeHosts - 1 109 opcode - 1 (MEMBER insert delete) mode - 2 |2+(n+p)/4| request-length - 1 (MEMBER internet decnet chaos) family - 1 x unused - 2 CARD16 length-of-address - n LISTofCARD8 address - p x unused -) - -(x-request ListHosts - 1 110 opcode - 1 x unused - 2 1 request-length -) - -(x-request ChangeAccessControl - 1 111 opcode - 1 (MEMBER disable enable) mode - 2 1 request-length -) - -(x-request ChangeCloseDownMode - 1 112 opcode - 1 (MEMBER destroy retainpermanent retaintemporary) mode - 2 1 request-length -) - -(x-request KillClient - 1 113 opcode - 1 x unused - 2 2 request-length - 4 (MEMBER alltemporary CARD32) resource -) - -(x-request RotateProperties - 1 114 opcode - 1 x unused - 2 3+n request-length - 4 WINDOW window - 2 n number-of-properties - 2 INT16 delta - 4n LISTofATOM properties -) - -(x-request ForceScreenSaver - 1 115 ForceScreenSaver - 1 (MEMBER reset activate) mode - 2 1 request-length -) - -(x-request SetPointerMapping - 1 116 opcode - 1 n length-of-map - 2 |1+(n+p)/4| request-length - n LISTofCARD8 map - p x unused -) - -(x-request GetPointerMapping - 1 117 opcode - 1 x unused - 2 1 request-length -) - -(x-request SetModifierMapping - 1 118 opcode - 1 KEYCODE Lock - 2 5 request-length - 1 KEYCODE Shift_A - 1 KEYCODE Shift_B - 1 KEYCODE Control_A - 1 KEYCODE Control_B - 1 KEYCODE Mod1_A - 1 KEYCODE Mod1_B - 1 KEYCODE Mod2_A - 1 KEYCODE Mod2_B - 1 KEYCODE Mod3_A - 1 KEYCODE Mod3_B - 1 KEYCODE Mod4_A - 1 KEYCODE Mod4_B - 1 KEYCODE Mod5_A - 1 KEYCODE Mod5_B - 2 x unused -) - -(x-request GetModifierMapping - 1 119 opcode - 1 x unused - 2 1 request-length -) - -#+comment -(x-request NoOperation - 1 127 opcode - 1 x unused - 2 1 request-length -) -;; End of file diff --git a/src/eclx/debug/event-test.lisp b/src/eclx/debug/event-test.lisp deleted file mode 100644 index 5ded127ab..000000000 --- a/src/eclx/debug/event-test.lisp +++ /dev/null @@ -1,237 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: (XTEST (XLIB LISP)); Base: 10; Lowercase: Yes -*- - -(in-package :xtest :use '(:xlib :lisp)) - -(defstruct event - key ; Event key - display ; Display event was reported to - ;; The following are from the CLX event - code - state - time - event-window - root - drawable - window - child - parent - root-x - root-y - x - y - width - height - border-width - override-redirect-p - same-screen-p - configure-p - hint-p - kind - mode - keymap - focus-p - count - major - minor - above-sibling - place - atom - selection - requestor - target - property - colormap - new-p - installed-p - format - type - data - send-event-p - ) - -(defun process-input (display &optional timeout) - "Process one event" - (declare (type display display) ; The display (from initialize-clue) - (type (or null number) timeout) ; optional timeout in seconds - (values (or null character))) ; Returns NIL only if timeout exceeded - (let ((event (make-event))) - (setf (event-display event) display) - (macrolet ((set-event (&rest parameters) - `(progn ,@(mapcar #'(lambda (parm) - `(setf (,(intern (concatenate 'string - (string 'event-) - (string parm))) - event) ,parm)) - parameters))) - (dispatch (contact) - `(dispatch-event event event-key send-event-p ,contact))) - - (let ((result - (xlib:event-case (display :timeout timeout :force-output-p t) - ((:key-press :key-release :button-press :button-release) - (code time root window child root-x root-y x y - state same-screen-p event-key send-event-p) - (set-event code time root window child root-x root-y x y - state same-screen-p) - (dispatch window)) - - (:motion-notify - (hint-p time root window child root-x root-y x y - state same-screen-p event-key send-event-p) - (set-event hint-p time root window child root-x root-y x y - state same-screen-p) - (dispatch window)) - - ((:enter-notify :leave-notify) - (kind time root window child root-x root-y x y - state mode focus-p same-screen-p event-key send-event-p) - (set-event kind time root window child root-x root-y x y - state mode focus-p same-screen-p) - (dispatch window)) - - ((:focus-in :focus-out) - (kind window mode event-key send-event-p) - (set-event kind window mode) - (dispatch window)) - - (:keymap-notify - (window keymap event-key send-event-p) - (set-event window keymap) - (dispatch window)) - - (:exposure - (window x y width height count event-key send-event-p) - (set-event window x y width height count) - (dispatch window)) - - (:graphics-exposure - (drawable x y width height count major minor event-key send-event-p) - (set-event drawable x y width height count major minor) - (dispatch drawable)) - - (:no-exposure - (drawable major minor event-key send-event-p) - (set-event drawable major minor) - (dispatch drawable)) - - (:visibility-notify - (window state event-key send-event-p) - (set-event window state) - (dispatch window)) - - (:create-notify - (parent window x y width height border-width - override-redirect-p event-key send-event-p) - (set-event parent window x y width height border-width - override-redirect-p) - (dispatch parent)) - - (:destroy-notify - (event-window window event-key send-event-p) - (set-event event-window window) - (dispatch event-window)) - - (:unmap-notify - (event-window window configure-p event-key send-event-p) - (set-event event-window window configure-p) - (dispatch event-window)) - - (:map-notify - (event-window window override-redirect-p event-key send-event-p) - (set-event event-window window override-redirect-p) - (dispatch event-window)) - - (:map-request - (parent window event-key send-event-p) - (set-event parent window) - (dispatch parent)) - - (:reparent-notify - (event-window window parent x y override-redirect-p event-key send-event-p) - (set-event event-window window parent x y override-redirect-p) - (dispatch event-window)) - - (:configure-notify - (event-window window above-sibling x y width height border-width - override-redirect-p event-key send-event-p) - (set-event event-window window above-sibling x y width height - border-width override-redirect-p) - (dispatch event-window)) - - (:configure-request - (parent window above-sibling x y width height border-width event-key send-event-p) - (set-event parent window above-sibling x y width height border-width) - (dispatch parent)) - - (:gravity-notify - (event-window window x y event-key send-event-p) - (set-event event-window window x y) - (dispatch event-window)) - - (:resize-request - (window width height event-key send-event-p) - (set-event window width height) - (dispatch window)) - - (:circulate-notify - (event-window window parent place event-key send-event-p) - (set-event event-window window parent place) - (dispatch event-window)) - - (:circulate-request - (parent window place event-key send-event-p) - (set-event parent window place) - (dispatch parent)) - - (:property-notify - (window atom time state event-key send-event-p) - (set-event window atom time state) - (dispatch window)) - - (:selection-clear - (time window selection event-key send-event-p) - (set-event time window selection) - (dispatch window)) - - (:selection-request - (time window requestor selection target property event-key send-event-p) - (set-event time window requestor selection target property) - (dispatch window)) - - (:selection-notify - (time window selection target property event-key send-event-p) - (set-event time window selection target property) - (dispatch window)) - - (:colormap-notify - (window colormap new-p installed-p event-key send-event-p) - (set-event window colormap new-p installed-p) - (dispatch window)) - - (:client-message - (format window type data event-key send-event-p) - (set-event format window type data) - (dispatch window)) - - (:mapping-notify - (request start count) - (mapping-notify display request start count)) ;; Special case - ))) - (and result t))))) - -(defun event-case-test (display) - ;; Tests universality of display, event-key, event-code, send-event-p and event-window - (event-case (display) - ((key-press key-release button-press button-release motion-notify - enter-notify leave-notify focus-in focus-out keymap-notify - exposure graphics-exposure no-exposure visibility-notify - create-notify destroy-notify unmap-notify map-notify map-request - reparent-notify configure-notify gravity-notify resize-request - configure-request circulate-notify circulate-request property-notify - selection-clear selection-request selection-notify colormap-notify client-message) - (display event-key event-code send-event-p event-window) - (print (list display event-key event-code send-event-p event-window))) - (mapping-notify ;; mapping-notify doesn't have event-window - (display event-key event-code send-event-p) - (print (list display event-key event-code send-event-p))) - )) diff --git a/src/eclx/debug/keytrans.lisp b/src/eclx/debug/keytrans.lisp deleted file mode 100644 index 333c1efa7..000000000 --- a/src/eclx/debug/keytrans.lisp +++ /dev/null @@ -1,266 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;;; CLX keysym-translation test programs - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(defun list-missing-keysyms () - ;; Lists explorer characters which have no keysyms - (dotimes (i 256) - (unless (character->keysyms (int-char i)) - (format t "~%(define-keysym ~@c ~d)" (int-char i) i)))) - -(defun list-multiple-keysyms () - ;; Lists characters with more than one keysym - (dotimes (i 256) - (when (cdr (character->keysyms (int-char i))) - (format t "~%Character ~@c [~d] has keysyms" (int-char i) i) - (dolist (keysym (character->keysyms (int-char i))) - (format t " ~d ~d" (ldb (byte 8 8) keysym) (ldb (byte 8 0) keysym)))))) - -(defun check-lowercase-keysyms () - ;; Checks for keysyms with incorrect :lowercase parameters - (maphash #'(lambda (key mapping) - (let* ((value (car mapping)) - (char (keysym-mapping-object value))) - (if (and (characterp char) (both-case-p char) - (= (char-int char) (char-int (char-upcase char)))) - ;; uppercase alphabetic character - (unless (eq (keysym-mapping-lowercase value) - (char-int (char-downcase char))) - (let ((lowercase (keysym-mapping-lowercase value)) - (should-be (char-downcase char))) - (format t "~%Error keysym ~3d ~3d (~@c) has :Lowercase ~3d ~3d (~s) Should be ~3d ~3d (~@c)" - (ldb (byte 8 8) key) - (ldb (byte 8 0) key) - char - (and lowercase (ldb (byte 8 8) lowercase)) - (and lowercase (ldb (byte 8 0) lowercase)) - (int-char lowercase) - (ldb (byte 8 8) (char-int should-be)) - (ldb (byte 8 0) (char-int should-be)) - should-be))) - (when (keysym-mapping-lowercase value) - (let ((lowercase (keysym-mapping-lowercase value))) - (format t "~%Error keysym ~3d ~3d (~@c) has :lowercase ~3d ~3d (~@c) and shouldn't" - (ldb (byte 8 8) key) - (ldb (byte 8 0) key) - char - (and lowercase (ldb (byte 8 8) (char-int lowercase))) - (and lowercase (ldb (byte 8 0) (char-int lowercase))) - lowercase - )))))) - *keysym->character-map*)) - -(defun print-all-keysyms () - (let ((all nil)) - (maphash #'(lambda (key value) (push (cons key value) all)) *keysym->character-map*) - (setq all (sort all #'< :key #'car)) - (format t "~%~d keysyms:" (length all)) - - (dolist (keysym all) - (format t "~%~3d ~3d~{ ~s~}" - (ldb (byte 8 8) (car keysym)) - (ldb (byte 8 0) (car keysym)) - (cadr keysym)) - (dolist (mapping (cddr keysym)) - (format t "~%~7@t~{ ~s~}" mapping))))) - -(defun keysym-mappings (keysym &key display (mask-format #'identity)) - ;; Return all the keysym mappings for keysym. - ;; Returns a list of argument lists that are argument-lists to define-keysym. - ;; The following will re-create the mappings for KEYSYM: - ;; (dolist (mapping (keysym-mappings) keysym) - ;; (apply #'define-keysym mapping)) - (let ((mappings (append (and display (cdr (assoc keysym (display-keysym-translation display)))) - (gethash keysym *keysym->character-map*))) - (result nil)) - (dolist (mapping mappings) - (let ((object (keysym-mapping-object mapping)) - (translate (keysym-mapping-translate mapping)) - (lowercase (keysym-mapping-lowercase mapping)) - (modifiers (keysym-mapping-modifiers mapping)) - (mask (keysym-mapping-mask mapping))) - (push (append (list object keysym) - (when translate (list :translate translate)) - (when lowercase (list :lowercase lowercase)) - (when modifiers (list :modifiers (funcall mask-format modifiers))) - (when mask (list :mask (funcall mask-format mask)))) - result))) - (nreverse result))) - -#+comment -(defun print-keysym-mappings (keysym &optional display) - (format t "~%(keysym ~d ~3d) " - (ldb (byte 8 8) keysym) - (ldb (byte 8 0) keysym)) - (dolist (mapping (keysym-mappings keysym :display display)) - (format t "~16t~{ ~s~}~%" mapping))) - -(defun print-keysym-mappings (keysym &optional display) - (flet ((format-mask (mask) - (cond ((numberp mask) - `(make-state-mask ,@(make-state-keys mask))) - ((atom mask) mask) - (t `(list ,@(mapcar - #'(lambda (item) - (if (numberp item) - `(keysym ,(keysym-mapping-object - (car (gethash item *keysym->character-map*)))) - item)) - mask)))))) - (dolist (mapping (keysym-mappings keysym :display display :mask-format #'format-mask)) - (format t "~%(define-keysym ~s (keysym ~d ~3d)~{ ~s~})" - (car mapping) - (ldb (byte 8 8) keysym) - (ldb (byte 8 0) keysym) - (cdr mapping))))) - -(defun keysym-test (host) - ;; Server key-press Loop-back test - (let* ((display (open-display host)) - (width 400) - (height 400) - (screen (display-default-screen display)) - (black (screen-black-pixel screen)) - (white (screen-white-pixel screen)) - (win (create-window - :parent (screen-root screen) - :background black - :border white - :border-width 1 - :colormap (screen-default-colormap screen) - :bit-gravity :center - :event-mask '(:exposure :key-press) - :x 20 :y 20 - :width width :height height)) - #+comment - (gc (create-gcontext - :drawable win - :background black - :foreground white))) - (initialize-extensions display) - - (map-window win) ; Map the window - ;; Handle events - (unwind-protect - (dotimes (state 64) - (do ((code (display-min-keycode display) (1+ code))) - ((> code (display-max-keycode display))) - (send-event win :key-press '(:key-press) :code code :state state - :window win :root (screen-root screen) :time 0 - :x 1 :y 2 :root-x 10 :root-y 20 :same-screen-p t) - (event-case (display :force-output-p t :discard-p t) - (exposure ;; Come here on exposure events - (window count) - (when (zerop count) ;; Ignore all but the last exposure event - (clear-area window)) - nil) - (key-press (display code state) - (princ (keycode->character display code state)) - t)))) - (close-display display)))) - -(defun keysym-echo (host &optional keymap-p) - ;; Echo characters typed to a window - (let* ((display (open-display host)) - (width 400) - (height 400) - (screen (display-default-screen display)) - (black (screen-black-pixel screen)) - (white (screen-white-pixel screen)) - (win (create-window - :parent (screen-root screen) - :background black - :border white - :border-width 1 - :colormap (screen-default-colormap screen) - :bit-gravity :center - :event-mask '(:exposure :key-press :keymap-state :enter-window) - :x 20 :y 20 - :width width :height height)) - (gc (create-gcontext - :drawable win - :background black - :foreground white))) - (initialize-extensions display) - - (map-window win) ; Map the window - ;; Handle events - (unwind-protect - (event-case (display :force-output-p t :discard-p t) - (exposure ;; Come here on exposure events - (window count) - (when (zerop count) ;; Ignore all but the last exposure event - (clear-area window) - (draw-glyphs window gc 10 10 "Press to exit")) - nil) - (key-press (display code state) - (let ((char (keycode->character display code state))) - (format t "~%Code: ~s State: ~s Char: ~s" code state char) - ;; (PRINC char) (PRINC " ") - (when keymap-p - (let ((keymap (query-keymap display))) - (unless (character-in-map-p display char keymap) - (print "character-in-map-p failed") - (print-keymap keymap)))) - ;; (when (eql char #\0) (setq disp display) (break)) - (eql char #\escape))) - (keymap-notify (keymap) - (print "Keymap-notify") ;; we never get here. Server bug? - (when (keysym-in-map-p display 65 keymap) - (print "Found A")) - (when (character-in-map-p display #\b keymap) - (print "Found B"))) - (enter-notify (event-window) (format t "~%Enter ~s" event-window))) - (close-display display)))) - -(defun print-keymap (keymap) - (do ((j 32 (+ j 32))) ;; first 32 bits is for window - ((>= j 256)) - (format t "~% ~3d: " j) - (do ((i j (1+ i))) - ((>= i (+ j 32))) - (when (zerop (logand i 7)) - (princ " ")) - (princ (aref keymap i))))) - -(defun define-keysym-test (&key display printp - (modifiers (list (keysym :left-meta))) (mask :modifiers)) - (let* ((keysym 067) - (args `(baz ,keysym :modifiers ,modifiers ,@(and mask `(:mask ,mask)))) - (original (copy-tree (keysym-mappings keysym :display display)))) - (when printp (print-keysym-mappings 67) (terpri)) - (apply #'define-keysym args) - (when printp (print-keysym-mappings 67) (terpri)) - (let ((is (keysym-mappings keysym :display display)) - (should-be (append original (list args)))) - (unless (equal is should-be) - (cerror "Ignore" "define-keysym error. ~%is: ~s ~%Should be: ~s" is should-be))) - (apply #'undefine-keysym args) - (when printp (print-keysym-mappings 67) (terpri)) - (let ((is (keysym-mappings keysym :display display))) - (unless (equal is original) - (cerror "Ignore" "undefine-keysym error. ~%is: ~s ~%Should be: ~s" is original))))) - -(define-keysym-test) -(define-keysym-test :modifiers (make-state-mask :shift :lock)) -(define-keysym-test :modifiers (list :shift (keysym :left-meta) :control)) -(define-keysym-test :modifiers (make-state-mask :shift :lock) :mask nil) - diff --git a/src/eclx/debug/trace.lisp b/src/eclx/debug/trace.lisp deleted file mode 100644 index 276e2f56b..000000000 --- a/src/eclx/debug/trace.lisp +++ /dev/null @@ -1,456 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -;; Trace works by substituting trace functions for the display-write/input functions. -;; The trace functions maintain a database of requests sent to the server in the -;; trace-history display property. This is an alist of (id . byte-vector) where -;; id is the request number for writes, :reply for replies, :event for events and -;; :error for errors. The alist is kept in reverse order (most recent first) - -;; In a multiprocessing system is it very helpful to know what process wrote or -;; read certain requests. Thus I have modified the format of the trace-history -;; list. It is now an alist of: ((id . more-info) . byte-vector). -;; (more-info is a list returned by the trace-more-info function). -;; Also added the ability to suspend and resume tracing without destroying the -;; trace history. Renamed 'display-trace' to 'show-trace' to avoid confusion. -;; 7feb91 -- jdi - -;;; Created 09/14/87 by LaMott G. OREN - -(in-package :xlib) - -(eval-when (load eval) - (export '(trace-display - suspend-display-tracing - resume-display-tracing - untrace-display - show-trace - display-trace ; for backwards compatibility - describe-request - describe-event - describe-reply - describe-error - describe-trace))) - -(defun trace-display (display) - "Start a trace on DISPLAY. - If display is already being traced, this discards previous history. - See show-trace and describe-trace." - (declare (type display display)) - (unless (getf (display-plist display) 'write-function) - (bind-io-hooks display)) - (setf (display-trace-history display) nil) - t) - -(defun suspend-display-tracing (display) - "Tracing is suspended, but history is not cleared." - (if (getf (display-plist display) 'suspend-display-tracing) - (warn "Tracing is already suspend for ~s" display) - (progn - (unbind-io-hooks display) - (setf (getf (display-plist display) 'suspend-display-tracing) t)))) - -(defun resume-display-tracing (display) - "Used to resume tracing after suspending" - (if (getf (display-plist display) 'suspend-display-tracing) - (progn - (bind-io-hooks display) - (remf (display-plist display) 'suspend-display-tracing)) - (warn "Tracing was not suspended for ~s" display))) - -(defun untrace-display (display) - "Stop tracing DISPLAY." - (declare (type display display)) - (if (not (getf (display-plist display) 'suspend-display-tracing)) - (unbind-io-hooks display) - (remf (display-plist display) 'suspend-display-tracing)) - (setf (display-trace-history display) nil)) - -;; Assumes tracing is not already on. -(defun bind-io-hooks (display) - (let ((write-function (display-write-function display)) - (input-function (display-input-function display))) - ;; Save origional write/input functions so we can untrace - (setf (getf (display-plist display) 'write-function) write-function) - (setf (getf (display-plist display) 'input-function) input-function) - ;; Set new write/input functions that will record what's sent to the server - (setf (display-write-function display) - #'(lambda (vector display start end) - (trace-write-hook vector display start end) - (funcall write-function vector display start end))) - (setf (display-input-function display) - #'(lambda (display vector start end timeout) - (let ((result (funcall input-function - display vector start end timeout))) - (unless result - (trace-read-hook display vector start end)) - result))))) - -(defun unbind-io-hooks (display) - (let ((write-function (getf (display-plist display) 'write-function)) - (input-function (getf (display-plist display) 'input-function))) - (when write-function - (setf (display-write-function display) write-function)) - (when input-function - (setf (display-input-function display) input-function)) - (remf (display-plist display) 'write-function) - (remf (display-plist display) 'input-function))) - - -(defun byte-ref16 (vector index) - #+clx-little-endian - (logior (the card16 - (ash (the card8 (aref vector (index+ index 1))) 8)) - (the card8 - (aref vector index))) - #-clx-little-endian - (logior (the card16 - (ash (the card8 (aref vector index)) 8)) - (the card8 - (aref vector (index+ index 1))))) - -(defun byte-ref32 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (values card32)) - (declare-buffun) - #+clx-little-endian - (the card32 - (logior (the card32 - (ash (the card8 (aref a (index+ i 3))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i 2))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i 1))) 8)) - (the card8 - (aref a i)))) - #-clx-little-endian - (the card32 - (logior (the card32 - (ash (the card8 (aref a i)) 24)) - (the card29 - (ash (the card8 (aref a (index+ i 1))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i 2))) 8)) - (the card8 - (aref a (index+ i 3)))))) - -(defun trace-write-hook (vector display start end) - ;; Called only by buffer-flush. Start should always be 0 - (unless (zerop start) - (format *debug-io* "write-called with non-zero start: ~d" start)) - (let* ((history (display-trace-history display)) - (request-number (display-request-number display)) - (last-history (car history))) - ;; There may be several requests in the buffer, and the last one may be - ;; incomplete. The first one may be the completion of a previous request. - ;; We can detect incomplete requests by comparing the expected length of - ;; the last request with the actual length. - (when (and last-history (numberp (caar last-history))) - (let* ((last-length (index* 4 (byte-ref16 (cdr last-history) 2))) - (append-length (min (- last-length (length (cdr last-history))) - (- end start)))) - (when (plusp append-length) - ;; Last history incomplete - append to last - (setf (cdr last-history) - (concatenate '(vector card8) (cdr last-history) - (subseq vector start (+ start append-length)))) - (index-incf start append-length)))) - ;; Copy new requests into the history - (do* ((new-history nil) - (i start (+ i length)) - request - length) - ((>= i end) - ;; add in sequence numbers - (dolist (entry new-history) - (setf (caar entry) request-number) - (decf request-number)) - (setf (display-trace-history display) - (nconc new-history history))) - (setq request (aref vector i)) - (setq length (index* 4 (byte-ref16 vector (+ i 2)))) - (when (zerop length) - (warn "Zero length in buffer") - (return nil)) - (push (cons (cons 0 (trace-more-info display request vector - i (min (+ i length) end))) - (subseq vector i (min (+ i length) end))) new-history) - (when (zerop request) - (warn "Zero length in buffer") - (return nil))))) - -(defun trace-read-hook (display vector start end) - ;; Reading is done with an initial length of 32 (with start = 0) - ;; This may be followed by several other reads for long replies. - (let* ((history (display-trace-history display)) - (last-history (car history)) - (length (- end start))) - (when (and history (eq (caar last-history) :reply)) - (let* ((last-length (index+ 32 (index* 4 (byte-ref32 (cdr last-history) 4)))) - (append-length (min (- last-length (length (cdr last-history))) - (- end start)))) - (when (plusp append-length) - (setf (cdr last-history) - (concatenate '(vector card8) (cdr last-history) - (subseq vector start (+ start append-length)))) - (index-incf start append-length) - (index-decf length append-length)))) - - ;; Copy new requests into the history - (when (plusp length) - (let ((reply-type (case (aref vector start) (0 :error) (1 :reply) - (otherwise :event)))) - (push (cons (cons reply-type - (trace-more-info display reply-type vector start - (+ start length))) - (subseq vector start (+ start length))) - (display-trace-history display)))))) - -(defun trace-more-info (display request-id vector start end) - ;; Currently only returns current process. - #+allegro - (list mp::*current-process*)) - - -(defun show-trace (display &key length show-process) - "Display the trace history for DISPLAY. - The default is to show ALL history entries. - When the LENGTH parameter is used, only the last LENGTH entries are - displayed." - (declare (type display display)) - (dolist (hist (reverse (subseq (display-trace-history display) - 0 length))) - (let* ((id (caar hist)) - (more-info (cdar hist)) - (vector (cdr hist)) - (length (length vector)) - (request (aref vector 0))) - (format t "~%~5d " id) - (case id - (:error - (trace-error-print display more-info vector)) - (:event - (format t "~a (~d) Sequence ~d" - (if (< request (length *event-key-vector*)) - (aref *event-key-vector* request) - "Unknown") - request - (byte-ref16 vector 2)) - (when show-process - #+allegro - (format t ", Proc ~a" (mp::process-name (car more-info))))) - (:reply - (format t "To ~d length ~d" - (byte-ref16 vector 2) length) - (let ((actual-length (index+ 32 (index* 4 (byte-ref32 vector 4))))) - (unless (= length actual-length) - (format t " Should be ~d **************" actual-length))) - (when show-process - #+allegro - (format t ", Proc ~a" (mp::process-name (car more-info))))) - (otherwise - (format t "~a (~d) length ~d" - (request-name request) request length) - (when show-process - #+allegro - (format t ", Proc ~a" (mp::process-name (car more-info))))))))) - -;; For backwards compatibility -(defun display-trace (&rest args) - (apply 'show-trace args)) - -(defun find-trace (display type sequence &optional (number 0)) - (dolist (history (display-trace-history display)) - (when (and (symbolp (caar history)) - (= (logandc2 (aref (cdr history) 0) 128) type) - (= (byte-ref16 (cdr history) 2) sequence) - (minusp (decf number))) - (return (cdr history))))) - -(defun describe-error (display sequence) - "Describe the error associated with request SEQUENCE." - (let ((vector (find-trace display 0 sequence))) - (if vector - (progn - (terpri) - (trace-error-print display nil vector)) - (format t "Error with sequence ~d not found." sequence)))) - -(defun trace-error-print (display more-info vector - &optional (stream *standard-output*)) - (let ((event (allocate-event))) - ;; Copy into event from reply buffer - (buffer-replace (reply-ibuf8 event) - vector - 0 - *replysize*) - (reading-event (event) - (let* ((type (read-card8 0)) - (error-code (read-card8 1)) - (sequence (read-card16 2)) - (resource-id (read-card32 4)) - (minor-code (read-card16 8)) - (major-code (read-card8 10)) - (current-sequence (ldb (byte 16 0) (buffer-request-number display))) - (error-key - (if (< error-code (length *xerror-vector*)) - (aref *xerror-vector* error-code) - 'unknown-error)) - (params - (case error-key - ((colormap-error cursor-error drawable-error font-error gcontext-error - id-choice-error pixmap-error window-error) - (list :resource-id resource-id)) - (atom-error - (list :atom-id resource-id)) - (value-error - (list :value resource-id)) - (unknown-error - ;; Prevent errors when handler is a sequence - (setq error-code 0) - (list :error-code error-code))))) - type - (let ((condition - (apply #+lispm #'si:make-condition - #+allegro #'make-condition - #-(or lispm allegro) #'make-condition - error-key - :error-key error-key - :display display - :major major-code - :minor minor-code - :sequence sequence - :current-sequence current-sequence - params))) - (princ condition stream) - (deallocate-event event) - condition))))) - -(defun describe-request (display sequence) - "Describe the request with sequence number SEQUENCE" - #+ti (si:load-if "clx:debug;describe") - (let ((request (assoc sequence (display-trace-history display) - :test #'(lambda (item key) - (eql item (car key)))))) - (if (null request) - (format t "~%Request number ~d not found in trace history" sequence) - (let* ((vector (cdr request)) - (len (length vector)) - (hist (make-reply-buffer len))) - (buffer-replace (reply-ibuf8 hist) vector 0 len) - (print-history-description hist))))) - -(defun describe-reply (display sequence) - "Print the reply to request SEQUENCE. - (The current implementation doesn't print very pretty)" - (let ((vector (find-trace display 1 sequence)) - (*print-array* t)) - (if vector - (print vector) - (format t "~%Reply not found")))) - -(defun event-number (name) - (if (integerp name) - (let ((name (logandc2 name 128))) - (if (typep name '(integer 0 63)) - (aref *event-key-vector* name)) - name) - (position (string name) *event-key-vector* :test #'equalp :key #'string))) - -(defun describe-event (display name sequence &optional (number 0)) - "Describe the event with event-name NAME and sequence number SEQUENCE. -If there is more than one event, return NUMBER in the sequence." - (declare (type display display) - (type (or stringable (integer 0 63)) name) - (integer sequence)) - (let* ((event (event-number name)) - (vector (and event (find-trace display event sequence number)))) - (if (not event) - (format t "~%~s isn't an event name" name) - (if (not vector) - (if (and (plusp number) (setq vector (find-trace display event sequence 0))) - (do ((i 1 (1+ i)) - (last-vector)) - (nil) - (if (setq vector (find-trace display event sequence i)) - (setq last-vector vector) - (progn - (format t "~%Event number ~d not found, last event was ~d" - number (1- i)) - (return (trace-event-print display last-vector))))) - (format t "~%Event ~s not found" - (aref *event-key-vector* event))) - (trace-event-print display vector))))) - -(defun trace-event-print (display vector) - (let* ((event (allocate-event)) - (event-code (ldb (byte 7 0) (aref vector 0))) - (event-decoder (aref *event-handler-vector* event-code))) - ;; Copy into event from reply buffer - (setf (event-code event) event-code) - (buffer-replace (reply-ibuf8 event) - vector - 0 - *replysize*) - (prog1 (funcall event-decoder display event - #'(lambda (&rest args &key send-event-p &allow-other-keys) - (setq args (copy-list args)) - (remf args :display) - (remf args :event-code) - (unless send-event-p (remf args :send-event-p)) - args)) - (deallocate-event event)))) - -(defun describe-trace (display &optional length) - "Display the trace history for DISPLAY. - The default is to show ALL history entries. - When the LENGTH parameter is used, only the last LENGTH entries are - displayed." - (declare (type display display)) - #+ti (si:load-if "clx:debug;describe") - (dolist (hist (reverse (subseq (display-trace-history display) - 0 length))) - (let* ((id (car hist)) - (vector (cdr hist)) - (length (length vector))) - (format t "~%~5d " id) - (case id - (:error - (trace-error-print display nil vector)) - (:event - (let ((event (trace-event-print display vector))) - (when event (format t "from ~d ~{ ~s~}" - (byte-ref16 vector 2) event)))) - (:reply - (format t "To ~d length ~d" - (byte-ref16 vector 2) length) - (let ((actual-length (index+ 32 (index* 4 (byte-ref32 vector 4))))) - (unless (= length actual-length) - (format t " Should be ~d **************" actual-length))) - (let ((*print-array* t) - (*print-base* 16.)) - (princ " ") - (princ vector))) - (otherwise - (let* ((len (length vector)) - (hist (make-reply-buffer len))) - (buffer-replace (reply-ibuf8 hist) vector 0 len) - (print-history-description hist))))))) - -;; End of file diff --git a/src/eclx/debug/util.lisp b/src/eclx/debug/util.lisp deleted file mode 100644 index 7db6be640..000000000 --- a/src/eclx/debug/util.lisp +++ /dev/null @@ -1,167 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES; -*- - -;; CLX utilities - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -;;; Created 04/09/87 14:30:41 by LaMott G. OREN - -(in-package :xlib) - -(export '(display-root - display-black - display-white - report-events - describe-window - describe-gc - degree - radian - display-refresh - root-tree - window-tree)) - -(defun display-root (display) (screen-root (display-default-screen display))) -(defun display-black (display) (screen-black-pixel (display-default-screen display))) -(defun display-white (display) (screen-white-pixel (display-default-screen display))) - -(defun report-events (display) - (loop - (unless - (process-event display :handler #'(lambda (&rest args) (print args)) :discard-p t :timeout 0.001) - (return nil)))) - -(defun describe-window (window) - (macrolet ((da (attribute &key (transform 'progn) (format "~s")) - (let ((func (intern (concatenate 'string (string 'window-) - (string attribute)) 'xlib))) - `(format t "~%~22a ~?" ',attribute ,format (list (,transform (,func window)))))) - (dg (attribute &key (transform 'progn) (format "~s")) - (let ((func (intern (concatenate 'string (string 'drawable-) - (string attribute)) 'xlib))) - `(format t "~%~22a ~?" ',attribute ,format (list (,transform (,func window))))))) - (with-state (window) - (when (window-p window) - (da visual :format "#x~x") - (da class) - (da gravity) - (da bit-gravity) - (da backing-store) - (da backing-planes :format "#x~x") - (da backing-pixel) - (da save-under) - (da colormap) - (da colormap-installed-p) - (da map-state) - (da all-event-masks :transform make-event-keys :format "~{~<~%~1:;~s ~>~}") - (da event-mask :transform make-event-keys :format "~{~<~%~1:;~s ~>~}") - (da do-not-propagate-mask :transform make-event-keys :format "~{~<~%~1:;~s ~>~}") - (da override-redirect) - ) - (dg root) - (dg depth) - (dg x) - (dg y) - (dg width) - (dg height) - (dg border-width) - - ))) - -(defun describe-gc (gc) - (macrolet ((dgc (name &key (transform 'progn) (format "~s")) - (let ((func (intern (concatenate 'string (string 'gcontext-) - (string name)) 'xlib))) - `(format t "~%~22a ~?" ',name ,format (list (,transform (,func gc))))))) - (dgc function) - (dgc plane-mask) - (dgc foreground) - (dgc background) - (dgc line-width) - (dgc line-style) - (dgc cap-style) - (dgc join-style) - (dgc fill-style) - (dgc fill-rule) - (dgc tile) - (dgc stipple) - (dgc ts-x) - (dgc ts-y) - (dgc font) ;; See below - (dgc subwindow-mode) - (dgc exposures) - (dgc clip-x) - (dgc clip-y) -;; (dgc clip-ordering) - (dgc clip-mask) - (dgc dash-offset) - (dgc dashes) - (dgc arc-mode) - )) - -(defun degree (degrees) - (* degrees (/ pi 180))) - -(defun radian (radians) - (round (* radians (/ 180 pi)))) - -(defun display-refresh (host) - ;; Useful for when the system writes to the screen (sometimes scrolling!) - (let ((display (open-display host))) - (unwind-protect - (let ((screen (display-default-screen display))) - (let ((win (create-window :parent (screen-root screen) :x 0 :y 0 :override-redirect :on - :width (screen-width screen) :height (screen-height screen) - :background (screen-black-pixel screen)))) - (map-window win) - (display-finish-output display) - (unmap-window win) - (destroy-window win) - (display-finish-output display))) - (close-display display)))) - -(defun root-tree (host) - (let ((display (open-display host))) - (unwind-protect - (window-tree (screen-root (display-default-screen display))) - (close-display display))) - (values)) - -(defun window-tree (window &optional (depth 0)) - ;; Print the window tree and properties starting from WINDOW - ;; Returns a list of windows in the order that they are printed. - (declare (arglist window) - (type window window) - (values (list window))) - (let ((props (mapcar #'(lambda (prop) - (multiple-value-bind (data type format) - (get-property window prop) - (case type - (:string (setq data (coerce data 'string)))) - (list prop format type data))) - (list-properties window))) - (result (list window))) - (with-state (window) - (format t "~%~v@t#x~x~20,20t X~3d Y~3d W~4d H~3d ~s" depth (window-id window) - (drawable-x window) (drawable-y window) - (drawable-width window) (drawable-height window) - (window-map-state window))) - (dolist (prop props) - (format t "~%~v@t~{~s ~}" (+ depth 2) prop)) - (dolist (w (query-tree window)) - (setq result (nconc result (window-tree w (+ depth 2))))) - result)) - diff --git a/src/eclx/demo/bezier.lisp b/src/eclx/demo/bezier.lisp deleted file mode 100644 index fca439b00..000000000 --- a/src/eclx/demo/bezier.lisp +++ /dev/null @@ -1,39 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;;; CLX interface for Bezier Spline Extension. - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(export 'draw-curves) - -(define-extension "bezier") - -(defun draw-curves (drawable gcontext points) - ;; Draw Bezier splines on drawable using gcontext. - ;; Points are a list of (x0 y0 x1 y1 x2 y2 x3 y3) - (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence points)) - (let* ((display (drawable-display drawable)) - (opcode (extension-opcode display "bezier"))) - (with-buffer-request (display opcode :gc-force gcontext) - ((data card8) 1) ;; X_PolyBezier - The minor_opcode for PolyBezier - (drawable drawable) - (gcontext gcontext) - ((sequence :format int16) points)))) diff --git a/src/eclx/demo/beziertest.lisp b/src/eclx/demo/beziertest.lisp deleted file mode 100644 index dc5bb91a2..000000000 --- a/src/eclx/demo/beziertest.lisp +++ /dev/null @@ -1,81 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;;; CLX Bezier Spline Extension demo program - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(defun bezier-test (host &optional (pathname "/usr/X.V11R1/extensions/test/datafile")) - ;; Display the part picture in /extensions/test/datafile - (let* ((display (open-display host)) - (width 800) - (height 800) - (screen (display-default-screen display)) - (black (screen-black-pixel screen)) - (white (screen-white-pixel screen)) - (win (create-window - :parent (screen-root screen) - :background black - :border white - :border-width 1 - :colormap (screen-default-colormap screen) - :bit-gravity :center - :event-mask '(:exposure :key-press) - :x 20 :y 20 - :width width :height height)) - (gc (create-gcontext - :drawable win - :background black - :foreground white)) - (lines (make-array (* 500 4) :fill-pointer 0 :element-type 'card16)) - (curves (make-array (* 500 8) :fill-pointer 0 :element-type 'card16))) - ;; Read the data - (with-open-file (stream pathname) - (loop - (case (read-char stream nil :eof) - (#\l (dotimes (i 4) (vector-push-extend (read stream) lines))) - (#\b (dotimes (i 8) (vector-push-extend (read stream) curves))) - ((#\space #\newline #\tab)) - (otherwise (return))))) - ;; The data points were created to fit in a 2048x2048 square, - ;; this means scale_factor will always be small enough so that - ;; we don't need to worry about overflows. - (let ((factor (ash (min width height) 5))) - (dotimes (i (length lines)) - (setf (svref lines i) - (ash (* (svref lines i) factor) -16))) - (dotimes (i (length curves)) - (setf (svref curves i) - (ash (* (svref curves i) factor) -16)))) - - (map-window win) ; Map the window - ;; Handle events - (unwind-protect - (loop - (event-case (display :force-output-p t) - (exposure ;; Come here on exposure events - (window count) - (when (zerop count) ;; Ignore all but the last exposure event - (clear-area window) - (draw-segments win gc lines) - (draw-curves win gc curves) - (draw-glyphs win gc 10 10 "Press any key to exit") - ;; Returning non-nil causes event-case to exit - t)) - (key-press () (return-from bezier-test t)))) - (close-display display)))) diff --git a/src/eclx/demo/hello.lisp b/src/eclx/demo/hello.lisp deleted file mode 100644 index a3fbd88d8..000000000 --- a/src/eclx/demo/hello.lisp +++ /dev/null @@ -1,65 +0,0 @@ -;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*- - -(in-package :xlib) - -(defun hello-world (host &rest args &key (string "Hello World") (font "fixed")) - ;; CLX demo, says STRING using FONT in its own window on HOST - (let ((display nil) - (abort t)) - (unwind-protect - (progn - (setq display (open-display host)) - (multiple-value-prog1 - (let* ((screen (display-default-screen display)) - (black (screen-black-pixel screen)) - (white (screen-white-pixel screen)) - (font (open-font display font)) - (border 1) ; Minimum margin around the text - (width (+ (text-width font string) (* 2 border))) - (height (+ (max-char-ascent font) (max-char-descent font) (* 2 border))) - (x (truncate (- (screen-width screen) width) 2)) - (y (truncate (- (screen-height screen) height) 2)) - (window (create-window :parent (screen-root screen) - :x x :y y :width width :height height - :background black - :border white - :border-width 1 - :colormap (screen-default-colormap screen) - :bit-gravity :center - :event-mask '(:exposure :button-press))) - (gcontext (create-gcontext :drawable window - :background black - :foreground white - :font font))) - ;; Set window manager hints - (set-wm-properties window - :name 'hello-world - :icon-name string - :resource-name string - :resource-class 'hello-world - :command (list* 'hello-world host args) - :x x :y y :width width :height height - :min-width width :min-height height - :input :off :initial-state :normal) - (map-window window) ; Map the window - ;; Handle events - (event-case (display :discard-p t :force-output-p t) - (exposure ;; Come here on exposure events - (window count) - (when (zerop count) ;; Ignore all but the last exposure event - (with-state (window) - (let ((x (truncate (- (drawable-width window) width) 2)) - (y (truncate (- (+ (drawable-height window) - (max-char-ascent font)) - (max-char-descent font)) - 2))) - ;; Draw text centered in widnow - (clear-area window) - (draw-glyphs window gcontext x y string))) - ;; Returning non-nil causes event-case to exit - nil)) - (button-press () t))) ;; Pressing any mouse-button exits - (setq abort nil))) - ;; Ensure display is closed when done - (when display - (close-display display :abort abort))))) diff --git a/src/eclx/demo/menu.lisp b/src/eclx/demo/menu.lisp deleted file mode 100644 index 80bc08eee..000000000 --- a/src/eclx/demo/menu.lisp +++ /dev/null @@ -1,382 +0,0 @@ -;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*- - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1988 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - - -;;;----------------------------------------------------------------------------------+ -;;; | -;;; These functions demonstrate a simple menu implementation described in | -;;; Kimbrough, Kerry, "Windows to the Future", Lisp Pointers, Oct-Nov, 1987. | -;;; See functions JUST-SAY-LISP and POP-UP for demonstrations. | -;;; | -;;;----------------------------------------------------------------------------------+ - - - -(defstruct (menu) - "A simple menu of text strings." - (title "choose an item:") - item-alist ;((item-window item-string)) - window - gcontext - width - title-width - item-width - item-height - (geometry-changed-p t)) ;nil iff unchanged since displayed - - - -(defun create-menu (parent-window text-color background-color text-font) - (make-menu - ;; Create menu graphics context - :gcontext (CREATE-GCONTEXT :drawable parent-window - :foreground text-color - :background background-color - :font text-font) - ;; Create menu window - :window (CREATE-WINDOW - :parent parent-window - :class :input-output - :x 0 ;temporary value - :y 0 ;temporary value - :width 16 ;temporary value - :height 16 ;temporary value - :border-width 2 - :border text-color - :background background-color - :save-under :on - :override-redirect :on ;override window mgr when positioning - :event-mask (MAKE-EVENT-MASK :leave-window - :exposure)))) - - -(defun menu-set-item-list (menu &rest item-strings) - ;; Assume the new items will change the menu's width and height - (setf (menu-geometry-changed-p menu) t) - - ;; Destroy any existing item windows - (dolist (item (menu-item-alist menu)) - (DESTROY-WINDOW (first item))) - - ;; Add (item-window item-string) elements to item-alist - (setf (menu-item-alist menu) - (let (alist) - (dolist (item item-strings (nreverse alist)) - (push (list (CREATE-WINDOW - :parent (menu-window menu) - :x 0 ;temporary value - :y 0 ;temporary value - :width 16 ;temporary value - :height 16 ;temporary value - :background (GCONTEXT-BACKGROUND (menu-gcontext menu)) - :event-mask (MAKE-EVENT-MASK :enter-window - :leave-window - :button-press - :button-release)) - item) - alist))))) - -(defparameter *menu-item-margin* 4 - "Minimum number of pixels surrounding menu items.") - - -(defun menu-recompute-geometry (menu) - (when (menu-geometry-changed-p menu) - (let* ((menu-font (GCONTEXT-FONT (menu-gcontext menu))) - (title-width (TEXT-EXTENTS menu-font (menu-title menu))) - (item-height (+ (FONT-ASCENT menu-font) (FONT-DESCENT menu-font))) - (item-width 0) - (items (menu-item-alist menu)) - menu-width) - - ;; Find max item string width - (dolist (next-item items) - (setf item-width (max item-width - (TEXT-EXTENTS menu-font (second next-item))))) - - ;; Compute final menu width, taking margins into account - (setf menu-width (max title-width - (+ item-width *menu-item-margin* *menu-item-margin*))) - (let ((window (menu-window menu)) - (delta-y (+ item-height *menu-item-margin*))) - - ;; Update width and height of menu window - (WITH-STATE (window) - (setf (DRAWABLE-WIDTH window) menu-width - (DRAWABLE-HEIGHT window) (+ *menu-item-margin* - (* (1+ (length items)) - delta-y)))) - - ;; Update width, height, position of item windows - (let ((item-left (round (- menu-width item-width) 2)) - (next-item-top delta-y)) - (dolist (next-item items) - (let ((window (first next-item))) - (WITH-STATE (window) - (setf (DRAWABLE-HEIGHT window) item-height - (DRAWABLE-WIDTH window) item-width - (DRAWABLE-X window) item-left - (DRAWABLE-Y window) next-item-top))) - (incf next-item-top delta-y)))) - - ;; Map all item windows - (MAP-SUBWINDOWS (menu-window menu)) - - ;; Save item geometry - (setf (menu-item-width menu) item-width - (menu-item-height menu) item-height - (menu-width menu) menu-width - (menu-title-width menu) title-width - (menu-geometry-changed-p menu) nil)))) - - -(defun menu-refresh (menu) - (let* ((gcontext (menu-gcontext menu)) - (baseline-y (FONT-ASCENT (GCONTEXT-FONT gcontext)))) - - ;; Show title centered in "reverse-video" - (let ((fg (GCONTEXT-BACKGROUND gcontext)) - (bg (GCONTEXT-FOREGROUND gcontext))) - (WITH-GCONTEXT (gcontext :foreground fg :background bg) - (DRAW-IMAGE-GLYPHS - (menu-window menu) - gcontext - (round (- (menu-width menu) - (menu-title-width menu)) 2) ;start x - baseline-y ;start y - (menu-title menu)))) - - ;; Show each menu item (position is relative to item window) - (dolist (item (menu-item-alist menu)) - (DRAW-IMAGE-GLYPHS - (first item) gcontext - 0 ;start x - baseline-y ;start y - (second item))))) - - -(defun menu-choose (menu x y) - ;; Display the menu so that first item is at x,y. - (menu-present menu x y) - - (let ((items (menu-item-alist menu)) - (mw (menu-window menu)) - selected-item) - - ;; Event processing loop - (do () (selected-item) - (EVENT-CASE ((DRAWABLE-DISPLAY mw) :force-output-p t) - (:exposure (count) - - ;; Discard all but final :exposure then display the menu - (when (zerop count) (menu-refresh menu)) - t) - - (:button-release (event-window) - ;;Select an item - (setf selected-item (second (assoc event-window items))) - t) - - (:enter-notify (window) - ;;Highlight an item - (let ((position (position window items :key #'first))) - (when position - (menu-highlight-item menu position))) - t) - - (:leave-notify (window kind) - (if (eql mw window) - ;; Quit if pointer moved out of main menu window - (setf selected-item (when (eq kind :ancestor) :none)) - - ;; Otherwise, unhighlight the item window left - (let ((position (position window items :key #'first))) - (when position - (menu-unhighlight-item menu position)))) - t) - - (otherwise () - ;;Ignore and discard any other event - t))) - - ;; Erase the menu - (UNMAP-WINDOW mw) - - ;; Return selected item string, if any - (unless (eq selected-item :none) selected-item))) - - -(defun menu-highlight-item (menu position) - (let* ((box-margin (round *menu-item-margin* 2)) - (left (- (round (- (menu-width menu) (menu-item-width menu)) 2) - box-margin)) - (top (- (* (+ *menu-item-margin* (menu-item-height menu)) - (1+ position)) - box-margin)) - (width (+ (menu-item-width menu) box-margin box-margin)) - (height (+ (menu-item-height menu) box-margin box-margin))) - - ;; Draw a box in menu window around the given item. - (DRAW-RECTANGLE (menu-window menu) - (menu-gcontext menu) - left top - width height))) - -(defun menu-unhighlight-item (menu position) - ;; Draw a box in the menu background color - (let ((gcontext (menu-gcontext menu))) - (WITH-GCONTEXT (gcontext :foreground (gcontext-background gcontext)) - (menu-highlight-item menu position)))) - - -(defun menu-present (menu x y) - ;; Make sure menu geometry is up-to-date - (menu-recompute-geometry menu) - - ;; Try to center first item at the given location, but - ;; make sure menu is completely visible in its parent - (let ((menu-window (menu-window menu))) - (multiple-value-bind (tree parent) (QUERY-TREE menu-window) - (declare (ignore tree)) - (WITH-STATE (parent) - (let* ((parent-width (DRAWABLE-WIDTH parent)) - (parent-height (DRAWABLE-HEIGHT parent)) - (menu-height (+ *menu-item-margin* - (* (1+ (length (menu-item-alist menu))) - (+ (menu-item-height menu) *menu-item-margin*)))) - (menu-x (max 0 (min (- parent-width (menu-width menu)) - (- x (round (menu-width menu) 2))))) - (menu-y (max 0 (min (- parent-height menu-height) - (- y (round (menu-item-height menu) 2/3) - *menu-item-margin*))))) - (WITH-STATE (menu-window) - (setf (DRAWABLE-X menu-window) menu-x - (DRAWABLE-Y menu-window) menu-y))))) - - ;; Make menu visible - (MAP-WINDOW menu-window))) - -(defun just-say-lisp (host &optional (font-name "fixed")) - (let* ((display (OPEN-DISPLAY host)) - (screen (first (DISPLAY-ROOTS display))) - (fg-color (SCREEN-BLACK-PIXEL screen)) - (bg-color (SCREEN-WHITE-PIXEL screen)) - (nice-font (OPEN-FONT display font-name)) - (a-menu (create-menu (screen-root screen) ;the menu's parent - fg-color bg-color nice-font))) - - (setf (menu-title a-menu) "Please pick your favorite language:") - (menu-set-item-list a-menu "Fortran" "APL" "Forth" "Lisp") - - ;; Bedevil the user until he picks a nice programming language - (unwind-protect - (do (choice) - ((and (setf choice (menu-choose a-menu 100 100)) - (string-equal "Lisp" choice)))) - - (CLOSE-DISPLAY display)))) - - -(defun pop-up (host strings &key (title "Pick one:") (font "fixed")) - (let* ((display (OPEN-DISPLAY host)) - (screen (first (DISPLAY-ROOTS display))) - (fg-color (SCREEN-BLACK-PIXEL screen)) - (bg-color (SCREEN-WHITE-PIXEL screen)) - (font (OPEN-FONT display font)) - (parent-width 400) - (parent-height 400) - (parent (CREATE-WINDOW :parent (SCREEN-ROOT screen) - :override-redirect :on - :x 100 :y 100 - :width parent-width :height parent-height - :background bg-color - :event-mask (MAKE-EVENT-MASK :button-press - :exposure))) - (a-menu (create-menu parent fg-color bg-color font)) - (prompt "Press a button...") - (prompt-gc (CREATE-GCONTEXT :drawable parent - :foreground fg-color - :background bg-color - :font font)) - (prompt-y (FONT-ASCENT font)) - (ack-y (- parent-height (FONT-DESCENT font)))) - - (setf (menu-title a-menu) title) - (apply #'menu-set-item-list a-menu strings) - - ;; Present main window - (MAP-WINDOW parent) - - (flet ((display-centered-text - (window string gcontext height width) - (multiple-value-bind (w a d l r fa fd) (text-extents gcontext string) - (declare (ignore a d l r)) - (let ((box-height (+ fa fd))) - - ;; Clear previous text - (CLEAR-AREA window - :x 0 :y (- height fa) - :width width :height box-height) - - ;; Draw new text - (DRAW-IMAGE-GLYPHS window gcontext (round (- width w) 2) height string))))) - - (unwind-protect - (loop - (EVENT-CASE (display :force-output-p t) - - (:exposure (count) - - ;; Display prompt - (when (zerop count) - (display-centered-text - parent - prompt - prompt-gc - prompt-y - parent-width)) - t) - - (:button-press (x y) - - ;; Pop up the menu - (let ((choice (menu-choose a-menu x y))) - (if choice - (display-centered-text - parent - (format nil "You have selected ~a." choice) - prompt-gc - ack-y - parent-width) - - (display-centered-text - parent - "No selection...try again." - prompt-gc - ack-y - parent-width))) - t) - - (otherwise () - ;;Ignore and discard any other event - t))) - - (CLOSE-DISPLAY display))))) - diff --git a/src/eclx/demo/qix.lisp b/src/eclx/demo/qix.lisp deleted file mode 100644 index 28160c863..000000000 --- a/src/eclx/demo/qix.lisp +++ /dev/null @@ -1,97 +0,0 @@ -;;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- -;;;; -;;;; Title: The famous swirling vectors using CLX -;;;; Created: Wed Feb 14 15:51:39 1996 -;;;; Author: Gilbert Baumann -;;;; Copyright: None, since this code is not worth it. - -;;;; -- TODO -- -;;;; -;;;; o react on resize events -;;;; o possibly react on iconify events by stoping -;;;; o maybe pressing 'q' should terminate it -;;;; o window documentation line is needed -;;;; o maybe add a root window option -;;;; o or a spline option?! -;;;; - -(in-package :xlib) - -(defvar *offset* 3) -(defvar *delta* 6) - -(defun check-bounds (val del max) - (cond ((< val 0) (+ (random *delta*) *offset*)) - ((> val max) (- (+ (random *delta*) *offset*))) - (t del))) - -;; IHMO this is worth to be added to the standard. -(defun make-circular (x) (nconc x x)) - -(defstruct qix - lines dims deltas coords) - -(defun gen-qix (nlines width height) - (make-qix :lines (make-circular (make-list nlines)) - :dims (list width height width height) - :deltas (list #3=(+ *offset* (random *delta*)) #3# #3# #3#) - :coords (list #1=(random width) #2=(random height) #1# #2#) )) - -(defun step-qix (qix win gc white-pixel black-pixel) - (when (car (qix-lines qix)) - (setf (xlib:gcontext-foreground gc) white-pixel) - (apply #'xlib:draw-line win gc (car (qix-lines qix))) - (setf (xlib:gcontext-foreground gc) black-pixel)) - (map-into (qix-coords qix) #'+ (qix-coords qix) (qix-deltas qix)) - (map-into (qix-deltas qix) #'check-bounds - (qix-coords qix) (qix-deltas qix) (qix-dims qix)) - (apply #'xlib:draw-line win gc (qix-coords qix)) - ;; push 'em into - (unless (car (qix-lines qix)) (setf (car (qix-lines qix)) (make-list 4))) - (map-into (car (qix-lines qix)) #'identity (qix-coords qix)) - (setf (qix-lines qix) (cdr (qix-lines qix))) ) - -(defun draw-qix (dpy win gc width height white-pixel black-pixel - delay nqixs nlines) - (let ((qixs nil) (n nlines)) - (dotimes (k nqixs) (push (gen-qix nlines width height) qixs)) - (loop - (dolist (k qixs) - (step-qix k win gc white-pixel black-pixel)) - (xlib:display-force-output dpy) - (sleep delay) - (setq n (- n 1)) - (if (<= n 0) (return))))) - -(defun qix (&key host display dpy - (width 400) (height 400) (delay 0.05) (nqixs 3) (nlines 80)) - #+ignore (setf (values host display) (x-host-display)) - (let* ((dp1 (or dpy (xlib:open-display host))) ;:display display))) - (scr (first (xlib:display-roots dp1))) - (root-win (xlib:screen-root scr)) - (white-pixel (xlib:screen-white-pixel scr)) - (black-pixel (xlib:screen-black-pixel scr)) - (win (xlib:create-window :parent root-win :x 10 :y 10 - :width width :height height - :background white-pixel)) - (gcon (xlib:create-gcontext :drawable win - :foreground black-pixel - :background white-pixel))) - (xlib:map-window win) - (xlib:display-finish-output dp1) - (format t "~&Qix uses the following parameters:~% :dpy: ~s - :host ~s :display ~s - :width ~d :height ~d :delay ~f :nqixs ~d :nlines ~d~%" - dp1 host display width height delay nqixs nlines) - (draw-qix dp1 win gcon width height white-pixel black-pixel - delay nqixs nlines) - (xlib:unmap-window win) - (xlib:destroy-window win) - ;;clean-up - (unless dpy (xlib:close-display dp1)))) - -;; since we have no herald, simply dump it: -#+nil -(format t "~& The famous swirling vectors.~% - (xlib::qix :host :display :dpy :width :height :delay :nqixs :nlines) -~% Call (xlib::qix :host \"\") or (xlib::qix :host \"\" :delay 0).~%") diff --git a/src/eclx/demo/shape-test.lisp b/src/eclx/demo/shape-test.lisp deleted file mode 100644 index 779cc2136..000000000 --- a/src/eclx/demo/shape-test.lisp +++ /dev/null @@ -1,26 +0,0 @@ -;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*- -;;; Copyright BRIAN SPILSBURY -;;; Placed in the public domain, no warranty - -(in-package :xlib) - -(defun shape-test (&optional (host "")) - (let* ((d (xlib:open-display host)) - (s (first (xlib:display-roots d))) - (r (xlib:screen-root s)) - (w (xlib:create-window :x 0 :y 0 :parent r :width 100 :height 100)) - (p (xlib:create-pixmap :width 100 :height 100 :depth 1 :drawable w)) - (g (xlib:create-gcontext :drawable p :foreground 0))) - - (multiple-value-bind (b? bx by bw bh c? cx cy cw ch) (xlib:shape-query-extents w) - (print (list b? bx by bw bh c? cx cy cw ch))) - (setf (xlib:window-background w) 0) - (xlib:draw-rectangle p g 0 0 100 100 t) - (setf (xlib:gcontext-foreground g) 1) - (xlib:draw-arc p g 0 0 100 100 0.0 (* 2 pi) t) - (xlib:shape-combine-mask w xlib:shape-bounding 0 0 p xlib::shape-set) - (xlib:map-window w) - (xlib:display-finish-output d) - - (multiple-value-bind (b? bx by bw bh c? cx cy cw ch) (xlib:shape-query-extents w) - (print (list b? bx by bw bh c? cx cy cw ch))))) diff --git a/src/eclx/demo/zoid.lisp b/src/eclx/demo/zoid.lisp deleted file mode 100644 index 0a313059f..000000000 --- a/src/eclx/demo/zoid.lisp +++ /dev/null @@ -1,58 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;;; CLX interface for Trapezoid Extension. - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(export '(draw-filled-trapezoids - gcontext-trapezoid-alignment ;; Setf'able - )) - -(define-extension "ZoidExtension") - -(defun draw-filled-trapezoids (drawable gcontext points) - ;; Draw trapezoids on drawable using gcontext. - ;; Points are a list of either (y1 y2 y3 y4 x1 x2) ;; x-aligned - ;; or (x1 x2 x3 x4 y1 y2) ;; y-aligned - ;; Alignment is determined by the GCONTEXT [see gcontext-trapezoid-alignment] - ;; Alignment is set with the ALIGNMENT keyword argument, which may be - ;; :X, :Y, or NIL (use previous alignment) - (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence points)) - (let* ((display (drawable-display drawable)) - (opcode (extension-opcode display "ZoidExtension"))) - (with-buffer-request (display opcode :gc-force gcontext) - ((data card8) 1) ;; X_PolyFillZoid - (drawable drawable) - (gcontext gcontext) - ((sequence :format int16) points)))) - -(define-gcontext-accessor trapezoid-alignment :default :x - :set-function set-trapezoid-alignment) - -(defun set-trapezoid-alignment (gcontext alignment) - (declare (type (member :x :y) alignment)) - (let* ((display (gcontext-display gcontext)) - (opcode (extension-opcode display "ZoidExtension"))) - (with-buffer-request (display opcode) - ((data card8) 2) ;; X_SetZoidAlignment - (gcontext gcontext) - ((member8 %error :x :y) alignment)))) - diff --git a/src/eclx/depdefs.lisp b/src/eclx/depdefs.lisp deleted file mode 100644 index cc7d165a6..000000000 --- a/src/eclx/depdefs.lisp +++ /dev/null @@ -1,394 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;; This file contains some of the system dependent code for CLX - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; -#+cmu -(ext:file-comment - "$Header$") - -(in-package :xlib) - -;;;------------------------------------------------------------------------- -;;; Declarations -;;;------------------------------------------------------------------------- - -;;; CLX-VALUES value1 value2 ... -- Documents the values returned by the function. - -(declaim (declaration clx-values)) - -;;; ARGLIST arg1 arg2 ... -- Documents the arglist of the function. Overrides -;;; the documentation that might get generated by the real arglist of the -;;; function. - -(declaim (declaration arglist)) - -;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to -;;; indent calls to the function or macro containing the declaration. - -(declaim (declaration indentation)) - -;;;------------------------------------------------------------------------- -;;; Declaration macros -;;;------------------------------------------------------------------------- - -;;; WITH-VECTOR (variable type) &body body --- ensures the variable is a local -;;; and then does a type declaration and array register declaration -(defmacro with-vector ((var type) &body body) - `(let ((,var ,var)) - (declare (type ,type ,var)) - ,@body)) - -;;; WITHIN-DEFINITION (name type) &body body --- Includes definitions for -;;; Meta-. - -(defmacro within-definition ((name type) &body body) - (declare (ignore name type)) - `(progn ,@body)) - - -;;;------------------------------------------------------------------------- -;;; CLX can maintain a mapping from X server ID's to local data types. If -;;; one takes the view that CLX objects will be instance variables of -;;; objects at the next higher level, then PROCESS-EVENT will typically map -;;; from resource-id to higher-level object. In that case, the lower-level -;;; CLX mapping will almost never be used (except in rare cases like -;;; query-tree), and only serve to consume space (which is difficult to -;;; GC), in which case always-consing versions of the make-s will -;;; be better. Even when maps are maintained, it isn't clear they are -;;; useful for much beyond xatoms and windows (since almost nothing else -;;; ever comes back in events). -;;;-------------------------------------------------------------------------- -(defparameter *clx-cached-types* - '( drawable - window - pixmap -; gcontext - cursor - colormap - font)) - -(defmacro resource-id-map-test () - '#'eql) - ; (eq fixnum fixnum) is not guaranteed. -(defmacro atom-cache-map-test () - '#'eq) - -(defmacro keysym->character-map-test () - '#'eql) - -;;; You must define this to match the real byte order. It is used by -;;; overlapping array and image code. - -#+cmu -(eval-when (:compile-toplevel :execute :load-toplevel) - (ecase #.(c:backend-byte-order c:*backend*) - (:big-endian) - (:little-endian (pushnew :clx-little-endian *features*)))) - -(deftype buffer-bytes () `(simple-array (unsigned-byte 8) (*))) - -;;; This defines a type which is a subtype of the integers. -;;; This type is used to describe all variables that can be array indices. -;;; It is here because it is used below. -;;; This is inclusive because start/end can be 1 past the end. -(deftype array-index () `(integer 0 ,array-dimension-limit)) - - -;; this is the best place to define these? - - -(progn - -(defun make-index-typed (form) - (if (constantp form) form `(the array-index ,form))) - -(defun make-index-op (operator args) - `(the array-index - (values - ,(case (length args) - (0 `(,operator)) - (1 `(,operator - ,(make-index-typed (first args)))) - (2 `(,operator - ,(make-index-typed (first args)) - ,(make-index-typed (second args)))) - (otherwise - `(,operator - ,(make-index-op operator (subseq args 0 (1- (length args)))) - ,(make-index-typed (first (last args))))))))) - -(defmacro index+ (&rest numbers) (make-index-op '+ numbers)) -(defmacro index-logand (&rest numbers) (make-index-op 'logand numbers)) -(defmacro index-logior (&rest numbers) (make-index-op 'logior numbers)) -(defmacro index- (&rest numbers) (make-index-op '- numbers)) -(defmacro index* (&rest numbers) (make-index-op '* numbers)) - -(defmacro index1+ (number) (make-index-op '1+ (list number))) -(defmacro index1- (number) (make-index-op '1- (list number))) - -(defmacro index-incf (place &optional (delta 1)) - (make-index-op 'incf (list place delta))) -(defmacro index-decf (place &optional (delta 1)) - (make-index-op 'decf (list place delta))) - -(defmacro index-min (&rest numbers) (make-index-op 'min numbers)) -(defmacro index-max (&rest numbers) (make-index-op 'max numbers)) - -(defmacro index-floor (number divisor) - (make-index-op 'floor (list number divisor))) -(defmacro index-ceiling (number divisor) - (make-index-op 'ceiling (list number divisor))) -(defmacro index-truncate (number divisor) - (make-index-op 'truncate (list number divisor))) - -(defmacro index-mod (number divisor) - (make-index-op 'mod (list number divisor))) - -(defmacro index-ash (number count) - (make-index-op 'ash (list number count))) - -(defmacro index-plusp (number) `(plusp (the array-index ,number))) -(defmacro index-zerop (number) `(zerop (the array-index ,number))) -(defmacro index-evenp (number) `(evenp (the array-index ,number))) -(defmacro index-oddp (number) `(oddp (the array-index ,number))) - -(defmacro index> (&rest numbers) - `(> ,@(mapcar #'make-index-typed numbers))) -(defmacro index= (&rest numbers) - `(= ,@(mapcar #'make-index-typed numbers))) -(defmacro index< (&rest numbers) - `(< ,@(mapcar #'make-index-typed numbers))) -(defmacro index>= (&rest numbers) - `(>= ,@(mapcar #'make-index-typed numbers))) -(defmacro index<= (&rest numbers) - `(<= ,@(mapcar #'make-index-typed numbers))) - -) - - -;;;; Stuff for BUFFER definition - -(defconstant +replysize+ 32.) - -;; used in defstruct initializations to avoid compiler warnings -(defvar *empty-bytes* (make-sequence 'buffer-bytes 0)) -(declaim (type buffer-bytes *empty-bytes*)) - -(defstruct (reply-buffer (:conc-name reply-) (:constructor make-reply-buffer-internal) - (:copier nil) (:predicate nil)) - (size 0 :type array-index) ;Buffer size - ;; Byte (8 bit) input buffer - (ibuf8 *empty-bytes* :type buffer-bytes) - ;; Word (16bit) input buffer - (next nil :type (or null reply-buffer)) - (data-size 0 :type array-index) - ) - -(defconstant +buffer-text16-size+ 256) -(deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,+buffer-text16-size+))) - -;; These are here because. - -(defparameter *xlib-package* (find-package :xlib)) - -(defun xintern (&rest parts) - (intern (apply #'concatenate 'string (mapcar #'string parts)) *xlib-package*)) - -(defparameter *keyword-package* (find-package :keyword)) - -(defun kintern (name) - (intern (string name) *keyword-package*)) - -;;; Pseudo-class mechanism. - -(eval-when (:execute :compile-toplevel :load-toplevel) -(defvar *def-clx-class-use-defclass* - #+(and cmu pcl) '(XLIB:DRAWABLE XLIB:WINDOW XLIB:PIXMAP) - #+(and cmu (not pcl)) nil - #-(or cmu) nil - "Controls whether DEF-CLX-CLASS uses DEFCLASS. - If it is a list, it is interpreted by DEF-CLX-CLASS to be a list of type names - for which DEFCLASS should be used. - If it is not a list, then DEFCLASS is always used. - If it is NIL, then DEFCLASS is never used, since NIL is the empty list.") -) - -(defmacro def-clx-class ((name &rest options) &body slots) - (if (or (not (listp *def-clx-class-use-defclass*)) - (member name *def-clx-class-use-defclass*)) - (let ((clos-package (find-package :common-lisp)) - (constructor t) - (constructor-args t) - (include nil) - (print-function nil) - (copier t) - (predicate t)) - (dolist (option options) - (ecase (pop option) - (:constructor - (setf constructor (pop option)) - (setf constructor-args (if (null option) t (pop option)))) - (:include - (setf include (pop option))) - (:print-function - (setf print-function (pop option))) - (:copier - (setf copier (pop option))) - (:predicate - (setf predicate (pop option))))) - (flet ((cintern (&rest symbols) - (intern (apply #'concatenate 'simple-string - (mapcar #'symbol-name symbols)) - *package*)) - (kintern (symbol) - (intern (symbol-name symbol) (find-package :keyword))) - (closintern (symbol) - (intern (symbol-name symbol) clos-package))) - (when (eq constructor t) - (setf constructor (cintern 'make- name))) - (when (eq copier t) - (setf copier (cintern 'copy- name))) - (when (eq predicate t) - (setf predicate (cintern name '-p))) - (when include - (setf slots (append (get include 'def-clx-class) slots))) - (let* ((n-slots (length slots)) - (slot-names (make-list n-slots)) - (slot-initforms (make-list n-slots)) - (slot-types (make-list n-slots))) - (dotimes (i n-slots) - (let ((slot (elt slots i))) - (setf (elt slot-names i) (pop slot)) - (setf (elt slot-initforms i) (pop slot)) - (setf (elt slot-types i) (getf slot :type t)))) - `(progn - - (eval-when (:compile-toplevel :load-toplevel :execute) - (setf (get ',name 'def-clx-class) ',slots)) - - ;; From here down are the system-specific expansions: - - (within-definition (,name def-clx-class) - (,(closintern 'defclass) - ,name ,(and include `(,include)) - (,@(map 'list - #'(lambda (slot-name slot-initform slot-type) - `(,slot-name - :initform ,slot-initform :type ,slot-type - :accessor ,(cintern name '- slot-name) - ,@(when (and constructor - (or (eq constructor-args t) - (member slot-name - constructor-args))) - `(:initarg ,(kintern slot-name))) - )) - slot-names slot-initforms slot-types))) - ,(when constructor - (if (eq constructor-args t) - `(defun ,constructor (&rest args) - (apply #',(closintern 'make-instance) - ',name args)) - `(defun ,constructor ,constructor-args - (,(closintern 'make-instance) ',name - ,@(mapcan #'(lambda (slot-name) - (and (member slot-name slot-names) - `(,(kintern slot-name) ,slot-name))) - constructor-args))))) - ,(when predicate - `(defun ,predicate (object) - (typep object ',name))) - ,(when copier - `(,(closintern 'defmethod) ,copier ((.object. ,name)) - (,(closintern 'with-slots) ,slot-names .object. - (,(closintern 'make-instance) ',name - ,@(mapcan #'(lambda (slot-name) - `(,(kintern slot-name) ,slot-name)) - slot-names))))) - ,(when print-function - `(,(closintern 'defmethod) - ,(closintern 'print-object) - ((object ,name) stream) - (,print-function object stream 0)))))))) - `(within-definition (,name def-clx-class) - (defstruct (,name ,@options) - ,@slots)))) - -;; We need this here so we can define DISPLAY for CLX. -;; -;; This structure is :INCLUDEd in the DISPLAY structure. -;; Overlapping (displaced) arrays are provided for byte -;; half-word and word access on both input and output. -;; -(def-clx-class (buffer (:constructor nil) (:copier nil) (:predicate nil)) - ;; Lock for multi-processing systems - (lock (make-process-lock "CLX Buffer Lock")) - (output-stream nil :type (or null stream)) - ;; Buffer size - (size 0 :type array-index) - (request-number 0 :type (unsigned-byte 16)) - ;; Byte position of start of last request - ;; used for appending requests and error recovery - (last-request nil :type (or null array-index)) - ;; Byte position of start of last flushed request - (last-flushed-request nil :type (or null array-index)) - ;; Current byte offset - (boffset 0 :type array-index) - ;; Byte (8 bit) output buffer - (obuf8 *empty-bytes* :type buffer-bytes) - ;; Holding buffer for 16-bit text - (tbuf16 (make-sequence 'buffer-text16 +buffer-text16-size+ :initial-element 0)) - ;; Probably EQ to Output-Stream - (input-stream nil :type (or null stream)) - - ;; T when the host connection has gotten errors - (dead nil :type (or null (not null))) - ;; T makes buffer-flush a noop. Manipulated with with-buffer-flush-inhibited. - (flush-inhibit nil :type (or null (not null))) - - ;; Change these functions when using shared memory buffers to the server - ;; Function to call when writing the buffer - (write-function 'buffer-write-default) - ;; Function to call when flushing the buffer - (force-output-function 'buffer-force-output-default) - ;; Function to call when closing a connection - (close-function 'buffer-close-default) - ;; Function to call when reading the buffer - (input-function 'buffer-read-default) - ;; Function to call to wait for data to be input - (input-wait-function 'buffer-input-wait-default) - ;; Function to call to listen for input data - (listen-function 'buffer-listen-default) - - ) - -;;----------------------------------------------------------------------------- -;; Image stuff -;;----------------------------------------------------------------------------- - -(defconstant +image-bit-lsb-first-p+ - #+clx-little-endian t - #-clx-little-endian nil) - -(defconstant +image-byte-lsb-first-p+ - #+clx-little-endian t - #-clx-little-endian nil) - -(defconstant +image-unit+ 32) - -(defconstant +image-pad+ 32) - diff --git a/src/eclx/dependent.lisp b/src/eclx/dependent.lisp deleted file mode 100644 index a40ad4ed2..000000000 --- a/src/eclx/dependent.lisp +++ /dev/null @@ -1,1460 +0,0 @@ -;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- - -;; This file contains some of the system dependent code for CLX - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; -#+cmu -(ext:file-comment - "$Header$") - -(in-package :xlib) - -(proclaim '(declaration array-register)) - -#+cmu -(setf (getf ext:*herald-items* :xlib) - `(" CLX X Library " ,*version*)) - -;;; The size of the output buffer. Must be a multiple of 4. -(defparameter *output-buffer-size* 8192) - -;;; Number of seconds to wait for a reply to a server request -(defparameter *reply-timeout* nil) - -#-(or (not clx-little-endian)) -(progn - (defconstant +word-0+ 0) - (defconstant +word-1+ 1) - - (defconstant +long-0+ 0) - (defconstant +long-1+ 1) - (defconstant +long-2+ 2) - (defconstant +long-3+ 3)) - -#-clx-little-endian -(progn - (defconstant +word-0+ 1) - (defconstant +word-1+ 0) - - (defconstant +long-0+ 3) - (defconstant +long-1+ 2) - (defconstant +long-2+ 1) - (defconstant +long-3+ 0)) - -;;; Set some compiler-options for often used code - -(eval-when (:execute :compile-toplevel :load-toplevel) - - (defconstant +buffer-speed+ #+clx-debugging 1 #-clx-debugging 3 - "Speed compiler option for buffer code.") - (defconstant +buffer-safety+ #+clx-debugging 3 #-clx-debugging 0 - "Safety compiler option for buffer code.") - - (defun declare-bufmac () - `(declare (optimize (speed ,+buffer-speed+) (safety ,+buffer-safety+)))) - -;;; It's my impression that in lucid there's some way to make a declaration -;;; called fast-entry or something that causes a function to not do some -;;; checking on args. Sadly, we have no lucid manuals here. If such a -;;; declaration is available, it would be a good idea to make it here when -;;; +buffer-speed+ is 3 and +buffer-safety+ is 0. - (defun declare-buffun () - #+clx-debugging - '(declare (optimize (speed 0) (safety 3))) - #-clx-debugging - `(declare (optimize (speed ,+buffer-speed+) (safety ,+buffer-safety+)))) - - ) - -(declaim (inline card8->int8 int8->card8 - card16->int16 int16->card16 - card32->int32 int32->card32)) - - -(progn - - (defun card8->int8 (x) - (declare (type card8 x)) - (declare (clx-values int8)) - #.(declare-buffun) - (the int8 (if (logbitp 7 x) - (the int8 (- x #x100)) - x))) - - (defun int8->card8 (x) - (declare (type int8 x)) - (declare (clx-values card8)) - #.(declare-buffun) - (the card8 (ldb (byte 8 0) x))) - - (defun card16->int16 (x) - (declare (type card16 x)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 (if (logbitp 15 x) - (the int16 (- x #x10000)) - x))) - - (defun int16->card16 (x) - (declare (type int16 x)) - (declare (clx-values card16)) - #.(declare-buffun) - (the card16 (ldb (byte 16 0) x))) - - (defun card32->int32 (x) - (declare (type card32 x)) - (declare (clx-values int32)) - #.(declare-buffun) - (the int32 (if (logbitp 31 x) - (the int32 (- x #x100000000)) - x))) - - (defun int32->card32 (x) - (declare (type int32 x)) - (declare (clx-values card32)) - #.(declare-buffun) - (the card32 (ldb (byte 32 0) x))) - - ) - -(declaim (inline aref-card8 aset-card8 aref-int8 aset-int8)) - - -(progn - - (defun aref-card8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card8)) - #.(declare-buffun) - (the card8 (aref a i))) - - (defun aset-card8 (v a i) - (declare (type card8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a i) v)) - - (defun aref-int8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int8)) - #.(declare-buffun) - (card8->int8 (aref a i))) - - (defun aset-int8 (v a i) - (declare (type int8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a i) (int8->card8 v))) - - ) - - -(progn - - (defun aref-card16 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card16)) - #.(declare-buffun) - (the card16 - (logior (the card16 - (ash (the card8 (aref a (index+ i +word-1+))) 8)) - (the card8 - (aref a (index+ i +word-0+)))))) - - (defun aset-card16 (v a i) - (declare (type card16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) - v) - - (defun aref-int16 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 - (logior (the int16 - (ash (the int8 (aref-int8 a (index+ i +word-1+))) 8)) - (the card8 - (aref a (index+ i +word-0+)))))) - - (defun aset-int16 (v a i) - (declare (type int16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) - v) - - (defun aref-card32 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card32)) - #.(declare-buffun) - (the card32 - (logior (the card32 - (ash (the card8 (aref a (index+ i +long-3+))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i +long-2+))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i +long-1+))) 8)) - (the card8 - (aref a (index+ i +long-0+)))))) - - (defun aset-card32 (v a i) - (declare (type card32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) - (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) - (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) - v) - - (defun aref-int32 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int32)) - #.(declare-buffun) - (the int32 - (logior (the int32 - (ash (the int8 (aref-int8 a (index+ i +long-3+))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i +long-2+))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i +long-1+))) 8)) - (the card8 - (aref a (index+ i +long-0+)))))) - - (defun aset-int32 (v a i) - (declare (type int32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) - (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) - (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) - v) - - (defun aref-card29 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card29)) - #.(declare-buffun) - (the card29 - (logior (the card29 - (ash (the card8 (aref a (index+ i +long-3+))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i +long-2+))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i +long-1+))) 8)) - (the card8 - (aref a (index+ i +long-0+)))))) - - (defun aset-card29 (v a i) - (declare (type card29 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) - (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) - (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) - v) - - ) - -(defsetf aref-card8 (a i) (v) - `(aset-card8 ,v ,a ,i)) - -(defsetf aref-int8 (a i) (v) - `(aset-int8 ,v ,a ,i)) - -(defsetf aref-card16 (a i) (v) - `(aset-card16 ,v ,a ,i)) - -(defsetf aref-int16 (a i) (v) - `(aset-int16 ,v ,a ,i)) - -(defsetf aref-card32 (a i) (v) - `(aset-card32 ,v ,a ,i)) - -(defsetf aref-int32 (a i) (v) - `(aset-int32 ,v ,a ,i)) - -(defsetf aref-card29 (a i) (v) - `(aset-card29 ,v ,a ,i)) - -;;; Other random conversions - -(defun rgb-val->card16 (value) - ;; Short floats are good enough - (declare (type rgb-val value)) - (declare (clx-values card16)) - #.(declare-buffun) - ;; Convert VALUE from float to card16 - (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff))))) - -(defun card16->rgb-val (value) - ;; Short floats are good enough - (declare (type card16 value)) - (declare (clx-values short-float)) - #.(declare-buffun) - ;; Convert VALUE from card16 to float - (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff)))) - -(defun radians->int16 (value) - ;; Short floats are good enough - (declare (type angle value)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0))))) - -(defun int16->radians (value) - ;; Short floats are good enough - (declare (type int16 value)) - (declare (clx-values short-float)) - #.(declare-buffun) - (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float)))) - - -;;----------------------------------------------------------------------------- -;; Character transformation -;;----------------------------------------------------------------------------- - - -;;; This stuff transforms chars to ascii codes in card8's and back. -;;; You might have to hack it a little to get it to work for your machine. - -(declaim (inline char->card8 card8->char)) - -(macrolet ((char-translators () - (let ((alist - `(;; The normal ascii codes for the control characters. - ,@`((#\Return . 13) - (#\Linefeed . 10) - (#\Rubout . 127) - (#\Page . 12) - (#\Tab . 9) - (#\Backspace . 8) - (#\Newline . 10) - (#\Space . 32)) - - ;; The rest of the common lisp charater set with the normal - ;; ascii codes for them. - (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) - (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) - (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) - (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) - (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) - (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) - (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) - (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) - (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) - (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) - (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) - (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) - (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) - (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) - (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) - (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) - (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) - (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) - (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) - (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) - (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) - (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) - (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) - (#\} . 125) (#\~ . 126)))) - (cond ((dolist (pair alist nil) - (when (not (= (char-code (car pair)) (cdr pair))) - (return t))) - `(progn - (defconstant +char-to-card8-translation-table+ - ',(let ((array (make-array - (let ((max-char-code 255)) - (dolist (pair alist) - (setq max-char-code - (max max-char-code - (char-code (car pair))))) - (1+ max-char-code)) - :element-type 'card8))) - (dotimes (i (length array)) - (setf (aref array i) (mod i 256))) - (dolist (pair alist) - (setf (aref array (char-code (car pair))) - (cdr pair))) - array)) - (defconstant +card8-to-char-translation-table+ - ',(let ((array (make-array 256))) - (dotimes (i (length array)) - (setf (aref array i) (code-char i))) - (dolist (pair alist) - (setf (aref array (cdr pair)) (car pair))) - array)) - (progn - (defun char->card8 (char) - (declare (type base-char char)) - #.(declare-buffun) - (the card8 (aref (the (simple-array card8 (*)) - +char-to-card8-translation-table+) - (the array-index (char-code char))))) - (defun card8->char (card8) - (declare (type card8 card8)) - #.(declare-buffun) - (the base-char - (or (aref (the simple-vector +card8-to-char-translation-table+) - card8) - (error "Invalid CHAR code ~D." card8)))) - ) - (dotimes (i 256) - (unless (= i (char->card8 (card8->char i))) - (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" - (list i - (card8->char i) - (char->card8 (card8->char i)))) - (return nil))) - (dotimes (i (length +char-to-card8-translation-table+)) - (let ((char (code-char i))) - (unless (eql char (card8->char (char->card8 char))) - (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S" - (list char - (char->card8 char) - (card8->char (char->card8 char)))) - (return nil)))))) - (t - `(progn - (defun char->card8 (char) - (declare (type base-char char)) - #.(declare-buffun) - (the card8 (char-code char))) - (defun card8->char (card8) - (declare (type card8 card8)) - #.(declare-buffun) - (the base-char (code-char card8))) - )))))) - (char-translators)) - -;;----------------------------------------------------------------------------- -;; Process Locking -;; -;; Common-Lisp doesn't provide process locking primitives, so we define -;; our own here, based on Zetalisp primitives. Holding-Lock is very -;; similar to with-lock on The TI Explorer, and a little more efficient -;; than with-process-lock on a Symbolics. -;;----------------------------------------------------------------------------- - -;;; MAKE-PROCESS-LOCK: Creating a process lock. - -(defun make-process-lock (name) - #-(or sbcl clisp ecl) - (port::make-lock :name name)) - - -;;; HOLDING-LOCK: Execute a body of code with a lock held. - -;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN -;;; passes its timeout to the holding-lock macro, so any timeout you want to -;;; work for event-listen you should do for holding-lock. - -(defmacro holding-lock ((lock display &optional (whostate "CLX wait") - &key timeout) - &body body) - (declare (ignore display whostate timeout)) - #+ecl - `(progn ,@body) - #-ecl - `(port:with-lock (,lock) - ,@body)) - - -;;; WITHOUT-ABORTS - -;;; If you can inhibit asynchronous keyboard aborts inside the body of this -;;; macro, then it is a good idea to do this. This macro is wrapped around -;;; request writing and reply reading to ensure that requests are atomically -;;; written and replies are atomically read from the stream. - -#-:lcl3.0 -(defmacro without-aborts (&body body) - `(progn ,@body)) -;;; XXX [pve] This needs to be more robust. - -;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value. -;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's -;;; value changes. - -(defun process-block (whostate predicate &rest predicate-args) - (declare (type function predicate)) - #-ecl - (apply #'port:process-wait - whostate - predicate - predicate-args)) - - - -;;; PROCESS-WAKEUP: Check some other process' wait function. - -(declaim (inline process-wakeup)) - -(defun process-wakeup (process) - (declare (ignore process)) - #-(or clisp sbcl ecl) - (port:process-yield)) - -;;; CURRENT-PROCESS: Return the current process object for input locking and -;;; for calling PROCESS-WAKEUP. - -(declaim (inline current-process)) - -;;; Default return NIL, which is acceptable even if there is a scheduler. - -(defun current-process () - #-(or sbcl clisp ecl) - (port:current-process)) - -;;; WITHOUT-INTERRUPTS -- provide for atomic operations. -;;; XXX [pve]: this thing is used quite a lot -;;; but we should find a better solution. -#-(or cmu) -(defmacro without-interrupts (&body body) - `(progn ,@body)) - -#+cmu -(defmacro without-interrupts (&body body) - `(sys:without-interrupts ,@body)) - -;;; CONDITIONAL-STORE: - -;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times. -;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD. -(defmacro conditional-store (place old-value new-value) - `(without-interrupts - (cond ((eq ,place ,old-value) - (setf ,place ,new-value) - t)))) - -;;;---------------------------------------------------------------------------- -;;; IO Error Recovery -;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro. -;;; It prevents multiple mindless errors when the network craters. -;;; -;;;---------------------------------------------------------------------------- - -(defmacro wrap-buf-output ((buffer) &body body) - ;; Error recovery wrapper - `(unless (buffer-dead ,buffer) - ,@body)) - -(defmacro wrap-buf-input ((buffer) &body body) - (declare (ignore buffer)) - ;; Error recovery wrapper - `(progn ,@body)) - - -;;;---------------------------------------------------------------------------- -;;; System dependent IO primitives -;;; Functions for opening, reading writing forcing-output and closing -;;; the stream to the server. -;;;---------------------------------------------------------------------------- - -;;; OPEN-X-STREAM -- for CMU Common Lisp. -;;; -;;; The file descriptor here just gets tossed into the stream slot of the -;;; display object instead of a stream. -;;; - -(defparameter *X-unix-socket-path*+ - "/tmp/.X11-unix/X" - "The location of the X socket") - -(defun open-x-stream (host display protocol) - (declare (ignore protocol) - (type (integer 0) display)) - (let ((socket - ;; are we dealing with a localhost? - (progn #+nil ignore-errors - (when (or (string= host "") - (string= host "unix")) - ;; ok, try to connect to a AF_UNIX domain socket - ;; - ;; clisp doesn't have sockets, but special code for - ;; X connections: - #-(or clisp ecl) - (port::open-unix-socket (format nil - "~A~D" - *X-unix-socket-path*+ - display) - :kind :stream - :bin t) - #+ecl - (sys::open-unix-socket-stream (format nil - "~A~D" - *X-unix-socket-path*+ - display)) - ;; clisp doesn't have this... - #+clisp - (sys::make-socket-stream "" 0))))) - (if socket - socket - #+ecl - (si::open-client-stream host (+ 6000 display)) - #-ecl - ;; try to connect by hand - (let ((host (host-address host))) - (when host - ;; Fixme: get a descent ip standard in CLX: a vector! - (let ((ip (format nil - "~{~D~^.~}" - (rest host)))) - (port:open-socket ip - (+ 6000 display) - ;; binary: - t))))))) - -;;; BUFFER-READ-DEFAULT - read data from the X stream - -;;; BUFFER-READ-DEFAULT for CMU Common Lisp. -;;; -;;; If timeout is 0, then we call LISTEN to see if there is any input. -;;; Timeout 0 is the only case where READ-INPUT dives into BUFFER-READ without -;;; first calling BUFFER-INPUT-WAIT-DEFAULT. -;;; -(defun buffer-read-default (display vector start end timeout) - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null fixnum) timeout)) - #.(declare-buffun) - (cond ((and (eql timeout 0) - (not (listen (display-input-stream display)))) - :timeout) - (t - (read-sequence vector - (display-input-stream display) - :start start - :end end) - nil))) - -;;; BUFFER-WRITE-DEFAULT - write data to the X stream - -(defun buffer-write-default (vector display start end) - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (write-sequence vector - (display-output-stream display) - :start start - :end end) - nil) - -;;; buffer-force-output-default - force output to the X stream - -(defun buffer-force-output-default (display) - ;; The default buffer force-output function for use with common-lisp streams - (declare (type display display)) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (force-output stream)))) - -;;; BUFFER-CLOSE-DEFAULT - close the X stream - -(defun buffer-close-default (display &key abort) - ;; The default buffer close function for use with common-lisp streams - (declare (type display display)) - #.(declare-buffun) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (close stream :abort abort)))) - -;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the -;;; buffer. This is called in read-input between requests, so that a process -;;; waiting for input is abortable when between requests. Should return -;;; :TIMEOUT if it times out, NIL otherwise. - -;;; The default implementation - -#+clisp -(defparameter *buffer-read-polling-time* 0.5 - "Poll for input every X seconds") - -(defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null number) timeout)) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (cond ((null stream)) - ((listen stream) nil) - ((eql timeout 0) :timeout) - #-(or allegro clisp ecl) - (t - (if (port::wait-for-stream stream timeout) - nil - :timeout)) - #+(or allegro clisp ecl) - ((not (null timeout)) - (multiple-value-bind (npoll fraction) - (truncate timeout *buffer-read-polling-time*) - (dotimes (i npoll) ; Sleep for a time, then listen again - (sleep *buffer-read-polling-time*) - (when (listen stream) - (return-from buffer-input-wait-default nil))) - (when (plusp fraction) - (sleep fraction) ; Sleep a fraction of a second - (when (listen stream) ; and listen one last time - (return-from buffer-input-wait-default nil))) - :timeout))))) - -;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the -;;; buffer. This should never block, so it can be called from the scheduler. - -;;; The default implementation is to just use listen. - -(defun buffer-listen-default (display) - (declare (type display display)) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (if (null stream) - t - (listen stream)))) - - -;;;---------------------------------------------------------------------------- -;;; System dependent speed hacks -;;;---------------------------------------------------------------------------- - -;; -;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature. -;; If your lisp doesn't have stack-lists, and you're worried about -;; consing garbage, you may want to re-write this to allocate and -;; initialize lists from a resource. -;; -(defmacro with-stack-list ((var &rest elements) &body body) - ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body) - ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body) - ;; except that the list produced by MAPCAR resides on the stack and - ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. - `(let ((,var (list ,@elements))) - (declare (type cons ,var) - (dynamic-extent ,var)) - ,@body)) - -(defmacro with-stack-list* ((var &rest elements) &body body) - ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body) - ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body) - ;; except that the list produced by MAPCAR resides on the stack and - ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. - `(let ((,var (list* ,@elements))) - (declare (type cons ,var) - (dynamic-extent ,var)) - ,@body)) - -(declaim (inline buffer-replace)) - -(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) - (declare (type buffer-bytes buf1 buf2) - (type array-index start1 end1 start2)) - (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) - -(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) - &body body) - (let ((local-state (gensym)) - (resets nil)) - (dolist (index indexes) - (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index)) - resets)) - `(unwind-protect - (progn - ,@body) - (let ((,local-state (gcontext-local-state ,gc))) - (declare (type gcontext-state ,local-state)) - ,@resets - (setf (svref ,local-state ,ts-index) 0)) - (when ,temp-gc - (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) - (deallocate-gcontext-state ,saved-state)))) - -;;;---------------------------------------------------------------------------- -;;; How error detection should CLX do? -;;; Several levels are possible: -;;; -;;; 1. Do the equivalent of check-type on every argument. -;;; -;;; 2. Simply report TYPE-ERROR. This eliminates overhead of all the format -;;; strings generated by check-type. -;;; -;;; 3. Do error checking only on arguments that are likely to have errors -;;; (like keyword names) -;;; -;;; 4. Do error checking only where not doing so may dammage the envirnment -;;; on a non-tagged machine (i.e. when storing into a structure that has -;;; been passed in) -;;; -;;; 5. No extra error detection code. On lispm's, ASET may barf trying to -;;; store a non-integer into a number array. -;;; -;;; How extensive should the error checking be? For example, if the server -;;; expects a CARD16, is is sufficient for CLX to check for integer, or -;;; should it also check for non-negative and less than 65536? -;;;---------------------------------------------------------------------------- - -;; The +TYPE-CHECK?+ constant controls how much error checking is done. -;; Possible values are: -;; NIL - Don't do any error checking -;; t - Do the equivalent of checktype on every argument -;; :minimal - Do error checking only where errors are likely - -;;; This controls macro expansion, and isn't changable at run-time You will -;;; probably want to set this to nil if you want good performance at -;;; production time. -(defconstant +type-check?+ #+clx-debugging t #-clx-debugging nil) - -;; TYPE? is used to allow the code to do error checking at a different level from -;; the declarations. It also does some optimizations for systems that don't have -;; good compiler support for TYPEP. The definitions for CARD32, CARD16, INT16, etc. -;; include range checks. You can modify TYPE? to do less extensive checking -;; for these types if you desire. - -;; -;; ### This comment is a lie! TYPE? is really also used for run-time type -;; dispatching, not just type checking. -- Ram. - -(defmacro type? (object type) - `(typep ,object ,type)) - -;; X-TYPE-ERROR is the function called for type errors. -;; If you want lots of checking, but are concerned about code size, -;; this can be made into a macro that ignores some parameters. - -(defun x-type-error (object type &optional error-string) - (x-error 'x-type-error - :datum object - :expected-type type - :type-string error-string)) - - -;;----------------------------------------------------------------------------- -;; Error handlers -;; Hack up KMP error signaling using zetalisp until the real thing comes -;; along -;;----------------------------------------------------------------------------- - -(defun default-error-handler (display error-key &rest key-vals - &key asynchronous &allow-other-keys) - (declare (type generalized-boolean asynchronous) - (dynamic-extent key-vals)) - ;; The default display-error-handler. - ;; It signals the conditions listed in the DISPLAY file. - (if asynchronous - (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals) - (apply #'x-error error-key :display display :error-key error-key key-vals))) - -(defun x-error (condition &rest keyargs) - (declare (dynamic-extent keyargs)) - (apply #'error condition keyargs)) - -(defun x-cerror (proceed-format-string condition &rest keyargs) - (declare (dynamic-extent keyargs)) - (apply #'cerror proceed-format-string condition keyargs)) - -;;; X-ERROR for CMU Common Lisp -;;; -;;; We detect a couple condition types for which we disable event handling in -;;; our system. This prevents going into the debugger or returning to a -;;; command prompt with CLX repeatedly seeing the same condition. This occurs -;;; because CMU Common Lisp provides for all events (that is, X, input on file -;;; descriptors, Mach messages, etc.) to come through one routine anyone can -;;; use to wait for input. -;;; -#+(and CMU (not mp)) -(defun x-error (condition &rest keyargs) - (let ((condx (apply #'make-condition condition keyargs))) - (when (eq condition 'closed-display) - (let ((disp (closed-display-display condx))) - (warn "Disabled event handling on ~S." disp) - (ext::disable-clx-event-handling disp))) - (error condx))) - - -(define-condition x-error (error) ()) - - - -;;----------------------------------------------------------------------------- -;; HOST hacking -;;----------------------------------------------------------------------------- - -(defun host-address (host &optional (family :internet)) - "Return a list whose car is the family keyword (:internet :DECnet :Chaos) - and cdr is a list of network address bytes." - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (labels ((no-host-error () - (error "Unknown host ~S" host)) - (no-address-error () - (error "Host ~S has no ~S address" host family))) - #+ecl - (let ((addr (first (nth-value 3 (si::lookup-host-entry (string host)))))) - (unless addr - (no-host-error)) - (list :internet - (ldb (byte 8 24) addr) - (ldb (byte 8 16) addr) - (ldb (byte 8 8) addr) - (ldb (byte 8 0) addr))) - #-ecl - (let ((hostent (port:resolve-host-ipaddr (string host)))) - (when (not (port:hostent-addr-list hostent)) - (no-host-error)) - (ecase family - ((:internet nil 0) - (unless (= (port:hostent-addr-type hostent) 2) - (no-address-error)) - (let ((addr (first (port:hostent-addr-list hostent)))) - (etypecase addr - (integer - (list :internet - (ldb (byte 8 24) addr) - (ldb (byte 8 16) addr) - (ldb (byte 8 8) addr) - (ldb (byte 8 0) addr))) - (string - (let ((parts (mapcar #'parse-integer - (split-sequence:split-sequence - #\. - addr :count 4)))) - (cons :internet - parts)))))))))) - - -;;----------------------------------------------------------------------------- -;; Whether to use closures for requests or not. -;;----------------------------------------------------------------------------- - -;;; If this macro expands to non-NIL, then request and locking code is -;;; compiled in a much more compact format, as the common code is shared, and -;;; the specific code is built into a closure that is funcalled by the shared -;;; code. If your compiler makes efficient use of closures then you probably -;;; want to make this expand to T, as it makes the code more compact. - -(defmacro use-closures () - nil) - -(defun clx-macroexpand (form env) - (macroexpand form env)) - - -;;----------------------------------------------------------------------------- -;; Resource stuff -;;----------------------------------------------------------------------------- - - -;;; Utilities - -(defun getenv (name) - (#-ecl port:getenv #+ecl si:getenv name)) - -(defun get-host-name () - "Return the same hostname as gethostname(3) would" - ;; machine-instance probably works on a lot of lisps, but clisp is not - ;; one of them - #+(or cmu sbcl) (machine-instance) - ;; resources-pathname was using short-site-name for this purpose - #+excl (short-site-name) - #+ecl (si::getenv "HOST") - #-(or excl cmu sbcl ecl) (error "get-host-name not implemented")) - -(defun homedir-file-pathname (name) - (and #-(or unix mach ecl) (search "Unix" (software-type) :test #'char-equal) - (merge-pathnames - (translate-logical-pathname - (user-homedir-pathname)) - (pathname name)))) - -;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if -;;; a resource manager isn't running. - -(defun default-resources-pathname () - (homedir-file-pathname ".Xdefaults")) - -;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the -;;; defaults have been loaded. - -(defun resources-pathname () - (or (let ((string (getenv "XENVIRONMENT"))) - (and string - (pathname string))) - (homedir-file-pathname (concatenate 'string ".Xdefaults-" (get-host-name))))) - -;;; AUTHORITY-PATHNAME - The pathname of the authority file. - -(defun authority-pathname () - (or (let ((xauthority (getenv "XAUTHORITY"))) - (and xauthority - (pathname xauthority))) - (homedir-file-pathname ".Xauthority"))) - -;;; this particular defaulting behaviour is typical to most Unices, I think -;; #+unix PVE: Well, cygwin? - -(defun get-default-display () - "Get the default X display as list of (host display-number screen protocol). -In UNIX this is selected using the DISPLAY environment variable, and -may use :internet or :local protocol" - (let* ((name (or (getenv "DISPLAY") - (error "DISPLAY environment variable is not set"))) - (colon-i (position #\: name)) - (host (subseq name 0 colon-i)) - (dot-i (and colon-i (position #\. name :start colon-i))) - (display (if colon-i - (ignore-errors - (parse-integer name :start (1+ colon-i) :end dot-i)))) - (screen (if dot-i - (ignore-errors (parse-integer name :start (1+ dot-i))))) - (protocol (if (or (string= host "") (string-equal host "unix")) - :local - :internet))) - (list host (or display 0) (or screen 0) protocol))) - - -;;----------------------------------------------------------------------------- -;; GC stuff -;;----------------------------------------------------------------------------- - -(defun gc-cleanup () - (declare (special *event-free-list* - *pending-command-free-list* - *reply-buffer-free-lists* - *gcontext-local-state-cache* - *temp-gcontext-cache*)) - (setq *event-free-list* nil) - (setq *pending-command-free-list* nil) - (when (boundp '*reply-buffer-free-lists*) - (fill *reply-buffer-free-lists* nil)) - (setq *gcontext-local-state-cache* nil) - (setq *temp-gcontext-cache* nil) - nil) - - - -;;----------------------------------------------------------------------------- -;; DEFAULT-KEYSYM-TRANSLATE -;;----------------------------------------------------------------------------- - -;;; If object is a character, char-bits are set from state. -;;; -;;; [the following isn't implemented (should it be?)] -;;; If object is a list, it is an alist with entries: -;;; (base-char [modifiers] [mask-modifiers]) -;;; When MODIFIERS are specified, this character translation -;;; will only take effect when the specified modifiers are pressed. -;;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore. -;;; When MASK-MODIFIERS is missing, all other modifiers are ignored. -;;; In ambiguous cases, the most specific translation is used. - - -(defun default-keysym-translate (display state object) - (declare (type display display) - (type card16 state) - (type t object) - (ignore display state) - (clx-values t)) - object) - - -;;----------------------------------------------------------------------------- -;; Image stuff -;;----------------------------------------------------------------------------- - -;;; Types - -(deftype pixarray-1-element-type () - 'bit) - -(deftype pixarray-4-element-type () - '(unsigned-byte 4)) - -(deftype pixarray-8-element-type () - '(unsigned-byte 8)) - -(deftype pixarray-16-element-type () - '(unsigned-byte 16)) - -(deftype pixarray-24-element-type () - '(unsigned-byte 24)) - -(deftype pixarray-32-element-type () - '(unsigned-byte 32)) - -(deftype pixarray-1 () - '(simple-array pixarray-1-element-type (* *))) - -(deftype pixarray-4 () - '(#+cmu simple-array #-cmu array pixarray-4-element-type (* *))) - -(deftype pixarray-8 () - '(simple-array pixarray-8-element-type (* *))) - -(deftype pixarray-16 () - '(simple-array pixarray-16-element-type (* *))) - -(deftype pixarray-24 () - '(simple-array pixarray-24-element-type (* *))) - -(deftype pixarray-32 () - '(simple-array pixarray-32-element-type (* *))) - -(deftype pixarray () - '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32)) - -(deftype bitmap () - 'pixarray-1) - -;;; WITH-UNDERLYING-SIMPLE-VECTOR - -#+CMU -;;; We do *NOT* support viewing an array as having a different element type. -;;; Element-type is ignored. -;;; -(defmacro with-underlying-simple-vector - ((variable element-type pixarray) &body body) - (declare (ignore element-type)) - `(lisp::with-array-data ((,variable ,pixarray) - (start) - (end)) - (declare (ignore start end)) - ,@body)) - -;;; These are used to read and write pixels from and to CARD8s. - -;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s. - -(defmacro read-image-load-byte (size position integer) - (unless +image-bit-lsb-first-p+ (setq position (- 7 position))) - `(the (unsigned-byte ,size) - (ldb (byte ,size ,position)(the card8 ,integer)))) - -;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from -;;; the appropriate number of CARD8s. - -(defmacro read-image-assemble-bytes (&rest bytes) - (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes))) - (let ((it (first bytes)) - (count 0)) - (dolist (byte (rest bytes)) - (setq it - `(dpb - (the card8 ,byte) - (byte 8 ,(incf count 8)) - (the (unsigned-byte ,count) ,it)))) - `(the (unsigned-byte ,(* (length bytes) 8)) ,it))) - - -;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit -;;; pixel. - -(defmacro write-image-load-byte (position integer integer-size) - integer-size - (unless +image-byte-lsb-first-p+ (setq position (- integer-size 8 position))) - `(the card8 - (ldb - (byte 8 ,position) - (the (unsigned-byte ,integer-size) ,integer)))) - -;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit -;;; pixels. - -(defmacro write-image-assemble-bytes (&rest bytes) - (unless +image-bit-lsb-first-p+ (setq bytes (reverse bytes))) - (let ((size (floor 8 (length bytes))) - (it (first bytes)) - (count 0)) - (dolist (byte (rest bytes)) - (setq it `(dpb - (the (unsigned-byte ,size) ,byte) - (byte ,size ,(incf count size)) - (the (unsigned-byte ,count) ,it)))) - `(the card8 ,it))) - -;;; The following table gives the bit ordering within bytes (when accessed -;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to -;;; 31, where bit 0 should be leftmost on the display. For a given byte -;;; labelled A-B, A is for the most significant bit of the byte, and B is -;;; for the least significant bit. -;;; -;;; legend: -;;; 1 scanline-unit = 8 -;;; 2 scanline-unit = 16 -;;; 4 scanline-unit = 32 -;;; M byte-order = MostSignificant -;;; L byte-order = LeastSignificant -;;; m bit-order = MostSignificant -;;; l bit-order = LeastSignificant -;;; -;;; -;;; format ordering -;;; -;;; 1Mm 00-07 08-15 16-23 24-31 -;;; 2Mm 00-07 08-15 16-23 24-31 -;;; 4Mm 00-07 08-15 16-23 24-31 -;;; 1Ml 07-00 15-08 23-16 31-24 -;;; 2Ml 15-08 07-00 31-24 23-16 -;;; 4Ml 31-24 23-16 15-08 07-00 -;;; 1Lm 00-07 08-15 16-23 24-31 -;;; 2Lm 08-15 00-07 24-31 16-23 -;;; 4Lm 24-31 16-23 08-15 00-07 -;;; 1Ll 07-00 15-08 23-16 31-24 -;;; 2Ll 07-00 15-08 23-16 31-24 -;;; 4Ll 07-00 15-08 23-16 31-24 - - -;;; If you can write fast routines that can read and write pixarrays out of a -;;; buffer-bytes, do it! It makes the image code a lot faster. The -;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines -;;; return T if they can do it, NIL if they can't. - -;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s - -#+(or CMU) -(defun fast-read-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-24-element-type array) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index* x 3)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) - (declare (type array-index start y)) - (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x (array-row-major-index array y 0) (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref vector x) - (read-image-assemble-bytes - (aref buffer-bbuf (index+ i 0)) - (aref buffer-bbuf (index+ i 1)) - (aref buffer-bbuf (index+ i 2)))))))) - t) - -#+CMU -(defun pixarray-element-size (pixarray) - (let ((eltype (array-element-type pixarray))) - (cond ((eq eltype 'bit) 1) - ((and (consp eltype) (eq (first eltype) 'unsigned-byte)) - (second eltype)) - (t - (error "Invalid pixarray: ~S." pixarray))))) - -#+CMU -;;; COPY-BIT-RECT -- Internal -;;; -;;; This is the classic BITBLT operation, copying a rectangular subarray -;;; from one array to another (but source and destination must not overlap.) -;;; Widths are specified in bits. Neither array can have a non-zero -;;; displacement. We allow extra random bit-offset to be thrown into the X. -;;; -(defun copy-bit-rect (source source-width sx sy dest dest-width dx dy - height width) - (declare (type array-index source-width sx sy dest-width dx dy height width)) - #.(declare-buffun) - (lisp::with-array-data ((sdata source) - (sstart) - (send)) - (declare (ignore send)) - (lisp::with-array-data ((ddata dest) - (dstart) - (dend)) - (declare (ignore dend)) - (assert (and (zerop sstart) (zerop dstart))) - (do ((src-idx (index+ (* vm:vector-data-offset vm:word-bits) - sx (index* sy source-width)) - (index+ src-idx source-width)) - (dest-idx (index+ (* vm:vector-data-offset vm:word-bits) - dx (index* dy dest-width)) - (index+ dest-idx dest-width)) - (count height (1- count))) - ((zerop count)) - (declare (type array-index src-idx dest-idx count)) - (kernel:bit-bash-copy sdata src-idx ddata dest-idx width))))) - -#+CMU -(defun fast-read-pixarray-using-bitblt - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) - (declare (type (array * 2) pixarray)) - #.(declare-buffun) - (copy-bit-rect bbuf - (index* padded-bytes-per-line vm:byte-bits) - (index* boffset vm:byte-bits) 0 - pixarray - (index* (array-dimension pixarray 1) bits-per-pixel) - x y - height - (index* width bits-per-pixel)) - t) - -(defun fast-read-pixarray (bbuf boffset pixarray - x y width height padded-bytes-per-line - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type array-index boffset - padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (progn bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (or - (let ((function - (or (and (index= (pixarray-element-size pixarray) bits-per-pixel) - #'fast-read-pixarray-using-bitblt) - (and (index= bits-per-pixel 24) - #'fast-read-pixarray-24)))) - (when function - (read-pixarray-internal - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel function - unit byte-lsb-first-p bit-lsb-first-p - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+))))) - -;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s - -#+(or CMU) -(defun fast-write-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-24-element-type array) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index y start)) - (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x (array-row-major-index array y x) (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (let ((pixel (aref vector x))) - (declare (type pixarray-24-element-type pixel)) - (setf (aref buffer-bbuf (index+ i 0)) - (write-image-load-byte 0 pixel 24)) - (setf (aref buffer-bbuf (index+ i 1)) - (write-image-load-byte 8 pixel 24)) - (setf (aref buffer-bbuf (index+ i 2)) - (write-image-load-byte 16 pixel 24))))))) - t) - -#+CMU -(defun fast-write-pixarray-using-bitblt - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) - #.(declare-buffun) - (copy-bit-rect pixarray - (index* (array-dimension pixarray 1) bits-per-pixel) - x y - bbuf - (index* padded-bytes-per-line vm:byte-bits) - (index* boffset vm:byte-bits) 0 - height - (index* width bits-per-pixel)) - t) - -(defun fast-write-pixarray (bbuf boffset pixarray x y width height - padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (progn bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (or - (let ((function - (or (and (index= (pixarray-element-size pixarray) bits-per-pixel) - #'fast-write-pixarray-using-bitblt) - (and (index= bits-per-pixel 24) - #'fast-write-pixarray-24)))) - (when function - (write-pixarray-internal - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel function - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+ - unit byte-lsb-first-p bit-lsb-first-p))))) - -;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another - -(defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel) - (declare (type pixarray pixarray copy) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel)) - (progn pixarray copy x y width height bits-per-pixel nil) - (let* ((pixarray-padded-pixels-per-line - (array-dimension pixarray 1)) - (pixarray-padded-bits-per-line - (* pixarray-padded-pixels-per-line bits-per-pixel)) - (copy-padded-pixels-per-line - (array-dimension copy 1)) - (copy-padded-bits-per-line - (* copy-padded-pixels-per-line bits-per-pixel))) - (when (index= (pixarray-element-size pixarray) - (pixarray-element-size copy) - bits-per-pixel) - (copy-bit-rect pixarray pixarray-padded-bits-per-line x y - copy copy-padded-bits-per-line 0 0 - height - (index* width bits-per-pixel)) - t))) diff --git a/src/eclx/display.lisp b/src/eclx/display.lisp deleted file mode 100644 index 9d1da726c..000000000 --- a/src/eclx/display.lisp +++ /dev/null @@ -1,642 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11 - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; -#+cmu -(ext:file-comment - "$Header$") - -(in-package :xlib) - -;;; Authorizaton -;;; shamelessly stolen from the cmucl sources: -;;; integrated patches by Hannu Rummukainen and Scott Fahlman -;;; X11 Authorization: to prevent malicious users from snooping on an -;;; display, X servers may require connection requests to be -;;; authorized. The X server (or display manager) will create a random -;;; key on startup, and store it as an entry in a file generally named -;;; $HOME/.Xauthority (see the function AUTHORITY-PATHNAME). Clients -;;; must extract from this file the "magic cookie" that corresponds to -;;; the server they wish to connect to, and send it as authorization -;;; data when opening the display. -;;; -;;; Users can manipulate the contents of their .Xauthority file using -;;; the xauth command. -;;; -;;; The function GET-BEST-AUTHORIZATION is responsible for parsing the -;;; .Xauthority file and extracting the cookie for DISPLAY on HOST. -;;; The HOST argument is the hostname of the target display as a -;;; string, and DISPLAY is a number. The PROTOCOL argument determines -;;; whether the server connection is using an Internet protocol -;;; (values of :tcp or :internet) or a non-network protocol such as -;;; Unix domain sockets (value of :local). GET-BEST-AUTHORITY returns -;;; two strings: an authorization name (very likely the string -;;; "MIT-MAGIC-COOKIE-1") and an authorization key, represented as -;;; fixnums in a vector. If the function fails to find an appropriate -;;; cookie, it returns two empty strings. -;;; -;;; The format of the .Xauthority file is documented in the XFree -;;; sources, in the file xc/lib/Xau/README. - - -(defparameter *known-authorizations* '("MIT-MAGIC-COOKIE-1")) - -(defun read-xauth-entry (stream) - (labels ((read-short (stream &optional (eof-errorp t)) - (let ((high-byte (read-byte stream eof-errorp))) - (and high-byte - (dpb high-byte (byte 8 8) (read-byte stream))))) - (read-short-length-string (stream) - (let ((length (read-short stream))) - (let ((string (make-string length))) - (dotimes (k length) - (setf (schar string k) (card8->char (read-byte stream)))) - string))) - (read-short-length-vector (stream) - (let ((length (read-short stream))) - (let ((vector (make-array length :element-type '(unsigned-byte 8)))) - (dotimes (k length) - (setf (aref vector k) (read-byte stream))) - vector)))) - (let ((family (read-short stream nil))) - (if (null family) - (list nil nil nil nil nil) - (let* ((address (read-short-length-vector stream)) - (number (parse-integer (read-short-length-string stream))) - (name (read-short-length-string stream)) - (data (read-short-length-vector stream)) - (family (or (car (rassoc family *protocol-families*)) family))) - (list - family - (ecase family - (:local (map 'string #'code-char address)) - (:internet (coerce address 'list))) - number name data)))))) - -(defun get-best-authorization (host display protocol) - ;; parse .Xauthority, extract the cookie for DISPLAY on HOST. - ;; PROTOCOL determines whether the server connection is using an - ;; Internet protocol (value of :internet) or a non-network - ;; protocol such as Unix domain sockets (value of :local). Returns - ;; two strings: an authorization name (very likely the string - ;; "MIT-MAGIC-COOKIE-1") and an authorization key, represented as - ;; fixnums in a vector. If we fail to find an appropriate cookie, - ;; return two empty strings. - (let ((pathname (authority-pathname))) - (when pathname - (with-open-file (stream pathname :element-type '(unsigned-byte 8) - :if-does-not-exist nil) - (when stream - (let* ((host-address (and (eql protocol :internet) - (rest (host-address host protocol)))) - (best-name nil) - (best-pos nil) - (best-data nil)) - ;; Check for the localhost address, in which case we're - ;; really FamilyLocal. - (when (or (eql protocol :local) - (and (eql protocol :internet) - (equal host-address '(127 0 0 1)))) - (setq host-address (get-host-name)) - (setq protocol :local)) - (loop - (destructuring-bind (family address number name data) - (read-xauth-entry stream) - (unless family (return)) - (when (and (eql family protocol) - (equal host-address address) - (= number display) - (let ((pos1 (position name *known-authorizations* - :test #'string=))) - (and pos1 - (or (null best-pos) - (< pos1 best-pos))))) - (setf best-name name - best-pos (position name *known-authorizations* - :test #'string=) - best-data data)))) - (when best-name - (return-from get-best-authorization - (values best-name best-data))))))) - (values "" ""))) - -;; -;; Resource id management -;; -(defun initialize-resource-allocator (display) - ;; Find the resource-id-byte (appropriate for LDB & DPB) from the resource-id-mask - (let ((id-mask (display-resource-id-mask display))) - (unless (zerop id-mask) ;; zero mask is an error - (do ((first 0 (index1+ first)) - (mask id-mask (the mask32 (ash mask -1)))) - ((oddp mask) - (setf (display-resource-id-byte display) - (byte (integer-length mask) first))) - (declare (type array-index first) - (type mask32 mask)))))) - -(defun resourcealloc (display) - ;; Allocate a resource-id for in DISPLAY - (declare (type display display)) - (declare (clx-values resource-id)) - (dpb (incf (display-resource-id-count display)) - (display-resource-id-byte display) - (display-resource-id-base display))) - -(defmacro allocate-resource-id (display object type) - ;; Allocate a resource-id for OBJECT in DISPLAY - (if (member (eval type) *clx-cached-types*) - `(let ((id (funcall (display-xid ,display) ,display))) - (save-id ,display id ,object) - id) - `(funcall (display-xid ,display) ,display))) - -(defmacro deallocate-resource-id (display id type) - ;; Deallocate a resource-id for OBJECT in DISPLAY - (when (member (eval type) *clx-cached-types*) - `(deallocate-resource-id-internal ,display ,id))) - -(defun deallocate-resource-id-internal (display id) - (remhash id (display-resource-id-map display))) - -(defun lookup-resource-id (display id) - ;; Find the object associated with resource ID - (gethash id (display-resource-id-map display))) - -(defun save-id (display id object) - ;; Register a resource-id from another display. - (declare (type display display) - (type integer id) - (type t object)) - (declare (clx-values object)) - (setf (gethash id (display-resource-id-map display)) object)) - -;; Define functions to find the CLX data types given a display and resource-id -;; If the data type is being cached, look there first. -(macrolet ((generate-lookup-functions (useless-name &body types) - `(within-definition (,useless-name generate-lookup-functions) - ,@(mapcar - #'(lambda (type) - `(defun ,(xintern 'lookup- type) - (display id) - (declare (type display display) - (type resource-id id)) - (declare (clx-values ,type)) - ,(if (member type *clx-cached-types*) - `(let ((,type (lookup-resource-id display id))) - (cond ((null ,type) ;; Not found, create and save it. - (setq ,type (,(xintern 'make- type) - :display display :id id)) - (save-id display id ,type)) - ;; Found. Check the type - ,(cond ((null +type-check?+) - `(t ,type)) - ((member type '(window pixmap)) - `((type? ,type 'drawable) ,type)) - (t `((type? ,type ',type) ,type))) - ,@(when +type-check?+ - `((t (x-error 'lookup-error - :id id - :display display - :type ',type - :object ,type)))))) - ;; Not being cached. Create a new one each time. - `(,(xintern 'make- type) - :display display :id id)))) - types)))) - (generate-lookup-functions ignore - drawable - window - pixmap - gcontext - cursor - colormap - font)) - -(defun id-atom (id display) - ;; Return the cached atom for an atom ID - (declare (type resource-id id) - (type display display)) - (declare (clx-values (or null keyword))) - (gethash id (display-atom-id-map display))) - -(defun atom-id (atom display) - ;; Return the ID for an atom in DISPLAY - (declare (type xatom atom) - (type display display)) - (declare (clx-values (or null resource-id))) - (gethash (if (or (null atom) (keywordp atom)) atom (kintern atom)) - (display-atom-cache display))) - -(defun set-atom-id (atom display id) - ;; Set the ID for an atom in DISPLAY - (declare (type xatom atom) - (type display display) - (type resource-id id)) - (declare (clx-values resource-id)) - (let ((atom (if (or (null atom) (keywordp atom)) atom (kintern atom)))) - (setf (gethash id (display-atom-id-map display)) atom) - (setf (gethash atom (display-atom-cache display)) id) - id)) - -(defsetf atom-id set-atom-id) - -(defun initialize-predefined-atoms (display) - (dotimes (i (length *predefined-atoms*)) - (declare (type resource-id i)) - (setf (atom-id (svref *predefined-atoms* i) display) i))) - -(defun visual-info (display visual-id) - (declare (type display display) - (type resource-id visual-id) - (clx-values visual-info)) - (when (zerop visual-id) - (return-from visual-info nil)) - (dolist (screen (display-roots display)) - (declare (type screen screen)) - (dolist (depth (screen-depths screen)) - (declare (type cons depth)) - (dolist (visual-info (rest depth)) - (declare (type visual-info visual-info)) - (when (funcall (resource-id-map-test) visual-id (visual-info-id visual-info)) - (return-from visual-info visual-info))))) - (error "Visual info not found for id #x~x in display ~s." visual-id display)) - - -;; -;; Display functions -;; -(defmacro with-display ((display &key timeout inline) - &body body) - ;; This macro is for use in a multi-process environment. It provides exclusive - ;; access to the local display object for multiple request generation. It need not - ;; provide immediate exclusive access for replies; that is, if another process is - ;; waiting for a reply (while not in a with-display), then synchronization need not - ;; (but can) occur immediately. Except where noted, all routines effectively - ;; contain an implicit with-display where needed, so that correct synchronization - ;; is always provided at the interface level on a per-call basis. Nested uses of - ;; this macro will work correctly. This macro does not prevent concurrent event - ;; processing; see with-event-queue. - `(with-buffer (,display - ,@(and timeout `(:timeout ,timeout)) - ,@(and inline `(:inline ,inline))) - ,@body)) - -(defmacro with-event-queue ((display &key timeout inline) - &body body &environment env) - ;; exclusive access to event queue - `(macrolet ((with-event-queue ((display &key timeout) &body body) - ;; Speedup hack for lexically nested with-event-queues - `(progn - (progn ,display ,@(and timeout `(,timeout)) nil) - ,@body))) - ,(if (and (null inline) (macroexpand '(use-closures) env)) - `(flet ((.with-event-queue-body. () ,@body)) - (declare (dynamic-extent #'.with-event-queue-body.)) - (with-event-queue-function - ,display ,timeout #'.with-event-queue-body.)) - (let ((disp (if (or (symbolp display) (constantp display)) - display - '.display.))) - `(let (,@(unless (eq disp display) `((,disp ,display)))) - (holding-lock ((display-event-lock ,disp) ,disp "CLX Event Lock" - ,@(and timeout `(:timeout ,timeout))) - ,@body)))))) - -(defun with-event-queue-function (display timeout function) - (declare (type display display) - (type (or null number) timeout) - (type function function) - (dynamic-extent function)) - (with-event-queue (display :timeout timeout :inline t) - (funcall function))) - -(defmacro with-event-queue-internal ((display &key timeout) &body body) - ;; exclusive access to the internal event queues - (let ((disp (if (or (symbolp display) (constantp display)) display '.display.))) - `(let (,@(unless (eq disp display) `((,disp ,display)))) - (holding-lock ((display-event-queue-lock ,disp) ,disp "CLX Event Queue Lock" - ,@(and timeout `(:timeout ,timeout))) - ,@body)))) - -(defun open-default-display () - "Opens the default display" - (destructuring-bind (host display screen protocol) - (get-default-display) - (declare (ignore screen)) - (open-display host :display display :protocol protocol))) - -(defun open-display (host &key (display 0) protocol authorization-name authorization-data) - ;; Implementation specific routine to setup the buffer for a specific host and display. - ;; This must interface with the local network facilities, and will probably do special - ;; things to circumvent the network when displaying on the local host. - ;; - ;; A string must be acceptable as a host, but otherwise the possible types - ;; for host and protocol are not constrained, and will likely be very - ;; system dependent. The default protocol is system specific. Authorization, - ;; if any, is assumed to come from the environment somehow. - (declare (type integer display)) - (declare (clx-values display)) - ;; Get the authorization mechanism from the environment. Handle the - ;; special case of a host name of "" and "unix" which means the - ;; protocol is :local - (when (member host '("" "unix") :test #'equal) - (setf protocol :local)) - (when (null authorization-name) - (multiple-value-setq (authorization-name authorization-data) - (get-best-authorization host - display - protocol))) - ;; PROTOCOL is the network protocol now _alwas_ :TCP - (let* ((stream (open-x-stream host display protocol)) - (disp (make-buffer *output-buffer-size* #'make-display-internal - :host host :display display - :output-stream stream :input-stream stream)) - (ok-p nil)) - (unwind-protect - (progn - (display-connect disp - :authorization-name authorization-name - :authorization-data authorization-data) - (setf (display-authorization-name disp) authorization-name) - (setf (display-authorization-data disp) authorization-data) - (initialize-resource-allocator disp) - (initialize-predefined-atoms disp) - (initialize-extensions disp) - (setq ok-p t)) - (unless ok-p (close-display disp :abort t))) - disp)) - -(defun display-force-output (display) - ; Output is normally buffered, this forces any buffered output to the server. - (declare (type display display)) - (with-display (display) - (buffer-force-output display))) - -(defun close-display (display &key abort) - ;; Close the host connection in DISPLAY - (declare (type display display)) - (close-buffer display :abort abort)) - -(defun display-connect (display &key authorization-name authorization-data) - (with-buffer-output (display :sizes (8 16)) - (card8-put - 0 - (ecase (display-byte-order display) - (:lsbfirst #x6c) ;; Ascii lowercase l - Least Significant Byte First - (:msbfirst #x42))) ;; Ascii uppercase B - Most Significant Byte First - (card16-put 2 *protocol-major-version*) - (card16-put 4 *protocol-minor-version*) - (card16-put 6 (length authorization-name)) - (card16-put 8 (length authorization-data)) - (write-sequence-char display 12 authorization-name) - (if (stringp authorization-data) - (write-sequence-char display (lround (+ 12 (length authorization-name))) - authorization-data) - (write-sequence-card8 display (lround (+ 12 (length authorization-name))) - authorization-data))) - (buffer-force-output display) - (let ((reply-buffer nil)) - (declare (type (or null reply-buffer) reply-buffer)) - (unwind-protect - (progn - (setq reply-buffer (allocate-reply-buffer #x1000)) - (with-buffer-input (reply-buffer :sizes (8 16 32)) - (buffer-input display buffer-bbuf 0 8) - (let ((success (boolean-get 0)) - (reason-length (card8-get 1)) - (major-version (card16-get 2)) - (minor-version (card16-get 4)) - (total-length (card16-get 6)) - vendor-length - num-roots - num-formats) - (declare (ignore total-length)) - (unless success - (x-error 'connection-failure - :major-version major-version - :minor-version minor-version - :host (display-host display) - :display (display-display display) - :reason - (progn (buffer-input display buffer-bbuf 0 reason-length) - (string-get reason-length 0 :reply-buffer reply-buffer)))) - (buffer-input display buffer-bbuf 0 32) - (setf (display-protocol-major-version display) major-version) - (setf (display-protocol-minor-version display) minor-version) - (setf (display-release-number display) (card32-get 0)) - (setf (display-resource-id-base display) (card32-get 4)) - (setf (display-resource-id-mask display) (card32-get 8)) - (setf (display-motion-buffer-size display) (card32-get 12)) - (setq vendor-length (card16-get 16)) - (setf (display-max-request-length display) (card16-get 18)) - (setq num-roots (card8-get 20)) - (setq num-formats (card8-get 21)) - ;; Get the image-info - (setf (display-image-lsb-first-p display) (zerop (card8-get 22))) - (let ((format (display-bitmap-format display))) - (declare (type bitmap-format format)) - (setf (bitmap-format-lsb-first-p format) (zerop (card8-get 23))) - (setf (bitmap-format-unit format) (card8-get 24)) - (setf (bitmap-format-pad format) (card8-get 25))) - (setf (display-min-keycode display) (card8-get 26)) - (setf (display-max-keycode display) (card8-get 27)) - ;; 4 bytes unused - ;; Get the vendor string - (buffer-input display buffer-bbuf 0 (lround vendor-length)) - (setf (display-vendor-name display) - (string-get vendor-length 0 :reply-buffer reply-buffer)) - ;; Initialize the pixmap formats - (dotimes (i num-formats) ;; loop gathering pixmap formats - (declare (ignorable i)) - (buffer-input display buffer-bbuf 0 8) - (push (make-pixmap-format :depth (card8-get 0) - :bits-per-pixel (card8-get 1) - :scanline-pad (card8-get 2)) - ; 5 unused bytes - (display-pixmap-formats display))) - (setf (display-pixmap-formats display) - (nreverse (display-pixmap-formats display))) - ;; Initialize the screens - (dotimes (i num-roots) - (declare (ignorable i)) - (buffer-input display buffer-bbuf 0 40) - (let* ((root-id (card32-get 0)) - (root (make-window :id root-id :display display)) - (root-visual (card32-get 32)) - (default-colormap-id (card32-get 4)) - (default-colormap - (make-colormap :id default-colormap-id :display display)) - (screen - (make-screen - :root root - :default-colormap default-colormap - :white-pixel (card32-get 8) - :black-pixel (card32-get 12) - :event-mask-at-open (card32-get 16) - :width (card16-get 20) - :height (card16-get 22) - :width-in-millimeters (card16-get 24) - :height-in-millimeters (card16-get 26) - :min-installed-maps (card16-get 28) - :max-installed-maps (card16-get 30) - :backing-stores (member8-get 36 :never :when-mapped :always) - :save-unders-p (boolean-get 37) - :root-depth (card8-get 38))) - (num-depths (card8-get 39)) - (depths nil)) - ;; Save root window for event reporting - (save-id display root-id root) - (save-id display default-colormap-id default-colormap) - ;; Create the depth AList for a screen, (depth . visual-infos) - (dotimes (j num-depths) - (declare (ignorable j)) - (buffer-input display buffer-bbuf 0 8) - (let ((depth (card8-get 0)) - (num-visuals (card16-get 2)) - (visuals nil)) ;; 4 bytes unused - (dotimes (k num-visuals) - (declare (ignorable k)) - (buffer-input display buffer-bbuf 0 24) - (let* ((visual (card32-get 0)) - (visual-info (make-visual-info - :id visual - :display display - :class (member8-get 4 :static-gray :gray-scale - :static-color :pseudo-color - :true-color :direct-color) - :bits-per-rgb (card8-get 5) - :colormap-entries (card16-get 6) - :red-mask (card32-get 8) - :green-mask (card32-get 12) - :blue-mask (card32-get 16) - ;; 4 bytes unused - ))) - (push visual-info visuals) - (when (funcall (resource-id-map-test) root-visual visual) - (setf (screen-root-visual-info screen) - (setf (colormap-visual-info default-colormap) - visual-info))))) - (push (cons depth (nreverse visuals)) depths))) - (setf (screen-depths screen) (nreverse depths)) - (push screen (display-roots display)))) - (setf (display-roots display) (nreverse (display-roots display))) - (setf (display-default-screen display) (first (display-roots display)))))) - (when reply-buffer - (deallocate-reply-buffer reply-buffer)))) - display) - -(defun display-protocol-version (display) - (declare (type display display)) - (declare (clx-values major minor)) - (values (display-protocol-major-version display) - (display-protocol-minor-version display))) - -(defun display-vendor (display) - (declare (type display display)) - (declare (clx-values name release)) - (values (display-vendor-name display) - (display-release-number display))) - -(defun display-nscreens (display) - (declare (type display display)) - (length (display-roots display))) - -#+comment ;; defined by the DISPLAY defstruct -(defsetf display-error-handler (display) (handler) - ;; All errors (synchronous and asynchronous) are processed by calling an error - ;; handler in the display. If handler is a sequence it is expected to contain - ;; handler functions specific to each error; the error code is used to index the - ;; sequence, fetching the appropriate handler. Any results returned by the handler - ;; are ignored; it is assumed the handler either takes care of the error - ;; completely, or else signals. For all core errors, the keyword/value argument - ;; pairs are: - ;; :display display - ;; :error-key error-key - ;; :major integer - ;; :minor integer - ;; :sequence integer - ;; :current-sequence integer - ;; For :colormap, :cursor, :drawable, :font, :gcontext, :id-choice, :pixmap, and - ;; :window errors another pair is: - ;; :resource-id integer - ;; For :atom errors, another pair is: - ;; :atom-id integer - ;; For :value errors, another pair is: - ;; :value integer - ) - - ;; setf'able - ;; If defined, called after every protocol request is generated, even those inside - ;; explicit with-display's, but never called from inside the after-function itself. - ;; The function is called inside the effective with-display for the associated - ;; request. Default value is nil. Can be set, for example, to - ;; #'display-force-output or #'display-finish-output. - -(defvar *inside-display-after-function* nil) - -(defun display-invoke-after-function (display) - ; Called after every protocal request is generated - (declare (type display display)) - (when (and (display-after-function display) - (not *inside-display-after-function*)) - (let ((*inside-display-after-function* t)) ;; Ensure no recursive calls - (funcall (display-after-function display) display)))) - -(defun display-finish-output (display) - ;; Forces output, then causes a round-trip to ensure that all possible - ;; errors and events have been received. - (declare (type display display)) - (with-buffer-request-and-reply (display +x-getinputfocus+ 16 :sizes (8 32)) - () - ) - ;; Report asynchronous errors here if the user wants us to. - (report-asynchronous-errors display :after-finish-output)) - -(defparameter - *request-names* - '#("error" "CreateWindow" "ChangeWindowAttributes" "GetWindowAttributes" - "DestroyWindow" "DestroySubwindows" "ChangeSaveSet" "ReparentWindow" - "MapWindow" "MapSubwindows" "UnmapWindow" "UnmapSubwindows" - "ConfigureWindow" "CirculateWindow" "GetGeometry" "QueryTree" - "InternAtom" "GetAtomName" "ChangeProperty" "DeleteProperty" - "GetProperty" "ListProperties" "SetSelectionOwner" "GetSelectionOwner" - "ConvertSelection" "SendEvent" "GrabPointer" "UngrabPointer" - "GrabButton" "UngrabButton" "ChangeActivePointerGrab" "GrabKeyboard" - "UngrabKeyboard" "GrabKey" "UngrabKey" "AllowEvents" - "GrabServer" "UngrabServer" "QueryPointer" "GetMotionEvents" - "TranslateCoords" "WarpPointer" "SetInputFocus" "GetInputFocus" - "QueryKeymap" "OpenFont" "CloseFont" "QueryFont" - "QueryTextExtents" "ListFonts" "ListFontsWithInfo" "SetFontPath" - "GetFontPath" "CreatePixmap" "FreePixmap" "CreateGC" - "ChangeGC" "CopyGC" "SetDashes" "SetClipRectangles" - "FreeGC" "ClearToBackground" "CopyArea" "CopyPlane" - "PolyPoint" "PolyLine" "PolySegment" "PolyRectangle" - "PolyArc" "FillPoly" "PolyFillRectangle" "PolyFillArc" - "PutImage" "GetImage" "PolyText8" "PolyText16" - "ImageText8" "ImageText16" "CreateColormap" "FreeColormap" - "CopyColormapAndFree" "InstallColormap" "UninstallColormap" "ListInstalledColormaps" - "AllocColor" "AllocNamedColor" "AllocColorCells" "AllocColorPlanes" - "FreeColors" "StoreColors" "StoreNamedColor" "QueryColors" - "LookupColor" "CreateCursor" "CreateGlyphCursor" "FreeCursor" - "RecolorCursor" "QueryBestSize" "QueryExtension" "ListExtensions" - "SetKeyboardMapping" "GetKeyboardMapping" "ChangeKeyboardControl" "GetKeyboardControl" - "Bell" "ChangePointerControl" "GetPointerControl" "SetScreenSaver" - "GetScreenSaver" "ChangeHosts" "ListHosts" "ChangeAccessControl" - "ChangeCloseDownMode" "KillClient" "RotateProperties" "ForceScreenSaver" - "SetPointerMapping" "GetPointerMapping" "SetModifierMapping" "GetModifierMapping")) diff --git a/src/eclx/doc.lisp b/src/eclx/doc.lisp deleted file mode 100644 index d11f22090..000000000 --- a/src/eclx/doc.lisp +++ /dev/null @@ -1,3806 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; Copyright 1987, 1988 Massachusetts Institute of Technology, and -;;; Texas Instruments Incorporated - -;;; Permission to use, copy, modify, and distribute this document for any purpose -;;; and without fee is hereby granted, provided that the above copyright notice -;;; appear in all copies and that both that copyright notice and this permission -;;; notice are retained, and that the name of M.I.T. not be used in advertising or -;;; publicity pertaining to this document without specific, written prior -;;; permission. M.I.T. makes no representations about the suitability of this -;;; document or the protocol defined in this document for any purpose. It is -;;; provided "as is" without express or implied warranty. - -;;; Texas Instruments Incorporated provides this document "as is" without -;;; express or implied warranty. -#+cmu -(ext:file-comment - "$Header$") - -;; Version 4 - -;; This is considered a somewhat changeable interface. Discussion of better -;; integration with CLOS, support for user-specified subclassess of basic -;; objects, and the additional functionality to match the C Xlib is still in -;; progress. - -;; Primary Interface Author: -;; Robert W. Scheifler -;; MIT Laboratory for Computer Science -;; 545 Technology Square, Room 418 -;; Cambridge, MA 02139 -;; rws@zermatt.lcs.mit.edu - -;; Design Contributors: -;; Dan Cerys, Texas Instruments -;; Scott Fahlman, CMU -;; Charles Hornig, Symbolics -;; John Irwin, Franz -;; Kerry Kimbrough, Texas Instruments -;; Chris Lindblad, MIT -;; Rob MacLachlan, CMU -;; Mike McMahon, Symbolics -;; David Moon, Symbolics -;; LaMott Oren, Texas Instruments -;; Daniel Weinreb, Symbolics -;; John Wroclawski, MIT -;; Richard Zippel, Symbolics - -;; CLX Extensions -;; Adds some of the functionality provided by the C XLIB library. -;; -;; Primary Author -;; LaMott G. Oren -;; Texas Instruments -;; -;; Design Contributors: -;; Robert W. Scheifler, MIT - - -;; Note: all of the following is in the package XLIB. - -(declaim (declaration arglist clx-values)) - -;; Note: if you have read the Version 11 protocol document or C Xlib manual, most of -;; the relationships should be fairly obvious. We have no intention of writing yet -;; another moby document for this interface. - -(deftype card32 () '(unsigned-byte 32)) - -(deftype card29 () '(unsigned-byte 29)) - -(deftype int32 () '(signed-byte 32)) - -(deftype card16 () '(unsigned-byte 16)) - -(deftype int16 () '(signed-byte 16)) - -(deftype card8 () '(unsigned-byte 8)) - -(deftype int8 () '(signed-byte 8)) - -(deftype mask32 () 'card32) - -(deftype mask16 () 'card16) - -(deftype resource-id () 'card29) - -;; Types employed: display, window, pixmap, cursor, font, gcontext, colormap, color. -;; These types are defined solely by a functional interface; we do not specify -;; whether they are implemented as structures or flavors or ... Although functions -;; below are written using DEFUN, this is not an implementation requirement (although -;; it is a requirement that they be functions as opposed to macros or special forms). -;; It is unclear whether with-slots in the Common Lisp Object System must work on -;; them. - -;; Windows, pixmaps, cursors, fonts, gcontexts, and colormaps are all represented as -;; compound objects, rather than as integer resource-ids. This allows applications -;; to deal with multiple displays without having an explicit display argument in the -;; most common functions. Every function uses the display object indicated by the -;; first argument that is or contains a display; it is an error if arguments contain -;; different displays, and predictable results are not guaranteed. - -;; Each of window, pixmap, drawable, cursor, font, gcontext, and colormap have the -;; following five functions: - -(defun -display () - (declare (type ) - (clx-values display))) - -(defun -id () - (declare (type ) - (clx-values resource-id))) - -(defun -equal (-1 -2) - (declare (type -1 -2))) - -(defun -p () - (declare (type ) - (clx-values boolean))) - -;; The following functions are provided by color objects: - -;; The intention is that IHS and YIQ and CYM interfaces will also exist. Note that -;; we are explicitly using a different spectrum representation than what is actually -;; transmitted in the protocol. - -(deftype rgb-val () '(real 0 1)) - -(defun make-color (&key red green blue &allow-other-keys) ; for expansion - (declare (type rgb-val red green blue) - (clx-values color))) - -(defun color-rgb (color) - (declare (type color color) - (clx-values red green blue))) - -(defun color-red (color) - ;; setf'able - (declare (type color color) - (clx-values rgb-val))) - -(defun color-green (color) - ;; setf'able - (declare (type color color) - (clx-values rgb-val))) - -(defun color-blue (color) - ;; setf'able - (declare (type color color) - (clx-values rgb-val))) - -(deftype drawable () '(or window pixmap)) - -;; Atoms are accepted as strings or symbols, and are always returned as keywords. -;; Protocol-level integer atom ids are hidden, using a cache in the display object. - -(deftype xatom () '(or string symbol)) - -(deftype stringable () '(or string symbol)) - -(deftype fontable () '(or stringable font)) - -;; Nil stands for CurrentTime. - -(deftype timestamp () '(or null card32)) - -(deftype bit-gravity () '(member :forget :static :north-west :north :north-east - :west :center :east :south-west :south :south-east)) - -(deftype win-gravity () '(member :unmap :static :north-west :north :north-east - :west :center :east :south-west :south :south-east)) - -(deftype grab-status () - '(member :success :already-grabbed :frozen :invalid-time :not-viewable)) - -(deftype boolean () '(or null (not null))) - -(deftype pixel () '(unsigned-byte 32)) -(deftype image-depth () '(integer 0 32)) - -(deftype keysym () 'card32) - -(deftype array-index () `(integer 0 ,array-dimension-limit)) - -;; An association list. - -(deftype alist (key-type-and-name datum-type-and-name) 'list) - -(deftype clx-list (&optional element-type) 'list) -(deftype clx-sequence (&optional element-type) 'sequence) - -;; A sequence, containing zero or more repetitions of the given elements, -;; with the elements expressed as (type name). - -(deftype repeat-seq (&rest elts) 'sequence) - -(deftype point-seq () '(repeat-seq (int16 x) (int16 y))) - -(deftype seg-seq () '(repeat-seq (int16 x1) (int16 y1) (int16 x2) (int16 y2))) - -(deftype rect-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height))) - -;; Note that we are explicitly using a different angle representation than what -;; is actually transmitted in the protocol. - -(deftype angle () '(real #.(* -2 pi) #.(* 2 pi))) - -(deftype arc-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height) - (angle angle1) (angle angle2))) - -(deftype event-mask-class () - '(member :key-press :key-release :owner-grab-button :button-press :button-release - :enter-window :leave-window :pointer-motion :pointer-motion-hint - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion :exposure :visibility-change - :structure-notify :resize-redirect :substructure-notify :substructure-redirect - :focus-change :property-change :colormap-change :keymap-state)) - -(deftype event-mask () - '(or mask32 (clx-list event-mask-class))) - -(deftype pointer-event-mask-class () - '(member :button-press :button-release - :enter-window :leave-window :pointer-motion :pointer-motion-hint - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion :keymap-state)) - -(deftype pointer-event-mask () - '(or mask32 (clx-list pointer-event-mask-class))) - -(deftype device-event-mask-class () - '(member :key-press :key-release :button-press :button-release :pointer-motion - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion)) - -(deftype device-event-mask () - '(or mask32 (clx-list device-event-mask-class))) - -(deftype modifier-key () - '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5)) - -(deftype modifier-mask () - '(or (member :any) mask16 (clx-list modifier-key))) - -(deftype state-mask-key () - '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5))) - -(deftype gcontext-key () - '(member :function :plane-mask :foreground :background - :line-width :line-style :cap-style :join-style :fill-style :fill-rule - :arc-mode :tile :stipple :ts-x :ts-y :font :subwindow-mode - :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes)) - -(deftype event-key () - '(member :key-press :key-release :button-press :button-release :motion-notify - :enter-notify :leave-notify :focus-in :focus-out :keymap-notify - :exposure :graphics-exposure :no-exposure :visibility-notify - :create-notify :destroy-notify :unmap-notify :map-notify :map-request - :reparent-notify :configure-notify :gravity-notify :resize-request - :configure-request :circulate-notify :circulate-request :property-notify - :selection-clear :selection-request :selection-notify - :colormap-notify :client-message)) - -(deftype error-key () - '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice - :illegal-request :implementation :length :match :name :pixmap :value :window)) - -(deftype draw-direction () - '(member :left-to-right :right-to-left)) - -(defstruct bitmap-format - (unit :type (member 8 16 32)) - (pad :type (member 8 16 32)) - (lsb-first-p :type boolean)) - -(defstruct pixmap-format - (depth :type image-depth) - (bits-per-pixel :type (member 1 4 8 16 24 32)) - (pad :type (member 8 16 32))) - -(defstruct visual-info - (id :type resource-id) - (display :type display) - (class :type (member :static-gray :static-color :true-color - :gray-scale :pseudo-color :direct-color)) - (red-mask :type pixel) - (green-mask :type pixel) - (blue-mask :type pixel) - (bits-per-rgb :type card8) - (colormap-entries :type card16)) - -(defstruct screen - (root :type window) - (width :type card16) - (height :type card16) - (width-in-millimeters :type card16) - (height-in-millimeters :type card16) - (depths :type (alist (image-depth depth) ((clx-list visual-info) visuals))) - (root-depth :type image-depth) - (root-visual-info :type visual-info) - (default-colormap :type colormap) - (white-pixel :type pixel) - (black-pixel :type pixel) - (min-installed-maps :type card16) - (max-installed-maps :type card16) - (backing-stores :type (member :never :when-mapped :always)) - (save-unders-p :type boolean) - (event-mask-at-open :type mask32)) - -(defun screen-root-visual (screen) - (declare (type screen screen) - (clx-values resource-id))) - -;; The list contains alternating keywords and integers. - -(deftype font-props () 'list) - -(defun open-display (host &key (display 0) protocol) - ;; A string must be acceptable as a host, but otherwise the possible types for host - ;; and protocol are not constrained, and will likely be very system dependent. The - ;; default protocol is system specific. Authorization, if any, is assumed to come - ;; from the environment somehow. - (declare (type integer display) - (clx-values display))) - -(defun display-protocol-major-version (display) - (declare (type display display) - (clx-values card16))) - -(defun display-protocol-minor-version (display) - (declare (type display display) - (clx-values card16))) - -(defun display-vendor-name (display) - (declare (type display display) - (clx-values string))) - -(defun display-release-number (display) - (declare (type display display) - (clx-values card32))) - -(defun display-image-lsb-first-p (display) - (declare (type display display) - (clx-values boolean))) - -(defun display-bitmap-formap (display) - (declare (type display display) - (clx-values bitmap-format))) - -(defun display-pixmap-formats (display) - (declare (type display display) - (clx-values (clx-list pixmap-formats)))) - -(defun display-roots (display) - (declare (type display display) - (clx-values (clx-list screen)))) - -(defun display-motion-buffer-size (display) - (declare (type display display) - (clx-values card32))) - -(defun display-max-request-length (display) - (declare (type display display) - (clx-values card16))) - -(defun display-min-keycode (display) - (declare (type display display) - (clx-values card8))) - -(defun display-max-keycode (display) - (declare (type display display) - (clx-values card8))) - -(defun close-display (display) - (declare (type display display))) - -(defun display-error-handler (display) - (declare (type display display) - (clx-values handler))) - -(defsetf display-error-handler (display) (handler) - ;; All errors (synchronous and asynchronous) are processed by calling an error - ;; handler in the display. If handler is a sequence it is expected to contain - ;; handler functions specific to each error; the error code is used to index the - ;; sequence, fetching the appropriate handler. Any results returned by the handler - ;; are ignored; it is assumed the handler either takes care of the error - ;; completely, or else signals. For all core errors, the keyword/value argument - ;; pairs are: - ;; :major card8 - ;; :minor card16 - ;; :sequence card16 - ;; :current-sequence card16 - ;; :asynchronous (member t nil) - ;; For :colormap, :cursor, :drawable, :font, :gcontext, :id-choice, :pixmap, and - ;; :window errors another pair is: - ;; :resource-id card32 - ;; For :atom errors, another pair is: - ;; :atom-id card32 - ;; For :value errors, another pair is: - ;; :value card32 - (declare (type display display) - (type (or (clx-sequence (function (display symbol &key &allow-other-keys))) - (function (display symbol &key &allow-other-keys))) - handler))) - -(defsetf display-report-asynchronous-errors (display) (when) - ;; Most useful in multi-process lisps. - ;; - ;; Synchronous errors are always signalled in the process that made the - ;; synchronous request. An error is considered synchronous if a process is - ;; waiting for a reply with the same request-id as the error. - ;; - ;; Asynchronous errors can be signalled at any one of these three times: - ;; - ;; 1. As soon as they are read. They get signalled in whichever process - ;; was doing the reading. This is enabled by - ;; (setf (xlib:display-report-asynchronous-errors display) - ;; '(:immediately)) - ;; This is the default. - ;; - ;; 2. Before any events are to be handled. You get these by doing an - ;; event-listen with any timeout value other than 0, or in of the event - ;; processing forms. This is useful if you using a background process to - ;; handle input. This is enabled by - ;; (setf (xlib:display-report-asynchronous-errors display) - ;; '(:before-event-handling)) - ;; - ;; 3. After a display-finish-output. You get these by doing a - ;; display-finish-output. A cliche using this might have a with-display - ;; wrapped around the display operations that possibly cause an asynchronous - ;; error, with a display-finish-output right the end of the with-display to - ;; catch any asynchronous errors. This is enabled by - ;; (setf (xlib:display-report-asynchronous-errors display) - ;; '(:after-finish-output)) - ;; - ;; You can select any combination of the three keywords. For example, to - ;; get errors reported before event handling and after finish-output, - ;; (setf (xlib:display-report-asynchronous-errors display) - ;; '(:before-event-handling :after-finish-output)) - (declare (type list when)) - ) - -(defmacro define-condition (name base &body items) - ;; just a place-holder here for the real thing - ) - -(define-condition request-error error - display - major - minor - sequence - current-sequence - asynchronous) - -(defun default-error-handler (display error-key &key &allow-other-keys) - ;; The default display-error-handler. - ;; It signals the conditions listed below. - (declare (type display display) - (type symbol error-key)) - ) - -(define-condition resource-error request-error - resource-id) - -(define-condition access-error request-error) - -(define-condition alloc-error request-error) - -(define-condition atom-error request-error - atom-id) - -(define-condition colormap-error resource-error) - -(define-condition cursor-error resource-error) - -(define-condition drawable-error resource-error) - -(define-condition font-error resource-error) - -(define-condition gcontext-error resource-error) - -(define-condition id-choice-error resource-error) - -(define-condition illegal-request-error request-error) - -(define-condition implementation-error request-error) - -(define-condition length-error request-error) - -(define-condition match-error request-error) - -(define-condition name-error request-error) - -(define-condition pixmap-error resource-error) - -(define-condition value-error request-error - value) - -(define-condition window-error resource-error) - -(defmacro with-display ((display) &body body) - ;; This macro is for use in a multi-process environment. It provides exclusive - ;; access to the local display object for multiple request generation. It need not - ;; provide immediate exclusive access for replies; that is, if another process is - ;; waiting for a reply (while not in a with-display), then synchronization need not - ;; (but can) occur immediately. Except where noted, all routines effectively - ;; contain an implicit with-display where needed, so that correct synchronization - ;; is always provided at the interface level on a per-call basis. Nested uses of - ;; this macro will work correctly. This macro does not prevent concurrent event - ;; processing; see with-event-queue. - ) - -(defun display-force-output (display) - ;; Output is normally buffered; this forces any buffered output. - (declare (type display display))) - -(defun display-finish-output (display) - ;; Forces output, then causes a round-trip to ensure that all possible errors and - ;; events have been received. - (declare (type display display))) - -(defun display-after-function (display) - ;; setf'able - ;; If defined, called after every protocol request is generated, even those inside - ;; explicit with-display's, but never called from inside the after-function itself. - ;; The function is called inside the effective with-display for the associated - ;; request. Default value is nil. Can be set, for example, to - ;; #'display-force-output or #'display-finish-output. - (declare (type display display) - (clx-values (or null (function (display)))))) - -(defun create-window (&key parent x y width height (depth 0) (border-width 0) - (class :copy) (visual :copy) - background border gravity bit-gravity - backing-store backing-planes backing-pixel save-under - event-mask do-not-propagate-mask override-redirect - colormap cursor) - ;; Display is obtained from parent. Only non-nil attributes are passed on in the - ;; request: the function makes no assumptions about what the actual protocol - ;; defaults are. Width and height are the inside size, excluding border. - (declare (type window parent) - (type int16 x y) - (type card16 width height depth border-width) - (type (member :copy :input-output :input-only) class) - (type (or (member :copy) visual-info) visual) - (type (or null (member :none :parent-relative) pixel pixmap) background) - (type (or null (member :copy) pixel pixmap) border) - (type (or null win-gravity) gravity) - (type (or null bit-gravity) bit-gravity) - (type (or null (member :not-useful :when-mapped :always) backing-store)) - (type (or null pixel) backing-planes backing-pixel) - (type (or null event-mask) event-mask) - (type (or null device-event-mask) do-not-propagate-mask) - (type (or null (member :on :off)) save-under override-redirect) - (type (or null (member :copy) colormap) colormap) - (type (or null (member :none) cursor) cursor) - (clx-values window))) - -(defun window-class (window) - (declare (type window window) - (clx-values (member :input-output :input-only)))) - -(defun window-visual-info (window) - (declare (type window window) - (clx-values visual-info))) - -(defun window-visual (window) - (declare (type window window) - (clx-values resource-id))) - -(defsetf window-background (window) (background) - (declare (type window window) - (type (or (member :none :parent-relative) pixel pixmap) background))) - -(defsetf window-border (window) (border) - (declare (type window window) - (type (or (member :copy) pixel pixmap) border))) - -(defun window-gravity (window) - ;; setf'able - (declare (type window window) - (clx-values win-gravity))) - -(defun window-bit-gravity (window) - ;; setf'able - (declare (type window window) - (clx-values bit-gravity))) - -(defun window-backing-store (window) - ;; setf'able - (declare (type window window) - (clx-values (member :not-useful :when-mapped :always)))) - -(defun window-backing-planes (window) - ;; setf'able - (declare (type window window) - (clx-values pixel))) - -(defun window-backing-pixel (window) - ;; setf'able - (declare (type window window) - (clx-values pixel))) - -(defun window-save-under (window) - ;; setf'able - (declare (type window window) - (clx-values (member :on :off)))) - -(defun window-event-mask (window) - ;; setf'able - (declare (type window window) - (clx-values mask32))) - -(defun window-do-not-propagate-mask (window) - ;; setf'able - (declare (type window window) - (clx-values mask32))) - -(defun window-override-redirect (window) - ;; setf'able - (declare (type window window) - (clx-values (member :on :off)))) - -(defun window-colormap (window) - (declare (type window window) - (clx-values (or null colormap)))) - -(defsetf window-colormap (window) (colormap) - (declare (type window window) - (type (or (member :copy) colormap) colormap))) - -(defsetf window-cursor (window) (cursor) - (declare (type window window) - (type (or (member :none) cursor) cursor))) - -(defun window-colormap-installed-p (window) - (declare (type window window) - (clx-values boolean))) - -(defun window-all-event-masks (window) - (declare (type window window) - (clx-values mask32))) - -(defun window-map-state (window) - (declare (type window window) - (clx-values (member :unmapped :unviewable :viewable)))) - -(defsetf drawable-x (window) (x) - (declare (type window window) - (type int16 x))) - -(defsetf drawable-y (window) (y) - (declare (type window window) - (type int16 y))) - -(defsetf drawable-width (window) (width) - ;; Inside width, excluding border. - (declare (type window window) - (type card16 width))) - -(defsetf drawable-height (window) (height) - ;; Inside height, excluding border. - (declare (type window window) - (type card16 height))) - -(defsetf drawable-border-width (window) (border-width) - (declare (type window window) - (type card16 border-width))) - -(defsetf window-priority (window &optional sibling) (mode) - ;; A bit strange, but retains setf form. - (declare (type window window) - (type (or null window) sibling) - (type (member :above :below :top-if :bottom-if :opposite) mode))) - -(defmacro with-state ((drawable) &body body) - ;; Allows a consistent view to be obtained of data returned by GetWindowAttributes - ;; and GetGeometry, and allows a coherent update using ChangeWindowAttributes and - ;; ConfigureWindow. The body is not surrounded by a with-display. Within the - ;; indefinite scope of the body, on a per-process basis in a multi-process - ;; environment, the first call within an Accessor Group on the specified drawable - ;; (the object, not just the variable) causes the complete results of the protocol - ;; request to be retained, and returned in any subsequent accessor calls. Calls - ;; within a Setf Group are delayed, and executed in a single request on exit from - ;; the body. In addition, if a call on a function within an Accessor Group follows - ;; a call on a function in the corresponding Setf Group, then all delayed setfs for - ;; that group are executed, any retained accessor information for that group is - ;; discarded, the corresponding protocol request is (re)issued, and the results are - ;; (again) retained, and returned in any subsequent accessor calls. - - ;; Accessor Group A (for GetWindowAttributes): - ;; window-visual-info, window-visual, window-class, window-gravity, window-bit-gravity, - ;; window-backing-store, window-backing-planes, window-backing-pixel, - ;; window-save-under, window-colormap, window-colormap-installed-p, - ;; window-map-state, window-all-event-masks, window-event-mask, - ;; window-do-not-propagate-mask, window-override-redirect - - ;; Setf Group A (for ChangeWindowAttributes): - ;; window-gravity, window-bit-gravity, window-backing-store, window-backing-planes, - ;; window-backing-pixel, window-save-under, window-event-mask, - ;; window-do-not-propagate-mask, window-override-redirect, window-colormap, - ;; window-cursor - - ;; Accessor Group G (for GetGeometry): - ;; drawable-root, drawable-depth, drawable-x, drawable-y, drawable-width, - ;; drawable-height, drawable-border-width - - ;; Setf Group G (for ConfigureWindow): - ;; drawable-x, drawable-y, drawable-width, drawable-height, drawable-border-width, - ;; window-priority - ) - -(defun destroy-window (window) - (declare (type window window))) - -(defun destroy-subwindows (window) - (declare (type window window))) - -(defun add-to-save-set (window) - (declare (type window window))) - -(defun remove-from-save-set (window) - (declare (type window window))) - -(defun reparent-window (window parent x y) - (declare (type window window parent) - (type int16 x y))) - -(defun map-window (window) - (declare (type window window))) - -(defun map-subwindows (window) - (declare (type window window))) - -(defun unmap-window (window) - (declare (type window window))) - -(defun unmap-subwindows (window) - (declare (type window window))) - -(defun circulate-window-up (window) - (declare (type window window))) - -(defun circulate-window-down (window) - (declare (type window window))) - -(defun drawable-root (drawable) - (declare (type drawable drawable) - (clx-values window))) - -(defun drawable-depth (drawable) - (declare (type drawable drawable) - (clx-values card8))) - -(defun drawable-x (drawable) - (declare (type drawable drawable) - (clx-values int16))) - -(defun drawable-y (drawable) - (declare (type drawable drawable) - (clx-values int16))) - -(defun drawable-width (drawable) - ;; For windows, inside width, excluding border. - (declare (type drawable drawable) - (clx-values card16))) - -(defun drawable-height (drawable) - ;; For windows, inside height, excluding border. - (declare (type drawable drawable) - (clx-values card16))) - -(defun drawable-border-width (drawable) - (declare (type drawable drawable) - (clx-values card16))) - -(defun query-tree (window &key (result-type 'list)) - (declare (type window window) - (type type result-type) - (clx-values (clx-sequence window) parent root))) - -(defun change-property (window property data type format - &key (mode :replace) (start 0) end transform) - ;; Start and end affect sub-sequence extracted from data. - ;; Transform is applied to each extracted element. - (declare (type window window) - (type xatom property type) - (type (member 8 16 32) format) - (type sequence data) - (type (member :replace :prepend :append) mode) - (type array-index start) - (type (or null array-index) end) - (type (or null (function (t) integer)) transform))) - -(defun delete-property (window property) - (declare (type window window) - (type xatom property))) - -(defun get-property (window property - &key type (start 0) end delete-p (result-type 'list) transform) - ;; Transform is applied to each integer retrieved. - ;; Nil is returned for type when the protocol returns None. - (declare (type window window) - (type xatom property) - (type (or null xatom) type) - (type array-index start) - (type (or null array-index) end) - (type boolean delete-p) - (type type result-type) - (type (or null (function (integer) t)) transform) - (clx-values data type format bytes-after))) - -(defun rotate-properties (window properties &optional (delta 1)) - ;; Postive rotates left, negative rotates right (opposite of actual protocol request). - (declare (type window window) - (type (clx-sequence xatom) properties) - (type int16 delta))) - -(defun list-properties (window &key (result-type 'list)) - (declare (type window window) - (type type result-type) - (clx-values (clx-sequence keyword)))) - -;; Although atom-ids are not visible in the normal user interface, atom-ids might -;; appear in window properties and other user data, so conversion hooks are needed. - -(defun intern-atom (display name) - (declare (type display display) - (type xatom name) - (clx-values resource-id))) - -(defun find-atom (display name) - (declare (type display display) - (type xatom name) - (clx-values (or null resource-id)))) - -(defun atom-name (display atom-id) - (declare (type display display) - (type resource-id atom-id) - (clx-values keyword))) - -(defun selection-owner (display selection) - (declare (type display display) - (type xatom selection) - (clx-values (or null window)))) - -(defsetf selection-owner (display selection &optional time) (owner) - ;; A bit strange, but retains setf form. - (declare (type display display) - (type xatom selection) - (type (or null window) owner) - (type timestamp time))) - -(defun convert-selection (selection type requestor &optional property time) - (declare (type xatom selection type) - (type window requestor) - (type (or null xatom) property) - (type timestamp time))) - -(defun send-event (window event-key event-mask &rest args - &key propagate-p display &allow-other-keys) - ;; Additional arguments depend on event-key, and are as specified further below - ;; with declare-event, except that both resource-ids and resource objects are - ;; accepted in the event components. The display argument is only required if the - ;; window is :pointer-window or :input-focus. If an argument has synonyms, it is - ;; only necessary to supply a value for one of them; it is an error to specify - ;; different values for synonyms. - (declare (type (or window (member :pointer-window :input-focus)) window) - (type (or null event-key) event-key) - (type event-mask event-mask) - (type boolean propagate-p) - (type (or null display) display))) - -(defun grab-pointer (window event-mask - &key owner-p sync-pointer-p sync-keyboard-p confine-to cursor time) - (declare (type window window) - (type pointer-event-mask event-mask) - (type boolean owner-p sync-pointer-p sync-keyboard-p) - (type (or null window) confine-to) - (type (or null cursor) cursor) - (type timestamp time) - (clx-values grab-status))) - -(defun ungrab-pointer (display &key time) - (declare (type display display) - (type timestamp time))) - -(defun grab-button (window button event-mask - &key (modifiers 0) - owner-p sync-pointer-p sync-keyboard-p confine-to cursor) - (declare (type window window) - (type (or (member :any) card8) button) - (type modifier-mask modifiers) - (type pointer-event-mask event-mask) - (type boolean owner-p sync-pointer-p sync-keyboard-p) - (type (or null window) confine-to) - (type (or null cursor) cursor))) - -(defun ungrab-button (window button &key (modifiers 0)) - (declare (type window window) - (type (or (member :any) card8) button) - (type modifier-mask modifiers))) - -(defun change-active-pointer-grab (display event-mask &optional cursor time) - (declare (type display display) - (type pointer-event-mask event-mask) - (type (or null cursor) cursor) - (type timestamp time))) - -(defun grab-keyboard (window &key owner-p sync-pointer-p sync-keyboard-p time) - (declare (type window window) - (type boolean owner-p sync-pointer-p sync-keyboard-p) - (type timestamp time) - (clx-values grab-status))) - -(defun ungrab-keyboard (display &key time) - (declare (type display display) - (type timestamp time))) - -(defun grab-key (window key &key (modifiers 0) owner-p sync-pointer-p sync-keyboard-p) - (declare (type window window) - (type boolean owner-p sync-pointer-p sync-keyboard-p) - (type (or (member :any) card8) key) - (type modifier-mask modifiers))) - -(defun ungrab-key (window key &key (modifiers 0)) - (declare (type window window) - (type (or (member :any) card8) key) - (type modifier-mask modifiers))) - -(defun allow-events (display mode &optional time) - (declare (type display display) - (type (member :async-pointer :sync-pointer :reply-pointer - :async-keyboard :sync-keyboard :replay-keyboard - :async-both :sync-both) - mode) - (type timestamp time))) - -(defun grab-server (display) - (declare (type display display))) - -(defun ungrab-server (display) - (declare (type display display))) - -(defmacro with-server-grabbed ((display) &body body) - ;; The body is not surrounded by a with-display. - ) - -(defun query-pointer (window) - (declare (type window window) - (clx-values x y same-screen-p child mask root-x root-y root))) - -(defun pointer-position (window) - (declare (type window window) - (clx-values x y same-screen-p))) - -(defun global-pointer-position (display) - (declare (type display display) - (clx-values root-x root-y root))) - -(defun motion-events (window &key start stop (result-type 'list)) - (declare (type window window) - (type timestamp start stop) - (type type result-type) - (clx-values (repeat-seq (int16 x) (int16 y) (timestamp time))))) - -(defun translate-coordinates (src src-x src-y dst) - ;; If src and dst are not on the same screen, nil is returned. - (declare (type window src) - (type int16 src-x src-y) - (type window dst) - (clx-values dst-x dst-y child))) - -(defun warp-pointer (dst dst-x dst-y) - (declare (type window dst) - (type int16 dst-x dst-y))) - -(defun warp-pointer-relative (display x-off y-off) - (declare (type display display) - (type int16 x-off y-off))) - -(defun warp-pointer-if-inside (dst dst-x dst-y src src-x src-y - &optional src-width src-height) - ;; Passing in a zero src-width or src-height is a no-op. A null src-width or - ;; src-height translates into a zero value in the protocol request. - (declare (type window dst src) - (type int16 dst-x dst-y src-x src-y) - (type (or null card16) src-width src-height))) - -(defun warp-pointer-relative-if-inside (x-off y-off src src-x src-y - &optional src-width src-height) - ;; Passing in a zero src-width or src-height is a no-op. A null src-width or - ;; src-height translates into a zero value in the protocol request. - (declare (type window src) - (type int16 x-off y-off src-x src-y) - (type (or null card16) src-width src-height))) - -(defun set-input-focus (display focus revert-to &optional time) - ;; Setf ought to allow multiple values. - (declare (type display display) - (type (or (member :none :pointer-root) window) focus) - (type (member :none :parent :pointer-root) revert-to) - (type timestamp time))) - -(defun input-focus (display) - (declare (type display display) - (clx-values focus revert-to))) - -(defun query-keymap (display) - (declare (type display display) - (clx-values (bit-vector 256)))) - -(defun open-font (display name) - ;; Font objects may be cached and reference counted locally within the display - ;; object. This function might not execute a with-display if the font is cached. - ;; The protocol QueryFont request happens on-demand under the covers. - (declare (type display display) - (type stringable name) - (clx-values font))) - -;; We probably want a per-font bit to indicate whether caching on -;; text-extents/width calls is desirable. But what to name it? - -(defun discard-font-info (font) - ;; Discards any state that can be re-obtained with QueryFont. This is simply - ;; a performance hint for memory-limited systems. - (declare (type font font))) - -;; This can be signalled anywhere a pseudo font access fails. - -(define-condition invalid-font error - font) - -;; Note: font-font-info removed. - -(defun font-name (font) - ;; Returns nil for a pseudo font returned by gcontext-font. - (declare (type font font) - (clx-values (or null string)))) - -(defun font-direction (font) - (declare (type font font) - (clx-values draw-direction))) - -(defun font-min-char (font) - (declare (type font font) - (clx-values card16))) - -(defun font-max-char (font) - (declare (type font font) - (clx-values card16))) - -(defun font-min-byte1 (font) - (declare (type font font) - (clx-values card8))) - -(defun font-max-byte1 (font) - (declare (type font font) - (clx-values card8))) - -(defun font-min-byte2 (font) - (declare (type font font) - (clx-values card8))) - -(defun font-max-byte2 (font) - (declare (type font font) - (clx-values card8))) - -(defun font-all-chars-exist-p (font) - (declare (type font font) - (clx-values boolean))) - -(defun font-default-char (font) - (declare (type font font) - (clx-values card16))) - -(defun font-ascent (font) - (declare (type font font) - (clx-values int16))) - -(defun font-descent (font) - (declare (type font font) - (clx-values int16))) - -;; The list contains alternating keywords and int32s. - -(deftype font-props () 'list) - -(defun font-properties (font) - (declare (type font font) - (clx-values font-props))) - -(defun font-property (font name) - (declare (type font font) - (type keyword name) - (clx-values (or null int32)))) - -;; For each of left-bearing, right-bearing, width, ascent, descent, attributes: - -(defun char- (font index) - ;; Note: I have tentatively chosen to return nil for an out-of-bounds index - ;; (or an in-bounds index on a pseudo font), although returning zero or - ;; signalling might be better. - (declare (type font font) - (type card16 index) - (clx-values (or null int16)))) - -(defun max-char- (font) - ;; Note: I have tentatively chosen separate accessors over allowing :min and - ;; :max as an index above. - (declare (type font font) - (clx-values int16))) - -(defun min-char- (font) - (declare (type font font) - (clx-values int16))) - -;; Note: char16- accessors could be defined to accept two-byte indexes. - -(defun close-font (font) - ;; This might not generate a protocol request if the font is reference - ;; counted locally or if it is a pseudo font. - (declare (type font font))) - -(defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list)) - (declare (type display display) - (type string pattern) - (type card16 max-fonts) - (type type result-type) - (clx-values (clx-sequence string)))) - -(defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list)) - ;; Returns "pseudo" fonts that contain basic font metrics and properties, but - ;; no per-character metrics and no resource-ids. These pseudo fonts will be - ;; converted (internally) to real fonts dynamically as needed, by issuing an - ;; OpenFont request. However, the OpenFont might fail, in which case the - ;; invalid-font error can arise. - (declare (type display display) - (type string pattern) - (type card16 max-fonts) - (type type result-type) - (clx-values (clx-sequence font)))) - -(defun font-path (display &key (result-type 'list)) - (declare (type display display) - (type type result-type) - (clx-values (clx-sequence (or string pathname))))) - -(defsetf font-path (display) (paths) - (declare (type display display) - (type (clx-sequence (or string pathname)) paths))) - -(defun create-pixmap (&key width height depth drawable) - (declare (type card16 width height) - (type card8 depth) - (type drawable drawable) - (clx-values pixmap))) - -(defun free-pixmap (pixmap) - (declare (type pixmap pixmap))) - -(defun create-gcontext (&key drawable function plane-mask foreground background - line-width line-style cap-style join-style fill-style fill-rule - arc-mode tile stipple ts-x ts-y font subwindow-mode - exposures clip-x clip-y clip-mask clip-ordering - dash-offset dashes - (cache-p t)) - ;; Only non-nil components are passed on in the request, but for effective caching - ;; assumptions have to be made about what the actual protocol defaults are. For - ;; all gcontext components, a value of nil causes the default gcontext value to be - ;; used. For clip-mask, this implies that an empty rect-seq cannot be represented - ;; as a list. Note: use of stringable as font will cause an implicit open-font. - ;; Note: papers over protocol SetClipRectangles and SetDashes special cases. If - ;; cache-p is true, then gcontext state is cached locally, and changing a gcontext - ;; component will have no effect unless the new value differs from the cached - ;; value. Component changes (setfs and with-gcontext) are always deferred - ;; regardless of the cache mode, and sent over the protocol only when required by a - ;; local operation or by an explicit call to force-gcontext-changes. - (declare (type drawable drawable) - (type (or null boole-constant) function) - (type (or null pixel) plane-mask foreground background) - (type (or null card16) line-width dash-offset) - (type (or null int16) ts-x ts-y clip-x clip-y) - (type (or null (member :solid :dash :double-dash)) line-style) - (type (or null (member :not-last :butt :round :projecting)) cap-style) - (type (or null (member :miter :round :bevel)) join-style) - (type (or null (member :solid :tiled :opaque-stippled :stippled)) fill-style) - (type (or null (member :even-odd :winding)) fill-rule) - (type (or null (member :chord :pie-slice)) arc-mode) - (type (or null pixmap) tile stipple) - (type (or null fontable) font) - (type (or null (member :clip-by-children :include-inferiors)) subwindow-mode) - (type (or null (member :on :off)) exposures) - (type (or null (member :none) pixmap rect-seq) clip-mask) - (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering) - (type (or null (or card8 (clx-sequence card8))) dashes) - (type boolean cache) - (clx-values gcontext))) - -;; For each argument to create-gcontext (except font, clip-mask and -;; clip-ordering) declared as (type ), there is an accessor: - -(defun gcontext- (gcontext) - ;; The value will be nil if the last value stored is unknown (e.g., the cache was - ;; off, or the component was copied from a gcontext with unknown state). - (declare (type gcontext gcontext) - (clx-values ))) - -;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared -;; as (type (or null ) ), there is a setf for the corresponding accessor: - -(defsetf gcontext- (gcontext) (value) - (declare (type gcontext gcontext) - (type value))) - -(defun gcontext-font (gcontext &optional metrics-p) - ;; If the stored font is known, it is returned. If it is not known and - ;; metrics-p is false, then nil is returned. If it is not known and - ;; metrics-p is true, then a pseudo font is returned. Full metric and - ;; property information can be obtained, but the font does not have a name or - ;; a resource-id, and attempts to use it where a resource-id is required will - ;; result in an invalid-font error. - (declare (type gcontext gcontext) - (type boolean metrics-p) - (clx-values (or null font)))) - -(defun gcontext-clip-mask (gcontext) - (declare (type gcontext gcontext) - (clx-values (or null (member :none) pixmap rect-seq) - (or null (member :unsorted :y-sorted :yx-sorted :yx-banded))))) - -(defsetf gcontext-clip-mask (gcontext &optional ordering) (clip-mask) - ;; Is nil illegal here, or is it transformed to a vector? - ;; A bit strange, but retains setf form. - (declare (type gcontext gcontext) - (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering) - (type (or (member :none) pixmap rect-seq) clip-mask))) - -(defun force-gcontext-changes (gcontext) - ;; Force any delayed changes. - (declare (type gcontext gcontext))) - -(defmacro with-gcontext ((gcontext &key - function plane-mask foreground background - line-width line-style cap-style join-style fill-style fill-rule - arc-mode tile stipple ts-x ts-y font subwindow-mode - exposures clip-x clip-y clip-mask clip-ordering - dashes dash-offset) - &body body) - ;; Changes gcontext components within the dynamic scope of the body (i.e., - ;; indefinite scope and dynamic extent), on a per-process basis in a multi-process - ;; environment. The values are all evaluated before bindings are performed. The - ;; body is not surrounded by a with-display. If cache-p is nil or the some - ;; component states are unknown, this will implement save/restore by creating a - ;; temporary gcontext and doing gcontext-components to and from it. - ) - -(defun copy-gcontext-components (src dst &rest keys) - (declare (type gcontext src dst) - (type (clx-list gcontext-key) keys))) - -(defun copy-gcontext (src dst) - (declare (type gcontext src dst)) - ;; Copies all components. - ) - -(defun free-gcontext (gcontext) - (declare (type gcontext gcontext))) - -(defun clear-area (window &key (x 0) (y 0) width height exposures-p) - ;; Passing in a zero width or height is a no-op. A null width or height translates - ;; into a zero value in the protocol request. - (declare (type window window) - (type int16 x y) - (type (or null card16) width height) - (type boolean exposures-p))) - -(defun copy-area (src gcontext src-x src-y width height dst dst-x dst-y) - (declare (type drawable src dst) - (type gcontext gcontext) - (type int16 src-x src-y dst-x dst-y) - (type card16 width height))) - -(defun copy-plane (src gcontext plane src-x src-y width height dst dst-x dst-y) - (declare (type drawable src dst) - (type gcontext gcontext) - (type pixel plane) - (type int16 src-x src-y dst-x dst-y) - (type card16 width height))) - -(defun draw-point (drawable gcontext x y) - ;; Should be clever about appending to existing buffered protocol request, provided - ;; gcontext has not been modified. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y))) - -(defun draw-points (drawable gcontext points &optional relative-p) - (declare (type drawable drawable) - (type gcontext gcontext) - (type point-seq points) - (type boolean relative-p))) - -(defun draw-line (drawable gcontext x1 y1 x2 y2 &optional relative-p) - ;; Should be clever about appending to existing buffered protocol request, provided - ;; gcontext has not been modified. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x1 y1 x2 y2) - (type boolean relative-p))) - -(defun draw-lines (drawable gcontext points &key relative-p fill-p (shape :complex)) - (declare (type drawable drawable) - (type gcontext gcontext) - (type point-seq points) - (type boolean relative-p fill-p) - (type (member :complex :non-convex :convex) shape))) - -(defun draw-segments (drawable gcontext segments) - (declare (type drawable drawable) - (type gcontext gcontext) - (type seg-seq segments))) - -(defun draw-rectangle (drawable gcontext x y width height &optional fill-p) - ;; Should be clever about appending to existing buffered protocol request, provided - ;; gcontext has not been modified. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type card16 width height) - (type boolean fill-p))) - -(defun draw-rectangles (drawable gcontext rectangles &optional fill-p) - (declare (type drawable drawable) - (type gcontext gcontext) - (type rect-seq rectangles) - (type boolean fill-p))) - -(defun draw-arc (drawable gcontext x y width height angle1 angle2 &optional fill-p) - ;; Should be clever about appending to existing buffered protocol request, provided - ;; gcontext has not been modified. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type card16 width height) - (type angle angle1 angle2) - (type boolean fill-p))) - -(defun draw-arcs (drawable gcontext arcs &optional fill-p) - (declare (type drawable drawable) - (type gcontext gcontext) - (type arc-seq arcs) - (type boolean fill-p))) - -;; The following image routines are bare minimum. It may be useful to define some -;; form of "image" object to hide representation details and format conversions. It -;; also may be useful to provide stream-oriented interfaces for reading and writing -;; the data. - -(defun put-raw-image (drawable gcontext data - &key (start 0) depth x y width height (left-pad 0) format) - ;; Data must be a sequence of 8-bit quantities, already in the appropriate format - ;; for transmission; the caller is responsible for all byte and bit swapping and - ;; compaction. Start is the starting index in data; the end is computed from the - ;; other arguments. - (declare (type drawable drawable) - (type gcontext gcontext) - (type (clx-sequence card8) data) - (type array-index start) - (type card8 depth left-pad) - (type int16 x y) - (type card16 width height) - (type (member :bitmap :xy-pixmap :z-pixmap) format))) - -(defun get-raw-image (drawable &key data (start 0) x y width height - (plane-mask 0xffffffff) format - (result-type '(vector (unsigned-byte 8)))) - ;; If data is given, it is modified in place (and returned), otherwise a new - ;; sequence is created and returned, with a size computed from the other arguments - ;; and the returned depth. The sequence is filled with 8-bit quantities, in - ;; transmission format; the caller is responsible for any byte and bit swapping and - ;; compaction required for further local use. - (declare (type drawable drawable) - (type (or null (clx-sequence card8)) data) - (type array-index start) - (type int16 x y) - (type card16 width height) - (type pixel plane-mask) - (type (member :xy-pixmap :z-pixmap) format) - (clx-values (clx-sequence card8) depth visual-info))) - -(defun translate-default (src src-start src-end font dst dst-start) - ;; dst is guaranteed to have room for (- src-end src-start) integer elements, - ;; starting at dst-start; whether dst holds 8-bit or 16-bit elements depends - ;; on context. font is the current font, if known. The function should - ;; translate as many elements of src as possible into indexes in the current - ;; font, and store them into dst. The first return value should be the src - ;; index of the first untranslated element. If no further elements need to - ;; be translated, the second return value should be nil. If a horizontal - ;; motion is required before further translation, the second return value - ;; should be the delta in x coordinate. If a font change is required for - ;; further translation, the second return value should be the new font. If - ;; known, the pixel width of the translated text can be returned as the third - ;; value; this can allow for appending of subsequent output to the same - ;; protocol request, if no overall width has been specified at the higher - ;; level. - (declare (type sequence src) - (type array-index src-start src-end dst-start) - (type (or null font) font) - (type vector dst) - (clx-values array-index (or null int16 font) (or null int32)))) - -;; There is a question below of whether translate should always be required, or -;; if not, what the default should be or where it should come from. For -;; example, the default could be something that expected a string as src and -;; translated the CL standard character set to ASCII indexes, and ignored fonts -;; and bits. Or the default could expect a string but otherwise be "system -;; dependent". Or the default could be something that expected a vector of -;; integers and did no translation. Or the default could come from the -;; gcontext (but what about text-extents and text-width?). - -(defun text-extents (font sequence &key (start 0) end translate) - ;; If multiple fonts are involved, font-ascent and font-descent will be the - ;; maximums. If multiple directions are involved, the direction will be nil. - ;; Translate will always be called with a 16-bit dst buffer. - (declare (type sequence sequence) - (type (or font gcontext) font) - (type translate translate) - (clx-values width ascent descent left right font-ascent font-descent direction - (or null array-index)))) - -(defun text-width (font sequence &key (start 0) end translate) - ;; Translate will always be called with a 16-bit dst buffer. - (declare (type sequence sequence) - (type (or font gcontext) font) - (type translate translate) - (clx-values int32 (or null array-index)))) - -;; This controls the element size of the dst buffer given to translate. If -;; :default is specified, the size will be based on the current font, if known, -;; and otherwise 16 will be used. [An alternative would be to pass the buffer -;; size to translate, and allow it to return the desired size if it doesn't -;; like the current size. The problem is that the protocol doesn't allow -;; switching within a single request, so to allow switching would require -;; knowing the width of text, which isn't necessarily known. We could call -;; text-width to compute it, but perhaps that is doing too many favors?] [An -;; additional possibility is to allow an index-size of :two-byte, in which case -;; translate would be given a double-length 8-bit array, and translate would be -;; expected to store first-byte/second-byte instead of 16-bit integers.] - -(deftype index-size () '(member :default 8 16)) - -;; In the glyph functions below, if width is specified, it is assumed to be the -;; total pixel width of whatever string of glyphs is actually drawn. -;; Specifying width will allow for appending the output of subsequent calls to -;; the same protocol request, provided gcontext has not been modified in the -;; interim. If width is not specified, appending of subsequent output might -;; not occur (unless translate returns the width). Specifying width is simply -;; a hint, for performance. - -(defun draw-glyph (drawable gcontext x y elt - &key translate width (size :default)) - ;; Returns true if elt is output, nil if translate refuses to output it. - ;; Second result is width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type translate translate) - (type (or null int32) width) - (type index-size size) - (clx-values boolean (or null int32)))) - -(defun draw-glyphs (drawable gcontext x y sequence - &key (start 0) end translate width (size :default)) - ;; First result is new start, if end was not reached. Second result is - ;; overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type sequence sequence) - (type array-index start) - (type (or null array-index) end) - (type (or null int32) width) - (type translate translate) - (type index-size size) - (clx-values (or null array-index) (or null int32)))) - -(defun draw-image-glyph (drawable gcontext x y elt - &key translate width (size :default)) - ;; Returns true if elt is output, nil if translate refuses to output it. - ;; Second result is overall width, if known. An initial font change is - ;; allowed from translate. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type translate translate) - (type (or null int32) width) - (type index-size size) - (clx-values boolean (or null int32)))) - -(defun draw-image-glyphs (drawable gcontext x y sequence - &key (start 0) end width translate (size :default)) - ;; An initial font change is allowed from translate, but any subsequent font - ;; change or horizontal motion will cause termination (because the protocol - ;; doesn't support chaining). [Alternatively, font changes could be accepted - ;; as long as they are accompanied with a width return value, or always - ;; accept font changes and call text-width as required. However, horizontal - ;; motion can't really be accepted, due to semantics.] First result is new - ;; start, if end was not reached. Second result is overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type sequence sequence) - (type array-index start) - (type (or null array-index) end) - (type (or null int32) width) - (type translate translate) - (type index-size size) - (clx-values (or null array-index) (or null int32)))) - -(defun create-colormap (visual window &optional alloc-p) - (declare (type visual-info visual) - (type window window) - (type boolean alloc-p) - (clx-values colormap))) - -(defun free-colormap (colormap) - (declare (type colormap colormap))) - -(defun copy-colormap-and-free (colormap) - (declare (type colormap colormap) - (clx-values colormap))) - -(defun install-colormap (colormap) - (declare (type colormap colormap))) - -(defun uninstall-colormap (colormap) - (declare (type colormap colormap))) - -(defun installed-colormaps (window &key (result-type 'list)) - (declare (type window window) - (type type result-type) - (clx-values (clx-sequence colormap)))) - -(defun alloc-color (colormap color) - (declare (type colormap colormap) - (type (or stringable color) color) - (clx-values pixel screen-color exact-color))) - -(defun alloc-color-cells (colormap colors &key (planes 0) contiguous-p (result-type 'list)) - (declare (type colormap colormap) - (type card16 colors planes) - (type boolean contiguous-p) - (type type result-type) - (clx-values (clx-sequence pixel) (clx-sequence mask)))) - -(defun alloc-color-planes (colormap colors - &key (reds 0) (greens 0) (blues 0) - contiguous-p (result-type 'list)) - (declare (type colormap colormap) - (type card16 colors reds greens blues) - (type boolean contiguous-p) - (type type result-type) - (clx-values (clx-sequence pixel) red-mask green-mask blue-mask))) - -(defun free-colors (colormap pixels &optional (plane-mask 0)) - (declare (type colormap colormap) - (type (clx-sequence pixel) pixels) - (type pixel plane-mask))) - -(defun store-color (colormap pixel spec &key (red-p t) (green-p t) (blue-p t)) - (declare (type colormap colormap) - (type pixel pixel) - (type (or stringable color) spec) - (type boolean red-p green-p blue-p))) - -(defun store-colors (colormap specs &key (red-p t) (green-p t) (blue-p t)) - ;; If stringables are specified for colors, it is unspecified whether all - ;; stringables are first resolved and then a single StoreColors protocol request is - ;; issued, or whether multiple StoreColors protocol requests are issued. - (declare (type colormap colormap) - (type (repeat-seq (pixel pixel) ((or stringable color) color)) specs) - (type boolean red-p green-p blue-p))) - -(defun query-colors (colormap pixels &key (result-type 'list)) - (declare (type colormap colormap) - (type (clx-sequence pixel) pixels) - (type type result-type) - (clx-values (clx-sequence color)))) - -(defun lookup-color (colormap name) - (declare (type colormap colormap) - (type stringable name) - (clx-values screen-color true-color))) - -(defun create-cursor (&key source mask x y foreground background) - (declare (type pixmap source) - (type (or null pixmap) mask) - (type card16 x y) - (type color foreground background) - (clx-values cursor))) - -(defun create-glyph-cursor (&key source-font source-char mask-font mask-char - foreground background) - (declare (type font source-font) - (type card16 source-char) - (type (or null font) mask-font) - (type (or null card16) mask-char) - (type color foreground background) - (clx-values cursor))) - -(defun free-cursor (cursor) - (declare (type cursor cursor))) - -(defun recolor-cursor (cursor foreground background) - (declare (type cursor cursor) - (type color foreground background))) - -(defun query-best-cursor (width height drawable) - (declare (type card16 width height) - (type drawable display) - (clx-values width height))) - -(defun query-best-tile (width height drawable) - (declare (type card16 width height) - (type drawable drawable) - (clx-values width height))) - -(defun query-best-stipple (width height drawable) - (declare (type card16 width height) - (type drawable drawable) - (clx-values width height))) - -(defun query-extension (display name) - (declare (type display display) - (type stringable name) - (clx-values major-opcode first-event first-error))) - -(defun list-extensions (display &key (result-type 'list)) - (declare (type display display) - (type type result-type) - (clx-values (clx-sequence string)))) - -;; Should pointer-mapping setf be changed to set-pointer-mapping? - -(defun set-modifier-mapping (display &key shift lock control mod1 mod2 mod3 mod4 mod5) - ;; Can signal device-busy. - ;; Setf ought to allow multiple values. - ;; Returns true for success, nil for failure - (declare (type display display) - (type (clx-sequence card8) shift lock control mod1 mod2 mod3 mod4 mod5) - (clx-values (member :success :busy :failed)))) - -(defun modifier-mapping (display) - ;; each value is a list of card8s - (declare (type display display) - (clx-values shift lock control mod1 mod2 mod3 mod4 mod5))) - -;; Either we will want lots of defconstants for well-known values, or perhaps -;; an integer-to-keyword translation function for well-known values. - -(defun change-keyboard-mapping (display keysyms - &key (start 0) end (first-keycode start)) - ;; start/end give subrange of keysyms - ;; first-keycode is the first-keycode to store at - (declare (type display display) - (type (array * (* *)) keysyms) - (type array-index start) - (type (or null array-index) end) - (type card8 first-keycode))) - -(defun keyboard-mapping (display &key first-keycode start end data) - ;; First-keycode specifies which keycode to start at (defaults to - ;; min-keycode). Start specifies where (in result) to put first-keycode - ;; (defaults to first-keycode). (- end start) is the number of keycodes to - ;; get (end defaults to (1+ max-keycode)). If data is specified, the results - ;; are put there. - (declare (type display display) - (type (or null card8) first-keycode) - (type (or null array-index) start end) - (type (or null (array * (* *))) data) - (clx-values (array * (* *))))) - -(defun change-keyboard-control (display &key key-click-percent - bell-percent bell-pitch bell-duration - led led-mode key auto-repeat-mode) - (declare (type display display) - (type (or null (member :default) int16) key-click-percent - bell-percent bell-pitch bell-duration) - (type (or null card8) led key) - (type (or null (member :on :off)) led-mode) - (type (or null (member :on :off :default)) auto-repeat-mode))) - -(defun keyboard-control (display) - (declare (type display display) - (clx-values key-click-percent bell-percent bell-pitch bell-duration - led-mask global-auto-repeat auto-repeats))) - -(defun bell (display &optional (percent-from-normal 0)) - ;; It is assumed that an eventual audio extension to X will provide more complete - ;; control. - (declare (type display display) - (type int8 percent-from-normal))) - -(defun pointer-mapping (display &key (result-type 'list)) - (declare (type display display) - (type type result-type) - (clx-values (clx-sequence card8)))) - -(defsetf pointer-mapping (display) (map) - ;; Can signal device-busy. - (declare (type display display) - (type (clx-sequence card8) map))) - -(defun change-pointer-control (display &key acceleration threshold) - ;; Acceleration is rationalized if necessary. - (declare (type display display) - (type (or null (member :default) number) acceleration) - (type (or null (member :default) integer) threshold))) - -(defun pointer-control (display) - (declare (type display display) - (clx-values acceleration threshold))) - -(defun set-screen-saver (display timeout interval blanking exposures) - ;; Setf ought to allow multiple values. - ;; Timeout and interval are in seconds, will be rounded to minutes. - (declare (type display display) - (type (or (member :default) int16) timeout interval) - (type (member :on :off :default) blanking exposures))) - -(defun screen-saver (display) - ;; Returns timeout and interval in seconds. - (declare (type display display) - (clx-values timeout interval blanking exposures))) - -(defun activate-screen-saver (display) - (declare (type display display))) - -(defun reset-screen-saver (display) - (declare (type display display))) - -(defun add-access-host (display host) - ;; A string must be acceptable as a host, but otherwise the possible types for host - ;; are not constrained, and will likely be very system dependent. - (declare (type display display))) - -(defun remove-access-host (display host) - ;; A string must be acceptable as a host, but otherwise the possible types for host - ;; are not constrained, and will likely be very system dependent. - (declare (type display display))) - -(defun access-hosts (display &key (result-type 'list)) - ;; The type of host objects returned is not constrained, except that the hosts must - ;; be acceptable to add-access-host and remove-access-host. - (declare (type display display) - (type type result-type) - (clx-values (clx-sequence host) enabled-p))) - -(defun access-control (display) - ;; setf'able - (declare (type display display) - (clx-values boolean))) - -(defun close-down-mode (display) - ;; setf'able - ;; Cached locally in display object. - (declare (type display display) - (clx-values (member :destroy :retain-permanent :retain-temporary)))) - -(defun kill-client (display resource-id) - (declare (type display display) - (type resource-id resource-id))) - -(defun kill-temporary-clients (display) - (declare (type display display))) - -(defun make-event-mask (&rest keys) - ;; This is only defined for core events. - ;; Useful for constructing event-mask, pointer-event-mask, device-event-mask. - (declare (type (clx-list event-mask-class) keys) - (clx-values mask32))) - -(defun make-event-keys (event-mask) - ;; This is only defined for core events. - (declare (type mask32 event-mask) - (clx-values (clx-list event-mask-class)))) - -(defun make-state-mask (&rest keys) - ;; Useful for constructing modifier-mask, state-mask. - (declare (type (clx-list state-mask-key) keys) - (clx-values mask16))) - -(defun make-state-keys (state-mask) - (declare (type mask16 mask) - (clx-values (clx-list state-mask-key)))) - -(defmacro with-event-queue ((display) &body body) - ;; Grants exclusive access to event queue. - ) - -(defun event-listen (display &optional (timeout 0)) - (declare (type display display) - (type (or null number) timeout) - (clx-values (or null number) (or null (member :timeout) (not null)))) - ;; Returns the number of events queued locally, if any, else nil. Hangs - ;; waiting for events, forever if timeout is nil, else for the specified - ;; number of seconds. The second value returned is :timeout if the - ;; operation timed out, and some other non-nil value if an EOF has been - ;; detected. - ) - -(defun process-event (display &key handler timeout peek-p discard-p (force-output-p t)) - ;; If force-output-p is true, first invokes display-force-output. Invokes - ;; handler on each queued event until handler returns non-nil, and that - ;; returned object is then returned by process-event. If peek-p is true, - ;; then the event is not removed from the queue. If discard-p is true, then - ;; events for which handler returns nil are removed from the queue, - ;; otherwise they are left in place. Hangs until non-nil is generated for - ;; some event, or for the specified timeout (in seconds, if given); however, - ;; it is acceptable for an implementation to wait only once on network data, - ;; and therefore timeout prematurely. Returns nil on timeout or EOF, with a - ;; second return value being :timeout for a timeout and some other non-nil - ;; value for EOF. If handler is a sequence, it is expected to contain - ;; handler functions specific to each event class; the event code is used to - ;; index the sequence, fetching the appropriate handler. The arguments to - ;; the handler are described further below using declare-event. If - ;; process-event is invoked recursively, the nested invocation begins with - ;; the event after the one currently being processed. - (declare (type display display) - (type (or (clx-sequence (function (&key &allow-other-keys) t)) - (function (&key &allow-other-keys) t)) - handler) - (type (or null number) timeout) - (type boolean peek-p))) - -(defun make-event-handlers (&key (type 'array) default) - (declare (type t type) ;Sequence type specifier - (type function default) - (clx-values sequence)) ;Default handler for initial content - ;; Makes a handler sequence suitable for process-event - ) - -(defun event-handler (handlers event-key) - (declare (type sequence handlers) - (type event-key event-key) - (clx-values function)) - ;; Accessor for a handler sequence - ) - -(defsetf event-handler (handlers event-key) (handler) - (declare (type sequence handlers) - (type event-key event-key) - (type function handler) - (clx-values function)) - ;; Setf accessor for a handler sequence - ) - -(defmacro event-case ((display &key timeout peek-p discard-p (force-output-p t)) - &body clauses) - (declare (arglist (display &key timeout peek-p discard-p force-output-p) - (event-or-events ((&rest args) |...|) &body body) |...|)) - ;; If force-output-p is true, first invokes display-force-output. Executes - ;; the matching clause for each queued event until a clause returns non-nil, - ;; and that returned object is then returned by event-case. If peek-p is - ;; true, then the event is not removed from the queue. If discard-p is - ;; true, then events for which the clause returns nil are removed from the - ;; queue, otherwise they are left in place. Hangs until non-nil is - ;; generated for some event, or for the specified timeout (in seconds, if - ;; given); however, it is acceptable for an implementation to wait only once - ;; on network data, and therefore timeout prematurely. Returns nil on - ;; timeout or EOF with a second return value being :timeout for a timeout - ;; and some other non-nil value for EOF. In each clause, event-or-events is - ;; an event-key or a list of event-keys (but they need not be typed as - ;; keywords) or the symbol t or otherwise (but only in the last clause). - ;; The keys are not evaluated, and it is an error for the same key to appear - ;; in more than one clause. Args is the list of event components of - ;; interest; corresponding values (if any) are bound to variables with these - ;; names (i.e., the args are variable names, not keywords, the keywords are - ;; derived from the variable names). An arg can also be a (keyword var) - ;; form, as for keyword args in a lambda lists. If no t/otherwise clause - ;; appears, it is equivalent to having one that returns nil. If - ;; process-event is invoked recursively, the nested invocation begins with - ;; the event after the one currently being processed. - ) - -(defmacro event-cond ((display &key timeout peek-p discard-p (force-output-p t)) - &body clauses) - ;; The clauses of event-cond are of the form: - ;; (event-or-events binding-list test-form . body-forms) - ;; - ;; EVENT-OR-EVENTS event-key or a list of event-keys (but they - ;; need not be typed as keywords) or the symbol t - ;; or otherwise (but only in the last clause). If - ;; no t/otherwise clause appears, it is equivalent - ;; to having one that returns nil. The keys are - ;; not evaluated, and it is an error for the same - ;; key to appear in more than one clause. - ;; - ;; BINDING-LIST The list of event components of interest. - ;; corresponding values (if any) are bound to - ;; variables with these names (i.e., the binding-list - ;; has variable names, not keywords, the keywords are - ;; derived from the variable names). An arg can also - ;; be a (keyword var) form, as for keyword args in a - ;; lambda list. - ;; - ;; The matching TEST-FORM for each queued event is executed until a - ;; clause's test-form returns non-nil. Then the BODY-FORMS are - ;; evaluated, returning the (possibly multiple) values of the last - ;; form from event-cond. If there are no body-forms then, if the - ;; test-form is non-nil, the value of the test-form is returned as a - ;; single value. - ;; - ;; Options: - ;; FORCE-OUTPUT-P When true, first invoke display-force-output if no - ;; input is pending. - ;; - ;; PEEK-P When true, then the event is not removed from the queue. - ;; - ;; DISCARD-P When true, then events for which the clause returns nil - ;; are removed from the queue, otherwise they are left in place. - ;; - ;; TIMEOUT If NIL, hang until non-nil is generated for some event's - ;; test-form. Otherwise return NIL after TIMEOUT seconds have - ;; elapsed. NIL is also returned whenever EOF is read. - ;; Whenever NIL is returned a second value is returned which - ;; is either :TIMEOUT if a timeout occurred or some other - ;; non-NIL value if an EOF is detected. - ;; - (declare (arglist (display &key timeout peek-p discard-p force-output-p) - (event-or-events (&rest args) test-form &body body) |...|)) - ) - -(defun discard-current-event (display) - (declare (type display display) - (clx-values boolean)) - ;; Discard the current event for DISPLAY. - ;; Returns NIL when the event queue is empty, else T. - ;; To ensure events aren't ignored, application code should only call - ;; this when throwing out of event-case or process-next-event, or from - ;; inside even-case, event-cond or process-event when :peek-p is T and - ;; :discard-p is NIL. - ) - -(defmacro declare-event (event-codes &rest declares) - ;; Used to indicate the keyword arguments for handler functions in process-event - ;; and event-case. In the declares, an argument listed as (name1 name2) indicates - ;; synonyms for the same argument. All process-event handlers can have - ;; (display display), (event-key event-key), and (boolean send-event-p) as keyword - ;; arguments, and an event-case clause can also have event-key and send-event-p as - ;; arguments. - (declare (arglist event-key-or-keys &rest (type &rest keywords)))) - -(declare-event (:key-press :key-release :button-press :button-release) - (card16 sequence) - (window (window event-window) root) - ((or null window) child) - (boolean same-screen-p) - (int16 x y root-x root-y) - (card16 state) - ((or null card32) time) - ;; for key-press and key-release, code is the keycode - ;; for button-press and button-release, code is the button number - (card8 code)) - -(declare-event :motion-notify - (card16 sequence) - (window (window event-window) root) - ((or null window) child) - (boolean same-screen-p) - (int16 x y root-x root-y) - (card16 state) - ((or null card32) time) - (boolean hint-p)) - -(declare-event (:enter-notify :leave-notify) - (card16 sequence) - (window (window event-window) root) - ((or null window) child) - (boolean same-screen-p) - (int16 x y root-x root-y) - (card16 state) - ((or null card32) time) - ((member :normal :grab :ungrab) mode) - ((member :ancestor :virtual :inferior :nonlinear :nonlinear-virtual) kind) - (boolean focus-p)) - -(declare-event (:focus-in :focus-out) - (card16 sequence) - (window (window event-window)) - ((member :normal :while-grabbed :grab :ungrab) mode) - ((member :ancestor :virtual :inferior :nonlinear :nonlinear-virtual - :pointer :pointer-root :none) - kind)) - -(declare-event :keymap-notify - ((bit-vector 256) keymap)) - -(declare-event :exposure - (card16 sequence) - (window (window event-window)) - (card16 x y width height count)) - -(declare-event :graphics-exposure - (card16 sequence) - (drawable (drawable event-window)) - (card16 x y width height count) - (card8 major) - (card16 minor)) - -(declare-event :no-exposure - (card16 sequence) - (drawable (drawable event-window)) - (card8 major) - (card16 minor)) - -(declare-event :visibility-notify - (card16 sequence) - (window (window event-window)) - ((member :unobscured :partially-obscured :fully-obscured) state)) - -(declare-event :create-notify - (card16 sequence) - (window window (parent event-window)) - (int16 x y) - (card16 width height border-width) - (boolean override-redirect-p)) - -(declare-event :destroy-notify - (card16 sequence) - (window event-window window)) - -(declare-event :unmap-notify - (card16 sequence) - (window event-window window) - (boolean configure-p)) - -(declare-event :map-notify - (card16 sequence) - (window event-window window) - (boolean override-redirect-p)) - -(declare-event :map-request - (card16 sequence) - (window (parent event-window) window)) - -(declare-event :reparent-notify - (card16 sequence) - (window event-window window parent) - (int16 x y) - (boolean override-redirect-p)) - -(declare-event :configure-notify - (card16 sequence) - (window event-window window) - (int16 x y) - (card16 width height border-width) - ((or null window) above-sibling) - (boolean override-redirect-p)) - -(declare-event :gravity-notify - (card16 sequence) - (window event-window window) - (int16 x y)) - -(declare-event :resize-request - (card16 sequence) - (window (window event-window)) - (card16 width height)) - -(declare-event :configure-request - (card16 sequence) - (window (parent event-window) window) - (int16 x y) - (card16 width height border-width) - ((member :above :below :top-if :bottom-if :opposite) stack-mode) - ((or null window) above-sibling) - (mask16 value-mask)) - -(declare-event :circulate-notify - (card16 sequence) - (window event-window window) - ((member :top :bottom) place)) - -(declare-event :circulate-request - (card16 sequence) - (window (parent event-window) window) - ((member :top :bottom) place)) - -(declare-event :property-notify - (card16 sequence) - (window (window event-window)) - (keyword atom) - ((member :new-value :deleted) state) - ((or null card32) time)) - -(declare-event :selection-clear - (card16 sequence) - (window (window event-window)) - (keyword selection) - ((or null card32) time)) - -(declare-event :selection-request - (card16 sequence) - (window (window event-window) requestor) - (keyword selection target) - ((or null keyword) property) - ((or null card32) time)) - -(declare-event :selection-notify - (card16 sequence) - (window (window event-window)) - (keyword selection target) - ((or null keyword) property) - ((or null card32) time)) - -(declare-event :colormap-notify - (card16 sequence) - (window (window event-window)) - ((or null colormap) colormap) - (boolean new-p installed-p)) - -(declare-event :mapping-notify - (card16 sequence) - ((member :modifier :keyboard :pointer) request) - (card8 start count)) - -(declare-event :client-message - (card16 sequence) - (window (window event-window)) - ((member 8 16 32) format) - (sequence data)) - -(defun queue-event (display event-key &rest args &key append-p &allow-other-keys) - ;; The event is put at the head of the queue if append-p is nil, else the tail. - ;; Additional arguments depend on event-key, and are as specified above with - ;; declare-event, except that both resource-ids and resource objects are accepted - ;; in the event components. - (declare (type display display) - (type event-key event-key) - (type boolean append-p))) - - - -;;; From here on, there has been less coherent review of the interface: - -;;;----------------------------------------------------------------------------- -;;; Window Manager Property functions - -(defun wm-name (window) - (declare (type window window) - (clx-values string))) - -(defsetf wm-name (window) (name)) - -(defun wm-icon-name (window) - (declare (type window window) - (clx-values string))) - -(defsetf wm-icon-name (window) (name)) - -(defun get-wm-class (window) - (declare (type window window) - (clx-values (or null name-string) (or null class-string)))) - -(defun set-wm-class (window resource-name resource-class) - (declare (type window window) - (type (or null stringable) resource-name resource-class))) - -(defun wm-command (window) - ;; Returns a list whose car is a command string and - ;; whose cdr is the list of argument strings. - (declare (type window window) - (clx-values (clx-list string)))) - -(defsetf wm-command (window) (command) - ;; Uses PRIN1 inside the ANSI common lisp form WITH-STANDARD-IO-SYNTAX (or - ;; equivalent), with elements of command separated by NULL characters. This - ;; enables - ;; (with-standard-io-syntax (mapcar #'read-from-string (wm-command window))) - ;; to recover a lisp command. - (declare (type window window) - (type (clx-list stringable) command))) - -(defun wm-client-machine (window) - ;; Returns a list whose car is a command string and - ;; whose cdr is the list of argument strings. - (declare (type window window) - (clx-values string))) - -(defsetf wm-client-machine (window) (string) - (declare (type window window) - (type stringable string))) - -(defstruct wm-hints - (input nil :type (or null (member :off :on))) - (initial-state nil :type (or null (member :normal :iconic))) - (icon-pixmap nil :type (or null pixmap)) - (icon-window nil :type (or null window)) - (icon-x nil :type (or null card16)) - (icon-y nil :type (or null card16)) - (icon-mask nil :type (or null pixmap)) - (window-group nil :type (or null resource-id)) - (flags 0 :type card32) ;; Extension-hook. Exclusive-Or'ed with the FLAGS field - ;; may be extended in the future - ) - -(defun wm-hints (window) - (declare (type window window) - (clx-values wm-hints))) - -(defsetf wm-hints (window) (wm-hints)) - - -(defstruct wm-size-hints - ;; Defaulted T to put the burden of remembering these on widget programmers. - (user-specified-position-p t :type boolean) ;; True when user specified x y - (user-specified-size-p t :type boolean) ;; True when user specified width height - (x nil :type (or null int16)) ;; Obsolete - (y nil :type (or null int16)) ;; Obsolete - (width nil :type (or null card16)) ;; Obsolete - (height nil :type (or null card16)) ;; Obsolete - (min-width nil :type (or null card16)) - (min-height nil :type (or null card16)) - (max-width nil :type (or null card16)) - (max-height nil :type (or null card16)) - (width-inc nil :type (or null card16)) - (height-inc nil :type (or null card16)) - (min-aspect nil :type (or null number)) - (max-aspect nil :type (or null number)) - (base-width nil :type (or null card16)) - (base-height nil :type (or null card16)) - (win-gravity nil :type (or null win-gravity))) - -(defun wm-normal-hints (window) - (declare (type window window) - (clx-values wm-size-hints))) - -(defsetf wm-normal-hints (window) (wm-size-hints)) - -;; ICON-SIZES uses the SIZE-HINTS structure - -(defun icon-sizes (window) - (declare (type window window) - (clx-values wm-size-hints))) - -(defsetf icon-sizes (window) (wm-size-hints)) - -(defun wm-protocols (window) - (declare (type window window) - (clx-values protocols))) - -(defsetf wm-protocols (window) (protocols) - (declare (type window window) - (type (clx-list keyword) protocols))) - -(defun wm-colormap-windows (window) - (declare (type window window) - (clx-values windows))) - -(defsetf wm-colormap-windows (window) (windows) - (declare (type window window) - (type (clx-list window) windows))) - -(defun transient-for (window) - (declare (type window window) - (clx-values window))) - -(defsetf transient-for (window) (transient) - (declare (type window window transient))) - -(defun set-wm-properties (window &rest options &key - name icon-name resource-name resource-class command - hints normal-hints - ;; the following are used for wm-normal-hints - user-specified-position-p user-specified-size-p - program-specified-position-p program-specified-size-p - min-width min-height max-width max-height - width-inc height-inc min-aspect max-aspect - base-width base-height win-gravity - ;; the following are used for wm-hints - input initial-state icon-pixmap icon-window - icon-x icon-y icon-mask window-group) - ;; Set properties for WINDOW. - (declare (type window window) - (type (or null stringable) name icoin-name resource-name resource-class) - (type (or null list) command) - (type (or null wm-hints) hints) - (type (or null wm-size-hints) normal-hints) - (type boolean user-specified-position-p user-specified-size-p) - (type boolean program-specified-position-p program-specified-size-p) - (type (or null card16) min-width min-height max-width max-height width-inc height-inc base-width base-height win-gravity) - (type (or null number) min-aspect max-aspect) - (type (or null (member :off :on)) input) - (type (or null (member :normal :iconic)) initial-state) - (type (or null pixmap) icon-pixmap icon-mask) - (type (or null window) icon-window) - (type (or null card16) icon-x icon-y) - (type (or null resource-id) window-group))) - -(defun iconify-window (window) - (declare (type window window))) - -(defun withdraw-window (window) - (declare (type window window))) - -(defstruct standard-colormap - (colormap nil :type (or null colormap)) - (base-pixel 0 :type pixel) - (max-color nil :type (or null color)) - (mult-color nil :type (or null color)) - (visual nil :type (or null visual-info)) - (kill nil :type (or (member nil :release-by-freeing-colormap) - drawable gcontext cursor colormap font))) - -(defun rgb-colormaps (window property) - (declare (type window window) - (type (member :rgb_default_map :rgb_best_map :rgb_red_map - :rgb_green_map :rgb_blue_map) property) - (clx-values (clx-list standard-colormap)))) - -(defsetf rgb-colormaps (window property) (standard-colormaps) - (declare (type window window) - (type (member :rgb_default_map :rgb_best_map :rgb_red_map - :rgb_green_map :rgb_blue_map) property) - (type (clx-list standard-colormap) standard-colormaps))) - -(defun cut-buffer (display &key (buffer 0) (type :string) (result-type 'string) - (transform #'card8->char) (start 0) end) - ;; Return the contents of cut-buffer BUFFER - (declare (type display display) - (type (integer 0 7) buffer) - (type xatom type) - (type array-index start) - (type (or null array-index) end) - (type t result-type) ;a sequence type - (type (or null (function (integer) t)) transform) - (clx-values sequence type format bytes-after))) - -(defsetf cut-buffer (display buffer &key (type :string) (format 8) - (transform #'char->card8) (start 0) end) (data)) - -(defun rotate-cut-buffers (display &optional (delta 1) (careful-p t)) - ;; Positive rotates left, negative rotates right (opposite of actual - ;; protocol request). When careful-p, ensure all cut-buffer - ;; properties are defined, to prevent errors. - (declare (type display display) - (type int16 delta) - (type boolean careful-p))) - -;;;----------------------------------------------------------------------------- -;;; Keycode mapping - -(defun define-keysym-set (set first-keysym last-keysym) - ;; Define all keysyms from first-keysym up to and including - ;; last-keysym to be in SET (returned from the keysym-set function). - ;; Signals an error if the keysym range overlaps an existing set. - (declare (type keyword set) - (type keysym first-keysym last-keysym))) - -(defun keysym-set (keysym) - ;; Return the character code set name of keysym - ;; Note that the keyboard set (255) has been broken up into its parts. - (declare (type keysym keysym) - (clx-values keyword))) - -(defun define-keysym (object keysym &key lowercase translate modifiers mask display) - ;; Define the translation from keysym/modifiers to a (usually - ;; character) object. ANy previous keysym definition with - ;; KEYSYM and MODIFIERS is deleted before adding the new definition. - ;; - ;; MODIFIERS is either a modifier-mask or list containing intermixed - ;; keysyms and state-mask-keys specifying when to use this - ;; keysym-translation. The default is NIL. - ;; - ;; MASK is either a modifier-mask or list containing intermixed - ;; keysyms and state-mask-keys specifying which modifiers to look at - ;; (i.e. modifiers not specified are don't-cares). - ;; If mask is :MODIFIERS then the mask is the same as the modifiers - ;; (i.e. modifiers not specified by modifiers are don't cares) - ;; The default mask is *default-keysym-translate-mask* - ;; - ;; If DISPLAY is specified, the translation will be local to DISPLAY, - ;; otherwise it will be the default translation for all displays. - ;; - ;; LOWERCASE is used for uppercase alphabetic keysyms. The value - ;; is the associated lowercase keysym. This information is used - ;; by the keysym-both-case-p predicate (for caps-lock computations) - ;; and by the keysym-downcase function. - ;; - ;; TRANSLATE will be called with parameters (display state OBJECT) - ;; when translating KEYSYM and modifiers and mask are satisfied. - ;; [e.g (zerop (logxor (logand state (or mask *default-keysym-translate-mask*)) - ;; (or modifiers 0))) - ;; when mask and modifiers aren't lists of keysyms] - ;; The default is #'default-keysym-translate - ;; - (declare (type (or base-char t) object) - (type keysym keysym) - (type (or null mask16 (clx-list (or keysym state-mask-key))) - modifiers) - (type (or null (member :modifiers) mask16 (clx-list (or keysym state-mask-key))) - mask) - (type (or null display) display) - (type (or null keysym) lowercase) - (type (function (display card16 t) t) translate))) - -(defvar *default-keysym-translate-mask* - (the (or (member :modifiers) mask16 (clx-list (or keysym state-mask-key))) - (logand #xff (lognot (make-state-mask :lock)))) - "Default keysym state mask to use during keysym-translation.") - -(defun undefine-keysym (object keysym &key display modifiers &allow-other-keys) - ;; Undefine the keysym-translation translating KEYSYM to OBJECT with MODIFIERS. - ;; If DISPLAY is non-nil, undefine the translation for DISPLAY if it exists. - (declare (type (or base-char t) object) - (type keysym keysym) - (type (or null mask16 (clx-list (or keysym state-mask-key))) - modifiers) - (type (or null display) display))) - -(defun default-keysym-translate (display state object) - ;; If object is a character, char-bits are set from state. - ;; If object is a list, it is an alist with entries: - ;; (base-char [modifiers] [mask-modifiers) - ;; When MODIFIERS are specified, this character translation - ;; will only take effect when the specified modifiers are pressed. - ;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore. - ;; When MASK-MODIFIERS is missing, all other modifiers are ignored. - ;; In ambiguous cases, the most specific translation is used. - (declare (type display display) - (type card16 state) - (type t object) - (clx-values t))) ;; Object returned by keycode->character - -(defmacro keysym (keysym &rest bytes) - ;; Build a keysym. - ;; If KEYSYM is an integer, it is used as the most significant bits of - ;; the keysym, and BYTES are used to specify low order bytes. The last - ;; parameter is always byte4 of the keysym. If KEYSYM is not an - ;; integer, the keysym associated with KEYSYM is returned. - ;; - ;; This is a macro and not a function macro to promote compile-time - ;; lookup. All arguments are evaluated. - (declare (type t keysym) - (type (clx-list card8) bytes) - (clx-values keysym))) - -(defun character->keysyms (character &optional display) - ;; Given a character, return a list of all matching keysyms. - ;; If DISPLAY is given, translations specific to DISPLAY are used, - ;; otherwise only global translations are used. - ;; Implementation dependent function. - ;; May be slow [i.e. do a linear search over all known keysyms] - (declare (type t character) - (type (or null display) display) - (clx-values (clx-list keysym)))) - -(defun keycode->keysym (display keycode keysym-index) - (declare (type display display) - (type card8 code) - (type card16 state) - (type card8 keysym-index) - (clx-values keysym))) - -(defun keysym->keycodes (display keysym) - ;; Return keycodes for keysym, as multiple values - (declare (type display display) - (type keysym keysym) - (clx-values (or null keycode) (or null keycode) (or null keycode))) - ) - -(defun keysym->character (display keysym &optional state) - ;; Find the character associated with a keysym. - ;; STATE is used for adding char-bits to character as follows: - ;; control -> char-control-bit - ;; mod-1 -> char-meta-bit - ;; mod-2 -> char-super-bit - ;; mod-3 -> char-hyper-bit - ;; Implementation dependent function. - (declare (type display display) - (type keysym keysym) - (type (or null card16) state) - (clx-values (or null character)))) - -(defun keycode->character (display keycode state &key keysym-index - (keysym-index-function #'default-keysym-index)) - ;; keysym-index defaults to the result of keysym-index-function which - ;; is called with the following parameters: - ;; (char0 state caps-lock-p keysyms-per-keycode) - ;; where char0 is the "character" object associated with keysym-index 0 and - ;; caps-lock-p is non-nil when the keysym associated with the lock - ;; modifier is for caps-lock. - ;; STATE is also used for setting char-bits: - ;; control -> char-control-bit - ;; mod-1 -> char-meta-bit - ;; mod-2 -> char-super-bit - ;; mod-3 -> char-hyper-bit - ;; Implementation dependent function. - (declare (type display display) - (type card8 keycode) - (type card16 state) - (type (or null card8) keysym-index) - (type (or null (function (char0 state caps-lock-p keysyms-per-keycode) card8)) - keysym-index-function) - (clx-values (or null character)))) - -(defun default-keysym-index (display keycode state) - ;; Returns a keysym-index for use with keycode->character - (declare (clx-values card8)) -) - -;;; default-keysym-index implements the following tables: -;;; -;;; control shift caps-lock character character -;;; 0 0 0 #\a #\8 -;;; 0 0 1 #\A #\8 -;;; 0 1 0 #\A #\* -;;; 0 1 1 #\A #\* -;;; 1 0 0 #\control-A #\control-8 -;;; 1 0 1 #\control-A #\control-8 -;;; 1 1 0 #\control-shift-a #\control-* -;;; 1 1 1 #\control-shift-a #\control-* -;;; -;;; control shift shift-lock character character -;;; 0 0 0 #\a #\8 -;;; 0 0 1 #\A #\* -;;; 0 1 0 #\A #\* -;;; 0 1 1 #\A #\8 -;;; 1 0 0 #\control-A #\control-8 -;;; 1 0 1 #\control-A #\control-* -;;; 1 1 0 #\control-shift-a #\control-* -;;; 1 1 1 #\control-shift-a #\control-8 - -(defun state-keysymp (display state keysym) - ;; Returns T when a modifier key associated with KEYSYM is on in STATE - (declare (type display display) - (type card16 state) - (type keysym keysym) - (clx-values boolean))) - -(defun mapping-notify (display request start count) - ;; Called on a mapping-notify event to update - ;; the keyboard-mapping cache in DISPLAY - (declare (type display display) - (type (member :modifier :keyboard :pointer) request) - (type card8 start count))) - -(defun keysym-in-map-p (display keysym keymap) - ;; Returns T if keysym is found in keymap - (declare (type display display) - (type keysym keysym) - (type (bit-vector 256) keymap) - (value boolean))) - -(defun character-in-map-p (display character keymap) - ;; Implementation dependent function. - ;; Returns T if character is found in keymap - (declare (type display display) - (type t character) - (type (bit-vector 256) keymap) - (value boolean))) - -;;;----------------------------------------------------------------------------- -;;; Extensions - -(defmacro define-extension (name &key events errors) - ;; Define extension NAME with EVENTS and ERRORS. - ;; Note: The case of NAME is important. - ;; To define the request, Use: - ;; (with-buffer-request (display (extension-opcode ,name)) ,@body) - ;; See the REQUESTS file for lots of examples. - ;; To define event handlers, use declare-event. - ;; To define error handlers, use declare-error and define-condition. - (declare (type stringable name) - (type (clx-list symbol) events errors))) - -(defmacro extension-opcode (display name) - ;; Returns the major opcode for extension NAME. - ;; This is a macro to enable NAME to be interned for fast run-time - ;; retrieval. - ;; Note: The case of NAME is important. - (declare (type display display) - (type stringable name) - (clx-values card8))) - -(defmacro define-error (error-key function) - ;; Associate a function with ERROR-KEY which will be called with - ;; parameters DISPLAY and REPLY-BUFFER and returns a plist of - ;; keyword/value pairs which will be passed on to the error handler. - ;; A compiler warning is printed when ERROR-KEY is not defined in a - ;; preceding DEFINE-EXTENSION. - ;; Note: REPLY-BUFFER may used with the READING-EVENT and READ-type - ;; macros for getting error fields. See DECODE-CORE-ERROR for - ; an example. - (declare (type symbol error-key) - (type function function))) - -;; All core errors use this, so we make it available to extensions. -(defun decode-core-error (display event &optional arg) - ;; All core errors have the following keyword/argument pairs: - ;; :major integer - ;; :minor integer - ;; :sequence integer - ;; :current-sequence integer - ;; In addition, many have an additional argument that comes from the - ;; same place in the event, but is named differently. When the ARG - ;; argument is specified, the keyword ARG with card32 value starting - ;; at byte 4 of the event is returned with the other keyword/argument - ;; pairs. - (declare (type display display) - (type reply-buffer event) - (type (or null keyword) arg) - (clx-values keyword/arg-plist))) - -;; This isn't new, just extended. -(defmacro declare-event (event-codes &body declares) - ;; Used to indicate the keyword arguments for handler functions in - ;; process-event and event-case. - ;; Generates functions used in SEND-EVENT. - ;; A compiler warning is printed when all of EVENT-CODES are not - ;; defined by a preceding DEFINE-EXTENSION. - ;; See the INPUT file for lots of examples. - (declare (type (or keyword (clx-list keywords)) event-codes) - (type (alist (field-type symbol) (field-names (clx-list symbol))) - declares))) - -(defmacro define-gcontext-accessor (name &key default set-function copy-function) - ;; This will define a new gcontext accessor called NAME. - ;; Defines the gcontext-NAME accessor function and its defsetf. - ;; Gcontext's will cache DEFAULT-VALUE and the last value SETF'ed when - ;; gcontext-cache-p is true. The NAME keyword will be allowed in - ;; CREATE-GCONTEXT, WITH-GCONTEXT, and COPY-GCONTEXT-COMPONENTS. - ;; SET-FUNCTION will be called with parameters (GCONTEXT NEW-VALUE) - ;; from create-gcontext, and force-gcontext-changes. - ;; COPY-FUNCTION will be called with parameters (src-gc dst-gc src-value) - ;; from copy-gcontext and copy-gcontext-components. - ;; The copy-function defaults to: - ;; (lambda (ignore dst-gc value) - ;; (if value - ;; (,set-function dst-gc value) - ;; (error "Can't copy unknown GContext component ~a" ',name))) - (declare (type symbol name) - (type t default) - (type symbol set-function) ;; required - (type symbol copy-function))) - - -;; To aid extension implementors in attaching additional information to -;; clx data structures, the following accessors (with SETF's) are -;; defined. GETF can be used on these to extend the structures. - -display-plist -screen-plist -visual-info-plist -gcontext-plist -font-plist -drawable-plist - - - -;;; These have had perhaps even less review. - -;;; Add some of the functionality provided by the C XLIB library. -;;; -;;; LaMott G. Oren, Texas Instruments 10/87 -;;; -;;; Design Contributors: -;;; Robert W. Scheifler, MIT - -;;;----------------------------------------------------------------------------- -;;; Regions (not yet implemented) - -;;; Regions are arbitrary collections of pixels. This is represented -;;; in the region structure as either a list of rectangles or a bitmap. - -(defun make-region (&optional x y width height) - ;; With no parameters, returns an empty region - ;; If some parameters are given, all must be given. - (declare (type (or null int16) x y width height) - (clx-values region))) - -(defun region-p (thing)) - -(defun copy-region (region)) - -(defun region-empty-p (region) - (declare (type region region) - (clx-values boolean))) - -(defun region-clip-box (region) - ;; Returns a region which is the smallest enclosing rectangle - ;; enclosing REGION - (declare (type region region) - (clx-values region))) - -;; Accessors that return the boundaries of a region -(defun region-x (region)) -(defun region-y (region)) -(defun region-width (region)) -(defun region-height (region)) - -(defsetf region-x (region) (x)) -(defsetf region-y (region) (y)) -;; Setting a region's X/Y translates the region - -(defun region-intersection (&rest regions) - "Returns a region which is the intersection of one or more REGIONS. -Returns an empty region if the intersection is empty. -If there are no regions given, return a very large region." - (declare (type (clx-list region) regions) - (clx-values region))) - -(defun region-union (&rest regions) - "Returns a region which is the union of a number of REGIONS - (i.e. the smallest region that can contain all the other regions) - Returns the empty region if no regions are given." - (declare (type (clx-list region) regions) - (clx-values region))) - -(defun region-subtract (region subtract) - "Returns a region containing the points that are in REGION but not in SUBTRACT" - (declare (type region region subtract) - (clx-values region))) - -(defun point-in-region-p (region x y) - ;; Returns T when X/Y are a point within REGION. - (declare (type region region) - (type int16 x y) - (clx-values boolean))) - -(defun region-equal (a b) - ;; Returns T when regions a and b contain the same points. - ;; That is, return t when for every X/Y (point-in-region-p a x y) - ;; equals (point-in-region-p b x y) - (declare (type region a b) - (clx-values boolean))) - -(defun subregion-p (large small) - "Returns T if SMALL is within LARGE. - That is, return T when for every X/Y (point-in-region-p small X Y) - implies (point-in-region-p large X Y)." - (declare (type region large small) - (clx-values boolean))) - -(defun region-intersect-p (a b) - "Returns T if A intersects B. - That is, return T when there is some point common to regions A and B." - (declare (type region a b) - (clx-values boolean))) - -(defun map-region (region function &rest args) - ;; Calls function with arguments (x y . args) for every point in REGION. - (declare (type region region) - (type (function x y &rest args) function))) - -;; Why isn't it better to augment -;; gcontext-clip-mask to deal with -;; (or null (member :none) pixmap rect-seq region) -;; and force conversions on the caller? -;; Good idea. - -;;(defun gcontext-clip-region (gcontext) -;; ;; If the clip-mask of GCONTEXT is known, return it as a region. -;; (declare (type gcontext gcontext) -;; (clx-values (or null region)))) - -;;(defsetf gcontext-clip-region (gcontext) (region) -;; ;; Set the clip-rectangles or clip-mask for for GCONTEXT to include -;; ;; only the pixels within REGION. -;; (declare (type gcontext gcontext) -;; (type region region))) - -(defun image->region (image) - ;; Returns a region containing the 1 bits of a depth-1 image - ;; Signals an error if image isn't of depth 1. - (declare (type image image) - (clx-values region))) - -(defun region->image (region) - ;; Returns a depth-1 image containg 1 bits for every pixel in REGION. - (declare (type region region) - (clx-values image))) - -(defun polygon-region (points &optional (fill-rule :even-odd)) - (declare (type sequence points) ;(repeat-seq (integer x) (integer y)) - (type (member :even-odd :winding) fill-rule) - (clx-values region))) - -;;;----------------------------------------------------------------------------- -;;; IMAGE functions - - -(deftype bitmap () '(array bit (* *))) -(deftype pixarray () '(array pixel (* *))) - -(defconstant +lisp-byte-lsb-first-p+ #+lispm t #-lispm nil - "Byte order in pixel arrays") - -(defstruct image - ;; Public structure - (width 0 :type card16 :read-only t) - (height 0 :type card16 :read-only t) - (depth 1 :type card8 :read-only t) - (plist nil :type list)) - -;; Image-Plist accessors: -(defun image-name (image)) -(defun image-x-hot (image)) -(defun image-y-hot (image)) -(defun image-red-mask (image)) -(defun image-blue-mask (image)) -(defun image-green-mask (image)) - -(defsetf image-name (image) (name)) -(defsetf image-x-hot (image) (x)) -(defsetf image-y-hot (image) (y)) -(defsetf image-red-mask (image) (mask)) -(defsetf image-blue-mask (image) (mask)) -(defsetf image-green-mask (image) (mask)) - -(defstruct (image-x (:include image)) - ;; Use this format for shoveling image data - ;; Private structure. Accessors for these NOT exported. - (format :z-pixmap :type (member :bitmap :xy-pixmap :z-pixmap)) - (bytes-per-line 0 :type card16) - (scanline-pad 32 :type (member 8 16 32)) - (bits-per-pixel 0 :type (member 1 4 8 16 24 32)) - (bit-lsb-first-p nil :type boolean) ; Bit order - (byte-lsb-first-p nil :type boolean) ; Byte order - (data #() :type (array card8 (*)))) ; row-major - -(defstruct (image-xy (:include image)) - ;; Public structure - ;; Use this format for image processing - (bitmap-list nil :type (clx-list bitmap))) - -(defstruct (image-z (:include image)) - ;; Public structure - ;; Use this format for image processing - (bits-per-pixel 0 :type (member 1 4 8 16 24 32)) - (pixarray #() :type pixarray)) - -(defun create-image (&key (width (required-arg width)) - (height (required-arg height)) - depth data plist name x-hot y-hot - red-mask blue-mask green-mask - bits-per-pixel format scanline-pad bytes-per-line - byte-lsb-first-p bit-lsb-first-p ) - ;; Returns an image-x image-xy or image-z structure, depending on the - ;; type of the :DATA parameter. - (declare - (type card16 width height) ; Required - (type (or null card8) depth) ; Defualts to 1 - (type (or (array card8 (*)) ;Returns image-x - (clx-list bitmap) ;Returns image-xy - pixarray) data) ;Returns image-z - (type list plist) - (type (or null stringable) name) - (type (or null card16) x-hot y-hot) - (type (or null pixel) red-mask blue-mask green-mask) - (type (or null (member 1 4 8 16 24 32)) bits-per-pixel) - - ;; The following parameters are ignored for image-xy and image-z: - (type (or null (member :bitmap :xy-pixmap :z-pixmap)) - format) ; defaults to :z-pixmap - (type (or null (member 8 16 32)) scanline-pad) - (type (or null card16) bytes-per-line) ;default from width and scanline-pad - (type boolean byte-lsb-first-p bit-lsb-first-p) - (clx-values image))) - -(defun get-image (drawable &key - (x (required-arg x)) - (y (required-arg y)) - (width (required-arg width)) - (height (required-arg height)) - plane-mask format result-type) - ;; Get an image from the server. - ;; Format defaults to :z-pixmap. Result-Type defaults from Format, - ;; image-z for :z-pixmap, and image-xy for :xy-pixmap. - ;; Plane-mask defaults to #xFFFFFFFF. - ;; Returns an image-x image-xy or image-z structure, depending on the - ;; result-type parameter. - (declare (type drawable drawable) - (type int16 x y) ;; required - (type card16 width height) ;; required - (type (or null pixel) plane-mask) - (type (or null (member :xy-pixmap :z-pixmap)) format) - (type (or null (member image-x image-xy image-z)) result-type) - (clx-values image))) - -(defun put-image (drawable gcontext image &key - (src-x 0) (src-y 0) - (x (required-arg x)) - (y (required-arg y)) - width height - bitmap-p) - ;; When BITMAP-P, force format to be :bitmap when depth=1 - ;; This causes gcontext to supply foreground & background pixels. - (declare (type drawable drawable) - (type gcontext gcontext) - (type image image) - (type int16 x y) ;; required - (type (or null card16) width height) - (type boolean bitmap-p))) - -(defun copy-image (image &key (x 0) (y 0) width height result-type) - ;; Copy with optional sub-imaging and format conversion. - ;; result-type defaults to (type-of image) - (declare (type image image) - (type card16 x y) - (type (or null card16) width height) ;; Default from image - (type (or null (member image-x image-xy image-z)) result-type) - (clx-values image))) - -(defun read-bitmap-file (pathname) - ;; Creates an image from a C include file in standard X11 format - (declare (type (or pathname string stream) pathname) - (clx-values image))) - -(defun write-bitmap-file (pathname image &optional name) - ;; Writes an image to a C include file in standard X11 format - ;; NAME argument used for variable prefixes. Defaults to "image" - (declare (type (or pathname string stream) pathname) - (type image image) - (type (or null stringable) name))) - -;;;----------------------------------------------------------------------------- -;;; Resource data-base - - -(defun make-resource-database () - ;; Returns an empty resource data-base - (declare (clx-values resource-database))) - -(defun get-resource (database value-name value-class full-name full-class) - ;; Return the value of the resource in DATABASE whose partial name - ;; most closely matches (append full-name (list value-name)) and - ;; (append full-class (list value-class)). - (declare (type resource-database database) - (type stringable value-name value-class) - (type (clx-list stringable) full-name full-class) - (clx-values value))) - -(defun add-resource (database name-list value) - ;; name-list is a list of either strings or symbols. If a symbol, - ;; case-insensitive comparisons will be used, if a string, - ;; case-sensitive comparisons will be used. The symbol '* or - ;; string "*" are used as wildcards, matching anything or nothing. - (declare (type resource-database database) - (type (clx-list stringable) name-list) - (type t value))) - -(defun delete-resource (database name-list) - (declare (type resource-database database) - (type (clx-list stringable) name-list))) - -(defun map-resource (database function &rest args) - ;; Call FUNCTION on each resource in DATABASE. - ;; FUNCTION is called with arguments (name-list value . args) - (declare (type resource-database database) - (type (function ((clx-list stringable) t &rest t) t) function) - (clx-values nil))) - -(defun merge-resources (database with-database) - (declare (type resource-database database with-database) - (clx-values resource-database)) - (map-resource #'add-resource database with-database) - with-database) - -;; Note: with-input-from-string can be used with read-resources to define -;; default resources in a program file. - -(defun read-resources (database pathname &key key test test-not) - ;; Merges resources from a file in standard X11 format with DATABASE. - ;; KEY is a function used for converting value-strings, the default is - ;; identity. TEST and TEST-NOT are predicates used for filtering - ;; which resources to include in the database. They are called with - ;; the name and results of the KEY function. - (declare (type resource-database database) - (type (or pathname string stream) pathname) - (type (or null (function (string) t)) key) - (type (or null (function ((clx-list string) t) boolean)) - test test-not) - (clx-values resource-database))) - -(defun write-resources (database pathname &key write test test-not) - ;; Write resources to PATHNAME in the standard X11 format. - ;; WRITE is a function used for writing values, the default is #'princ - ;; TEST and TEST-NOT are predicates used for filtering which resources - ;; to include in the database. They are called with the name and value. - (declare (type resource-database database) - (type (or pathname string stream) pathname) - (type (or null (function (string stream) t)) write) - (type (or null (function ((clx-list string) t) boolean)) - test test-not))) - -(defun root-resources (screen &key database key test test-not) - "Returns a resource database containing the contents of the root window - RESOURCE_MANAGER property for the given SCREEN. If SCREEN is a display, - then its default screen is used. If an existing DATABASE is given, then - resource values are merged with the DATABASE and the modified DATABASE is - returned. - - TEST and TEST-NOT are predicates for selecting which resources are - read. Arguments are a resource name list and a resource value. The KEY - function, if given, is called to convert a resource value string to the - value given to TEST or TEST-NOT." - - (declare (type (or screen display) screen) - (type (or null resource-database) database) - (type (or null (function (string) t)) key) - (type (or null (function list boolean)) test test-not) - (clx-values resource-database))) - -(defsetf root-resources (screen &key test test-not (write 'princ)) (database) - "Changes the contents of the root window RESOURCE_MANAGER property for the - given SCREEN. If SCREEN is a display, then its default screen is used. - - TEST and TEST-NOT are predicates for selecting which resources from the - DATABASE are written. Arguments are a resource name list and a resource - value. The WRITE function is used to convert a resource value into a - string stored in the property." - - (declare (type (or screen display) screen) - (type (or null resource-database) database) - (type (or null (function list boolean)) test test-not) - (type (or null (function (string stream) t)) write) - (clx-values resource-database))) - -;;;----------------------------------------------------------------------------- -;;; Shared GContext's - -(defmacro using-gcontext ((var &rest options &key drawable - function plane-mask foreground background - line-width line-style cap-style - join-style fill-style fill-rule arc-mode - tile stipple ts-x ts-y font - subwindow-mode exposures clip-x clip-y - clip-mask clip-ordering dash-offset - dashes) - &body body) - ;; Equivalent to (let ((var (apply #'make-gcontext options))) ,@body) - ;; but more efficient because it uses a gcontext cache associated with - ;; drawable's display. - ) - - - - X11 Request Name CLX Function Name ------------------ ----------------- -AllocColor ALLOC-COLOR -AllocColorCells ALLOC-COLOR-CELLS -AllocColorPlanes ALLOC-COLOR-PLANES -AllocNamedColor ALLOC-COLOR -AllowEvents ALLOW-EVENTS -Bell BELL -ChangeAccessControl (setf (ACCESS-CONTROL display) boolean) -ChangeActivePointerGrab CHANGE-ACTIVE-POINTER-GRAB -ChangeCloseDownMode (setf (CLOSE-DOWN-MODE display) mode) -ChangeGC FORCE-GCONTEXT-CHANGES - ;; See WITH-GCONTEXT - (setf (gcontext-function gc) boole-constant) - (setf (gcontext-plane-mask gc) card32) - (setf (gcontext-foreground gc) card32) - (setf (gcontext-background gc) card32) - (setf (gcontext-line-width gc) card16) - (setf (gcontext-line-style gc) keyword) - (setf (gcontext-cap-style gc) keyword) - (setf (gcontext-join-style gc) keyword) - (setf (gcontext-fill-style gc) keyword) - (setf (gcontext-fill-rule gc) keyword) - (setf (gcontext-tile gc) pixmap) - (setf (gcontext-stipple gc) pixmap) - (setf (gcontext-ts-x gc) int16) ;; Tile-Stipple-X-origin - (setf (gcontext-ts-y gc) int16) ;; Tile-Stipple-Y-origin - (setf (gcontext-font gc &optional metrics-p) font) - (setf (gcontext-subwindow-mode gc) keyword) - (setf (gcontext-exposures gc) (member :on :off)) - (setf (gcontext-clip-x gc) int16) - (setf (gcontext-clip-y gc) int16) - (setf (gcontext-clip-mask gc &optional ordering) - (or (member :none) pixmap rect-seq)) - (setf (gcontext-dash-offset gc) card16) - (setf (gcontext-dashes gc) (or card8 sequence)) - (setf (gcontext-arc-mode gc) (member :chord :pie-slice)) - (setf (gcontext-clip-ordering gc) keyword) - -ChangeHosts ADD-ACCESS-HOST -ChangeHosts REMOVE-ACCESS-HOST -ChangeKeyboardControl CHANGE-KEYBOARD-CONTROL -ChangePointerControl CHANGE-POINTER-CONTROL -ChangeProperty CHANGE-PROPERTY -ChangeSaveSet REMOVE-FROM-SAVE-SET -ChangeSaveSet ADD-TO-SAVE-SET -ChangeWindowAttributes - ;; See WITH-STATE - (setf (window-background window) value) - (setf (window-border window) value) - (setf (window-bit-gravity window) value) - (setf (window-gravity window) value) - (setf (window-backing-store window) value) - (setf (window-backing-planes window) value) - (setf (window-backing-pixel window) value) - (setf (window-override-redirect window) value) - (setf (window-save-under window) value) - (setf (window-colormap window) value) - (setf (window-cursor window) value) - (setf (window-event-mask window) value) - (setf (window-do-not-propagate-mask window) value) - -CirculateWindow CIRCULATE-WINDOW-DOWN -CirculateWindow CIRCULATE-WINDOW-UP -ClearToBackground CLEAR-AREA -CloseFont CLOSE-FONT -ConfigureWindow - ;; See WITH-STATE - (setf (drawable-x drawable) integer) - (setf (drawable-y drawable) integer) - (setf (drawable-width drawable) integer) - (setf (drawable-height drawable) integer) - (setf (drawable-depth drawable) integer) - (setf (drawable-border-width drawable) integer) - (setf (window-priority window &optional sibling) integer) - -ConvertSelection CONVERT-SELECTION -CopyArea COPY-AREA -CopyColormapAndFree COPY-COLORMAP-AND-FREE -CopyGC COPY-GCONTEXT -CopyGC COPY-GCONTEXT-COMPONENTS -CopyPlane COPY-PLANE -CreateColormap CREATE-COLORMAP -CreateCursor CREATE-CURSOR -CreateGC CREATE-GCONTEXT -CreateGlyphCursor CREATE-GLYPH-CURSOR -CreatePixmap CREATE-PIXMAP -CreateWindow CREATE-WINDOW -DeleteProperty DELETE-PROPERTY -DestroySubwindows DESTROY-SUBWINDOWS -DestroyWindow DESTROY-WINDOW -FillPoly DRAW-LINES -ForceScreenSaver RESET-SCREEN-SAVER -ForceScreenSaver ACTIVATE-SCREEN-SAVER -FreeColormap FREE-COLORMAP -FreeColors FREE-COLORS -FreeCursor FREE-CURSOR -FreeGC FREE-GCONTEXT -FreePixmap FREE-PIXMAP -GetAtomName ATOM-NAME -GetFontPath FONT-PATH -GetGeometry ;; See WITH-STATE - DRAWABLE-ROOT - DRAWABLE-X - DRAWABLE-Y - DRAWABLE-WIDTH - DRAWABLE-HEIGHT - DRAWABLE-DEPTH - DRAWABLE-BORDER-WIDTH - -GetImage GET-RAW-IMAGE -GetInputFocus INPUT-FOCUS -GetKeyboardControl KEYBOARD-CONTROL -GetKeyboardMapping KEYBOARD-MAPPING -GetModifierMapping MODIFIER-MAPPING -GetMotionEvents MOTION-EVENTS -GetPointerControl POINTER-CONTROL -GetPointerMapping POINTER-MAPPING -GetProperty GET-PROPERTY -GetScreenSaver SCREEN-SAVER -GetSelectionOwner SELECTION-OWNER -GetWindowAttributes ;; See WITH-STATE - WINDOW-VISUAL-INFO - WINDOW-CLASS - WINDOW-BIT-GRAVITY - WINDOW-GRAVITY - WINDOW-BACKING-STORE - WINDOW-BACKING-PLANES - WINDOW-BACKING-PIXEL - WINDOW-SAVE-UNDER - WINDOW-OVERRIDE-REDIRECT - WINDOW-EVENT-MASK - WINDOW-DO-NOT-PROPAGATE-MASK - WINDOW-COLORMAP - WINDOW-COLORMAP-INSTALLED-P - WINDOW-ALL-EVENT-MASKS - WINDOW-MAP-STATE - -GrabButton GRAB-BUTTON -GrabKey GRAB-KEY -GrabKeyboard GRAB-KEYBOARD -GrabPointer GRAB-POINTER -GrabServer GRAB-SERVER -ImageText16 DRAW-IMAGE-GLYPHS -ImageText16 DRAW-IMAGE-GLYPH -ImageText8 DRAW-IMAGE-GLYPHS -InstallColormap INSTALL-COLORMAP -InternAtom FIND-ATOM -InternAtom INTERN-ATOM -KillClient KILL-TEMPORARY-CLIENTS -KillClient KILL-CLIENT -ListExtensions LIST-EXTENSIONS -ListFonts LIST-FONT-NAMES -ListFontsWithInfo LIST-FONTS -ListHosts ACCESS-CONTROL -ListHosts ACCESS-HOSTS -ListInstalledColormaps INSTALLED-COLORMAPS -ListProperties LIST-PROPERTIES -LookupColor LOOKUP-COLOR -MapSubwindows MAP-SUBWINDOWS -MapWindow MAP-WINDOW -OpenFont OPEN-FONT -PolyArc DRAW-ARC -PolyArc DRAW-ARCS -PolyFillArc DRAW-ARC -PolyFillArc DRAW-ARCS -PolyFillRectangle DRAW-RECTANGLE -PolyFillRectangle DRAW-RECTANGLES -PolyLine DRAW-LINE -PolyLine DRAW-LINES -PolyPoint DRAW-POINT -PolyPoint DRAW-POINTS -PolyRectangle DRAW-RECTANGLE -PolyRectangle DRAW-RECTANGLES -PolySegment DRAW-SEGMENTS -PolyText16 DRAW-GLYPH -PolyText16 DRAW-GLYPHS -PolyText8 DRAW-GLYPHS -PutImage PUT-RAW-IMAGE -QueryBestSize QUERY-BEST-CURSOR -QueryBestSize QUERY-BEST-STIPPLE -QueryBestSize QUERY-BEST-TILE -QueryColors QUERY-COLORS -QueryExtension QUERY-EXTENSION -QueryFont FONT-NAME - FONT-NAME - FONT-DIRECTION - FONT-MIN-CHAR - FONT-MAX-CHAR - FONT-MIN-BYTE1 - FONT-MAX-BYTE1 - FONT-MIN-BYTE2 - FONT-MAX-BYTE2 - FONT-ALL-CHARS-EXIST-P - FONT-DEFAULT-CHAR - FONT-ASCENT - FONT-DESCENT - FONT-PROPERTIES - FONT-PROPERTY - - CHAR-LEFT-BEARING - CHAR-RIGHT-BEARING - CHAR-WIDTH - CHAR-ASCENT - CHAR-DESCENT - CHAR-ATTRIBUTES - - MIN-CHAR-LEFT-BEARING - MIN-CHAR-RIGHT-BEARING - MIN-CHAR-WIDTH - MIN-CHAR-ASCENT - MIN-CHAR-DESCENT - MIN-CHAR-ATTRIBUTES - - MAX-CHAR-LEFT-BEARING - MAX-CHAR-RIGHT-BEARING - MAX-CHAR-WIDTH - MAX-CHAR-ASCENT - MAX-CHAR-DESCENT - MAX-CHAR-ATTRIBUTES - -QueryKeymap QUERY-KEYMAP -QueryPointer GLOBAL-POINTER-POSITION -QueryPointer POINTER-POSITION -QueryPointer QUERY-POINTER -QueryTextExtents TEXT-EXTENTS -QueryTextExtents TEXT-WIDTH -QueryTree QUERY-TREE -RecolorCursor RECOLOR-CURSOR -ReparentWindow REPARENT-WINDOW -RotateProperties ROTATE-PROPERTIES -SendEvent SEND-EVENT -SetClipRectangles FORCE-GCONTEXT-CHANGES - ;; See WITH-GCONTEXT - (setf (gcontext-clip-x gc) int16) - (setf (gcontext-clip-y gc) int16) - (setf (gcontext-clip-mask gc &optional ordering) - (or (member :none) pixmap rect-seq)) - (setf (gcontext-clip-ordering gc) keyword) - -SetDashes FORCE-GCONTEXT-CHANGES - ;; See WITH-GCONTEXT - (setf (gcontext-dash-offset gc) card16) - (setf (gcontext-dashes gc) (or card8 sequence)) - -SetFontPath - (setf (font-path font) paths) - Where paths is (type (clx-sequence (or string pathname))) - -SetInputFocus SET-INPUT-FOCUS -SetKeyboardMapping CHANGE-KEYBOARD-MAPPING -SetModifierMapping SET-MODIFIER-MAPPING -SetPointerMapping SET-POINTER-MAPPING -SetScreenSaver SET-SCREEN-SAVER -SetSelectionOwner SET-SELECTION-OWNER -StoreColors STORE-COLOR -StoreColors STORE-COLORS -StoreNamedColor STORE-COLOR -StoreNamedColor STORE-COLORS -TranslateCoords TRANSLATE-COORDINATES -UngrabButton UNGRAB-BUTTON -UngrabKey UNGRAB-KEY -UngrabKeyboard UNGRAB-KEYBOARD -UngrabPointer UNGRAB-POINTER -UngrabServer UNGRAB-SERVER -UninstallColormap UNINSTALL-COLORMAP -UnmapSubwindows UNMAP-SUBWINDOWS -UnmapWindow UNMAP-WINDOW -WarpPointer WARP-POINTER -WarpPointer WARP-POINTER-IF-INSIDE -WarpPointer WARP-POINTER-RELATIVE -WarpPointer WARP-POINTER-RELATIVE-IF-INSIDE -NoOperation NO-OPERATION - - - - X11 Request Name CLX Function Name ------------------ ----------------- -ListHosts ACCESS-CONTROL -ListHosts ACCESS-HOSTS -ForceScreenSaver ACTIVATE-SCREEN-SAVER -ChangeHosts ADD-ACCESS-HOST -ChangeSaveSet ADD-TO-SAVE-SET -AllocColor ALLOC-COLOR -AllocNamedColor ALLOC-COLOR -AllocColorCells ALLOC-COLOR-CELLS -AllocColorPlanes ALLOC-COLOR-PLANES -AllowEvents ALLOW-EVENTS -GetAtomName ATOM-NAME -Bell BELL -ChangeActivePointerGrab CHANGE-ACTIVE-POINTER-GRAB -ChangeKeyboardControl CHANGE-KEYBOARD-CONTROL -SetKeyboardMapping CHANGE-KEYBOARD-MAPPING -ChangePointerControl CHANGE-POINTER-CONTROL -ChangeProperty CHANGE-PROPERTY -QueryFont CHAR-ASCENT -QueryFont CHAR-ATTRIBUTES -QueryFont CHAR-DESCENT -QueryFont CHAR-LEFT-BEARING -QueryFont CHAR-RIGHT-BEARING -QueryFont CHAR-WIDTH -CirculateWindow CIRCULATE-WINDOW-DOWN -CirculateWindow CIRCULATE-WINDOW-UP -ClearToBackground CLEAR-AREA -CloseFont CLOSE-FONT -ConvertSelection CONVERT-SELECTION -CopyArea COPY-AREA -CopyColormapAndFree COPY-COLORMAP-AND-FREE -CopyGC COPY-GCONTEXT -CopyGC COPY-GCONTEXT-COMPONENTS -CopyPlane COPY-PLANE -CreateColormap CREATE-COLORMAP -CreateCursor CREATE-CURSOR -CreateGC CREATE-GCONTEXT -CreateGlyphCursor CREATE-GLYPH-CURSOR -CreatePixmap CREATE-PIXMAP -CreateWindow CREATE-WINDOW -DeleteProperty DELETE-PROPERTY -DestroySubwindows DESTROY-SUBWINDOWS -DestroyWindow DESTROY-WINDOW -PolyArc DRAW-ARC -PolyArc DRAW-ARCS -PolyText16 DRAW-GLYPH -PolyText16 DRAW-GLYPHS -PolyText8 DRAW-GLYPHS -ImageText16 DRAW-IMAGE-GLYPH -ImageText16 DRAW-IMAGE-GLYPHS -ImageText8 DRAW-IMAGE-GLYPHS -PolyLine DRAW-LINE -PolyLine DRAW-LINES -PolyPoint DRAW-POINT -PolyPoint DRAW-POINTS -PolyFillRectangle DRAW-RECTANGLE -PolyRectangle DRAW-RECTANGLE -PolyFillRectangle DRAW-RECTANGLES -PolyRectangle DRAW-RECTANGLES -PolySegment DRAW-SEGMENTS -GetGeometry DRAWABLE-BORDER-WIDTH -GetGeometry DRAWABLE-DEPTH -GetGeometry DRAWABLE-HEIGHT -GetGeometry DRAWABLE-ROOT -GetGeometry DRAWABLE-WIDTH -GetGeometry DRAWABLE-X -GetGeometry DRAWABLE-Y -FillPoly FILL-POLYGON -InternAtom FIND-ATOM -QueryFont FONT-ALL-CHARS-EXIST-P -QueryFont FONT-ASCENT -QueryFont FONT-DEFAULT-CHAR -QueryFont FONT-DESCENT -QueryFont FONT-DIRECTION -QueryFont FONT-MAX-BYTE1 -QueryFont FONT-MAX-BYTE2 -QueryFont FONT-MAX-CHAR -QueryFont FONT-MIN-BYTE1 -QueryFont FONT-MIN-BYTE2 -QueryFont FONT-MIN-CHAR -QueryFont FONT-NAME -QueryFont FONT-NAME -GetFontPath FONT-PATH -QueryFont FONT-PROPERTIES -QueryFont FONT-PROPERTY -ChangeGC FORCE-GCONTEXT-CHANGES -SetClipRectangles FORCE-GCONTEXT-CHANGES -SetDashes FORCE-GCONTEXT-CHANGES -FreeColormap FREE-COLORMAP -FreeColors FREE-COLORS -FreeCursor FREE-CURSOR -FreeGC FREE-GCONTEXT -FreePixmap FREE-PIXMAP -GetProperty GET-PROPERTY -GetImage GET-RAW-IMAGE -QueryPointer GLOBAL-POINTER-POSITION -GrabButton GRAB-BUTTON -GrabKey GRAB-KEY -GrabKeyboard GRAB-KEYBOARD -GrabPointer GRAB-POINTER -GrabServer GRAB-SERVER -GrabServer WITH-SERVER-GRABBED -GetInputFocus INPUT-FOCUS -InstallColormap INSTALL-COLORMAP -ListInstalledColormaps INSTALLED-COLORMAPS -InternAtom INTERN-ATOM -GetKeyboardControl KEYBOARD-CONTROL -GetKeyboardMapping KEYBOARD-MAPPING -KillClient KILL-CLIENT -KillClient KILL-TEMPORARY-CLIENTS -ListExtensions LIST-EXTENSIONS -ListFonts LIST-FONT-NAMES -ListFontsWithInfo LIST-FONTS -ListProperties LIST-PROPERTIES -LookupColor LOOKUP-COLOR -MapSubwindows MAP-SUBWINDOWS -MapWindow MAP-WINDOW -QueryFont MAX-CHAR-ASCENT -QueryFont MAX-CHAR-ATTRIBUTES -QueryFont MAX-CHAR-DESCENT -QueryFont MAX-CHAR-LEFT-BEARING -QueryFont MAX-CHAR-RIGHT-BEARING -QueryFont MAX-CHAR-WIDTH -QueryFont MIN-CHAR-ASCENT -QueryFont MIN-CHAR-ATTRIBUTES -QueryFont MIN-CHAR-DESCENT -QueryFont MIN-CHAR-LEFT-BEARING -QueryFont MIN-CHAR-RIGHT-BEARING -QueryFont MIN-CHAR-WIDTH -GetModifierMapping MODIFIER-MAPPING -GetMotionEvents MOTION-EVENTS -NoOperation NO-OPERATION -OpenFont OPEN-FONT -GetPointerControl POINTER-CONTROL -GetPointerMapping POINTER-MAPPING -QueryPointer POINTER-POSITION -PutImage PUT-RAW-IMAGE -QueryBestSize QUERY-BEST-CURSOR -QueryBestSize QUERY-BEST-STIPPLE -QueryBestSize QUERY-BEST-TILE -QueryColors QUERY-COLORS -QueryExtension QUERY-EXTENSION -QueryKeymap QUERY-KEYMAP -QueryPointer QUERY-POINTER -QueryTree QUERY-TREE -RecolorCursor RECOLOR-CURSOR -ChangeHosts REMOVE-ACCESS-HOST -ChangeSaveSet REMOVE-FROM-SAVE-SET -ReparentWindow REPARENT-WINDOW -ForceScreenSaver RESET-SCREEN-SAVER -RotateProperties ROTATE-PROPERTIES -GetScreenSaver SCREEN-SAVER -GetSelectionOwner SELECTION-OWNER -SendEvent SEND-EVENT -ChangeAccessControl SET-ACCESS-CONTROL -ChangeCloseDownMode SET-CLOSE-DOWN-MODE -SetInputFocus SET-INPUT-FOCUS -SetModifierMapping SET-MODIFIER-MAPPING -SetPointerMapping SET-POINTER-MAPPING -SetScreenSaver SET-SCREEN-SAVER -SetSelectionOwner SET-SELECTION-OWNER -StoreColors STORE-COLOR -StoreColors STORE-COLORS -StoreNamedColor STORE-COLOR -StoreNamedColor STORE-COLORS -QueryTextExtents TEXT-EXTENTS -QueryTextExtents TEXT-WIDTH -TranslateCoords TRANSLATE-COORDINATES -UngrabButton UNGRAB-BUTTON -UngrabKey UNGRAB-KEY -UngrabKeyboard UNGRAB-KEYBOARD -UngrabPointer UNGRAB-POINTER -UngrabServer UNGRAB-SERVER -UngrabServer WITH-SERVER-GRABBED -UninstallColormap UNINSTALL-COLORMAP -UnmapSubwindows UNMAP-SUBWINDOWS -UnmapWindow UNMAP-WINDOW -WarpPointer WARP-POINTER -WarpPointer WARP-POINTER-IF-INSIDE -WarpPointer WARP-POINTER-RELATIVE -WarpPointer WARP-POINTER-RELATIVE-IF-INSIDE -GetWindowAttributes WINDOW-ALL-EVENT-MASKS -GetWindowAttributes WINDOW-BACKING-PIXEL -GetWindowAttributes WINDOW-BACKING-PLANES -GetWindowAttributes WINDOW-BACKING-STORE -GetWindowAttributes WINDOW-BIT-GRAVITY -GetWindowAttributes WINDOW-CLASS -GetWindowAttributes WINDOW-COLORMAP -GetWindowAttributes WINDOW-COLORMAP-INSTALLED-P -GetWindowAttributes WINDOW-DO-NOT-PROPAGATE-MASK -GetWindowAttributes WINDOW-EVENT-MASK -GetWindowAttributes WINDOW-GRAVITY -GetWindowAttributes WINDOW-MAP-STATE -GetWindowAttributes WINDOW-OVERRIDE-REDIRECT -GetWindowAttributes WINDOW-SAVE-UNDER -GetWindowAttributes WINDOW-VISUAL-INFO - -ConfigureWindow (SETF (DRAWABLE-BORDER-WIDTH DRAWABLE) INTEGER) -ConfigureWindow (SETF (DRAWABLE-DEPTH DRAWABLE) INTEGER) -ConfigureWindow (SETF (DRAWABLE-HEIGHT DRAWABLE) INTEGER) -ConfigureWindow (SETF (DRAWABLE-WIDTH DRAWABLE) INTEGER) -ConfigureWindow (SETF (DRAWABLE-X DRAWABLE) INTEGER) -ConfigureWindow (SETF (DRAWABLE-Y DRAWABLE) INTEGER) -SetFontPath (SETF (FONT-PATH FONT) PATHS) -ChangeGC (SETF (GCONTEXT-ARC-MODE GC) (MEMBER CHORD PIE-SLICE)) -ChangeGC (SETF (GCONTEXT-BACKGROUND GC) CARD32) -ChangeGC (SETF (GCONTEXT-CAP-STYLE GC) KEYWORD) -SetClipRectangles (SETF (GCONTEXT-CLIP-MASK GC &OPTIONAL ORDERING) - (OR (MEMBER NONE) PIXMAP RECT-SEQ)) -SetClipRectangles (SETF (GCONTEXT-CLIP-ORDERING GC) KEYWORD) -SetClipRectangles (SETF (GCONTEXT-CLIP-X GC) INT16) -SetClipRectangles (SETF (GCONTEXT-CLIP-Y GC) INT16) -SetDashes (SETF (GCONTEXT-DASH-OFFSET GC) CARD16) -SetDashes (SETF (GCONTEXT-DASHES GC) (OR CARD8 SEQUENCE)) -ChangeGC (SETF (GCONTEXT-EXPOSURES GC) (MEMBER ON OFF)) -ChangeGC (SETF (GCONTEXT-FILL-RULE GC) KEYWORD) -ChangeGC (SETF (GCONTEXT-FILL-STYLE GC) KEYWORD) -ChangeGC (SETF (GCONTEXT-FONT GC &OPTIONAL METRICS-P) FONT) -ChangeGC (SETF (GCONTEXT-FOREGROUND GC) CARD32) -ChangeGC (SETF (GCONTEXT-FUNCTION GC) BOOLE-CONSTANT) -ChangeGC (SETF (GCONTEXT-JOIN-STYLE GC) KEYWORD) -ChangeGC (SETF (GCONTEXT-LINE-STYLE GC) KEYWORD) -ChangeGC (SETF (GCONTEXT-LINE-WIDTH GC) CARD16) -ChangeGC (SETF (GCONTEXT-PLANE-MASK GC) CARD32) -ChangeGC (SETF (GCONTEXT-STIPPLE GC) PIXMAP) -ChangeGC (SETF (GCONTEXT-SUBWINDOW-MODE GC) KEYWORD) -ChangeGC (SETF (GCONTEXT-TILE GC) PIXMAP) -ChangeGC (SETF (GCONTEXT-TS-X GC) INT16) -ChangeGC (SETF (GCONTEXT-TS-Y GC) INT16) -ChangeWindowAttributes (SETF (WINDOW-BACKGROUND WINDOW) VALUE) -ChangeWindowAttributes (SETF (WINDOW-BACKING-PIXEL WINDOW) VALUE) -ChangeWindowAttributes (SETF (WINDOW-BACKING-PLANES WINDOW) VALUE) -ChangeWindowAttributes (SETF (WINDOW-BACKING-STORE WINDOW) VALUE) -ChangeWindowAttributes (SETF (WINDOW-BIT-GRAVITY WINDOW) VALUE) -ChangeWindowAttributes (SETF (WINDOW-BORDER WINDOW) VALUE) -ChangeWindowAttributes (SETF (WINDOW-COLORMAP WINDOW) VALUE) -ChangeWindowAttributes (SETF (WINDOW-CURSOR WINDOW) VALUE) -ChangeWindowAttributes (SETF (WINDOW-DO-NOT-PROPAGATE-MASK WINDOW) VALUE) -ChangeWindowAttributes (SETF (WINDOW-EVENT-MASK WINDOW) VALUE) -ChangeWindowAttributes (SETF (WINDOW-GRAVITY WINDOW) VALUE) -ChangeWindowAttributes (SETF (WINDOW-OVERRIDE-REDIRECT WINDOW) VALUE) -ConfigureWindow (SETF (WINDOW-PRIORITY WINDOW &OPTIONAL SIBLING) INTEGER) -ChangeWindowAttributes (SETF (WINDOW-SAVE-UNDER WINDOW) VALUE) - - - -;; Here's a list of the CLX functions that don't directly correspond to -;; X Window System requests. The've been categorized by function: - - ;Display Management -CLOSE-DISPLAY -CLOSE-DOWN-MODE -DISPLAY-AFTER-FUNCTION ;; SETF'able -DISPLAY-FINISH-OUTPUT -DISPLAY-FORCE-OUTPUT -DISPLAY-INVOKE-AFTER-FUNCTION -OPEN-DISPLAY -WITH-DISPLAY -WITH-EVENT-QUEUE - ;Extensions -DECLARE-EVENT -DECODE-CORE-ERROR -DEFAULT-ERROR-HANDLER -DEFINE-CONDITION -DEFINE-ERROR -DEFINE-EXTENSION -DEFINE-GCONTEXT-ACCESSOR -EXTENSION-OPCODE - ;Events -EVENT-CASE -EVENT-LISTEN -MAPPING-NOTIFY -PROCESS-EVENT -EVENT-HANDLER -MAKE-EVENT-HANDLERS -QUEUE-EVENT - ;Image -COPY-IMAGE -CREATE-IMAGE -GET-IMAGE -IMAGE-BLUE-MASK -IMAGE-DEPTH -IMAGE-GREEN-MASK -IMAGE-HEIGHT -IMAGE-NAME -IMAGE-PIXMAP -IMAGE-PLIST -IMAGE-RED-MASK -IMAGE-WIDTH -IMAGE-X-HOT -IMAGE-Y-HOT -PUT-IMAGE -READ-BITMAP-FILE -WRITE-BITMAP-FILE - ;Keysyms -CHARACTER->KEYSYMS -CHARACTER-IN-MAP-P -DEFAULT-KEYSYM-INDEX -DEFAULT-KEYSYM-TRANSLATE -DEFINE-KEYSYM -DEFINE-KEYSYM-SET -KEYCODE->CHARACTER -KEYCODE->KEYSYM -KEYSYM -KEYSYM->CHARACTER -KEYSYM-IN-MAP-P -KEYSYM-SET -UNDEFINE-KEYSYM - ;Properties -CUT-BUFFER -GET-STANDARD-COLORMAP -GET-WM-CLASS -ICON-SIZES -MAKE-WM-HINTS -MAKE-WM-SIZE-HINTS -ROTATE-CUT-BUFFERS -SET-STANDARD-COLORMAP -SET-WM-CLASS -TRANSIENT-FOR -WM-CLIENT-MACHINE -WM-COMMAND -WM-HINTS -WM-HINTS-FLAGS -WM-HINTS-ICON-MASK -WM-HINTS-ICON-PIXMAP -WM-HINTS-ICON-WINDOW -WM-HINTS-ICON-X -WM-HINTS-ICON-Y -WM-HINTS-INITIAL-STATE -WM-HINTS-INPUT -WM-HINTS-P -WM-HINTS-WINDOW-GROUP -WM-ICON-NAME -WM-NAME -WM-NORMAL-HINTS -WM-SIZE-HINTS-HEIGHT -WM-SIZE-HINTS-HEIGHT-INC -WM-SIZE-HINTS-MAX-ASPECT -WM-SIZE-HINTS-MAX-HEIGHT -WM-SIZE-HINTS-MAX-WIDTH -WM-SIZE-HINTS-MIN-ASPECT -WM-SIZE-HINTS-MIN-HEIGHT -WM-SIZE-HINTS-MIN-WIDTH -WM-SIZE-HINTS-P -WM-SIZE-HINTS-USER-SPECIFIED-POSITION-P -WM-SIZE-HINTS-USER-SPECIFIED-SIZE-P -WM-SIZE-HINTS-WIDTH -WM-SIZE-HINTS-WIDTH-INC -WM-SIZE-HINTS-X -WM-SIZE-HINTS-Y -WM-ZOOM-HINTS - ;Misc. -MAKE-COLOR -MAKE-EVENT-KEYS -MAKE-EVENT-MASK -MAKE-RESOURCE-DATABASE -MAKE-STATE-KEYS -MAKE-STATE-MASK -DISCARD-FONT-INFO -TRANSLATE-DEFAULT - ;Structures -BITMAP-FORMAT-LSB-FIRST-P -BITMAP-FORMAT-P -BITMAP-FORMAT-PAD -BITMAP-FORMAT-UNIT -BITMAP-IMAGE - -COLOR-BLUE -COLOR-GREEN -COLOR-P -COLOR-RED -COLOR-RGB -COLORMAP-DISPLAY -COLORMAP-EQUAL -COLORMAP-ID -COLORMAP-P -COLORMAP-VISUAL-INFO - -CURSOR-DISPLAY -CURSOR-EQUAL -CURSOR-ID -CURSOR-P - -DRAWABLE-DISPLAY -DRAWABLE-EQUAL -DRAWABLE-ID -DRAWABLE-P - -FONT-DISPLAY -FONT-EQUAL -FONT-ID -FONT-MAX-BOUNDS -FONT-MIN-BOUNDS -FONT-P -FONT-PLIST - -GCONTEXT-DISPLAY -GCONTEXT-EQUAL -GCONTEXT-ID -GCONTEXT-P -GCONTEXT-PLIST - -DISPLAY-AUTHORIZATION-DATA -DISPLAY-AUTHORIZATION-NAME -DISPLAY-BITMAP-FORMAT -DISPLAY-BYTE-ORDER -DISPLAY-DEFAULT-SCREEN -DISPLAY-DISPLAY -DISPLAY-ERROR-HANDLER -DISPLAY-IMAGE-LSB-FIRST-P -DISPLAY-KEYCODE-RANGE -DISPLAY-MAX-KEYCODE -DISPLAY-MAX-REQUEST-LENGTH -DISPLAY-MIN-KEYCODE -DISPLAY-MOTION-BUFFER-SIZE -DISPLAY-NSCREENS -DISPLAY-P -DISPLAY-PIXMAP-FORMATS -DISPLAY-PLIST -DISPLAY-PROTOCOL-MAJOR-VERSION -DISPLAY-PROTOCOL-MINOR-VERSION -DISPLAY-PROTOCOL-VERSION -DISPLAY-RELEASE-NUMBER -DISPLAY-RESOURCE-ID-BASE -DISPLAY-RESOURCE-ID-MASK -DISPLAY-ROOTS -DISPLAY-SQUISH -DISPLAY-VENDOR -DISPLAY-VENDOR-NAME -DISPLAY-VERSION-NUMBER -DISPLAY-XDEFAULTS -DISPLAY-XID - -PIXMAP-DISPLAY -PIXMAP-EQUAL -PIXMAP-FORMAT-BITS-PER-PIXEL -PIXMAP-FORMAT-DEPTH -PIXMAP-FORMAT-P -PIXMAP-FORMAT-SCANLINE-PAD -PIXMAP-ID -PIXMAP-P -PIXMAP-PLIST - -SCREEN-BACKING-STORES -SCREEN-BLACK-PIXEL -SCREEN-DEFAULT-COLORMAP -SCREEN-DEPTHS -SCREEN-EVENT-MASK-AT-OPEN -SCREEN-HEIGHT -SCREEN-HEIGHT-IN-MILLIMETERS -SCREEN-MAX-INSTALLED-MAPS -SCREEN-MIN-INSTALLED-MAPS -SCREEN-P -SCREEN-PLIST -SCREEN-ROOT -SCREEN-ROOT-DEPTH -SCREEN-ROOT-VISUAL-INFO -SCREEN-SAVE-UNDERS-P -SCREEN-WHITE-PIXEL -SCREEN-WIDTH -SCREEN-WIDTH-IN-MILLIMETERS - -VISUAL-INFO -VISUAL-INFO-BITS-PER-RGB -VISUAL-INFO-BLUE-MASK -VISUAL-INFO-CLASS -VISUAL-INFO-COLORMAP-ENTRIES -VISUAL-INFO-GREEN-MASK -VISUAL-INFO-ID -VISUAL-INFO-P -VISUAL-INFO-PLIST -VISUAL-INFO-RED-MASK - -WINDOW-DISPLAY -WINDOW-EQUAL -WINDOW-ID -WINDOW-P -WINDOW-PLIST diff --git a/src/eclx/fonts.lisp b/src/eclx/fonts.lisp deleted file mode 100644 index de596fd79..000000000 --- a/src/eclx/fonts.lisp +++ /dev/null @@ -1,368 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; -#+cmu -(ext:file-comment - "$Header$") - -(in-package :xlib) - -;; The char-info stuff is here instead of CLX because of uses of int16->card16. - -; To allow efficient storage representations, the type char-info is not -; required to be a structure. - -;; For each of left-bearing, right-bearing, width, ascent, descent, attributes: - -;(defun char- (font index) -; ;; Note: I have tentatively chosen to return nil for an out-of-bounds index -; ;; (or an in-bounds index on a pseudo font), although returning zero or -; ;; signalling might be better. -; (declare (type font font) -; (type integer index) -; (clx-values (or null integer)))) - -;(defun max-char- (font) -; ;; Note: I have tentatively chosen separate accessors over allowing :min and -; ;; :max as an index above. -; (declare (type font font) -; (clx-values integer))) - -;(defun min-char- (font) -; (declare (type font font) -; (clx-values integer))) - -;; Note: char16- accessors could be defined to accept two-byte indexes. - -(deftype char-info-vec () '(simple-array int16 (*))) - -(macrolet ((def-char-info-accessors (useless-name &body fields) - `(within-definition (,useless-name def-char-info-accessors) - ,@(do ((field fields (cdr field)) - (n 0 (1+ n)) - (name) (type) - (result nil)) - ((endp field) result) - (setq name (xintern 'char- (caar field))) - (setq type (cadar field)) - (flet ((from (form) - (if (eq type 'int16) - form - `(,(xintern 'int16-> type) ,form)))) - (push - `(defun ,name (font index) - (declare (type font font) - (type array-index index)) - (declare (clx-values (or null ,type))) - (when (and (font-name font) - (index>= (font-max-char font) index (font-min-char font))) - (the ,type - ,(from - `(the int16 - (let ((char-info-vector (font-char-infos font))) - (declare (type char-info-vec char-info-vector)) - (if (index-zerop (length char-info-vector)) - ;; Fixed width font - (aref (the char-info-vec - (font-max-bounds font)) - ,n) - ;; Variable width font - (aref char-info-vector - (index+ - (index* - 6 - (index- - index - (font-min-char font))) - ,n))))))))) - result) - (setq name (xintern 'min-char- (caar field))) - (push - `(defun ,name (font) - (declare (type font font)) - (declare (clx-values (or null ,type))) - (when (font-name font) - (the ,type - ,(from - `(the int16 - (aref (the char-info-vec (font-min-bounds font)) - ,n)))))) - result) - (setq name (xintern 'max-char- (caar field))) - (push - `(defun ,name (font) - (declare (type font font)) - (declare (clx-values (or null ,type))) - (when (font-name font) - (the ,type - ,(from - `(the int16 - (aref (the char-info-vec (font-max-bounds font)) - ,n)))))) - result))) - - (defun make-char-info - (&key ,@(mapcar - #'(lambda (field) - `(,(car field) (required-arg ,(car field)))) - fields)) - (declare ,@(mapcar #'(lambda (field) `(type ,@(reverse field))) fields)) - (let ((result (make-array ,(length fields) :element-type 'int16))) - (declare (type char-info-vec result)) - ,@(do* ((field fields (cdr field)) - (var (caar field) (caar field)) - (type (cadar field) (cadar field)) - (n 0 (1+ n)) - (result nil)) - ((endp field) (nreverse result)) - (push `(setf (aref result ,n) - ,(if (eq type 'int16) - var - `(,(xintern type '->int16) ,var))) - result)) - result))))) - (def-char-info-accessors ignore - (left-bearing int16) - (right-bearing int16) - (width int16) - (ascent int16) - (descent int16) - (attributes card16))) - -(defun open-font (display name) - ;; Font objects may be cached and reference counted locally within the display - ;; object. This function might not execute a with-display if the font is cached. - ;; The protocol QueryFont request happens on-demand under the covers. - (declare (type display display) - (type stringable name)) - (declare (clx-values font)) - (let* ((name-string (string-downcase (string name))) - (font (car (member name-string (display-font-cache display) - :key 'font-name - :test 'equal))) - font-id) - (unless font - (setq font (make-font :display display :name name-string)) - (setq font-id (allocate-resource-id display font 'font)) - (setf (font-id-internal font) font-id) - (with-buffer-request (display +x-openfont+) - (resource-id font-id) - (card16 (length name-string)) - (pad16 nil) - (string name-string)) - (push font (display-font-cache display))) - (incf (font-reference-count font)) - font)) - -(defun open-font-internal (font) - ;; Called "under the covers" to open a font object - (declare (type font font)) - (declare (clx-values resource-id)) - (let* ((name-string (font-name font)) - (display (font-display font)) - (id (allocate-resource-id display font 'font))) - (setf (font-id-internal font) id) - (with-buffer-request (display +x-openfont+) - (resource-id id) - (card16 (length name-string)) - (pad16 nil) - (string name-string)) - (push font (display-font-cache display)) - (incf (font-reference-count font)) - id)) - -(defun discard-font-info (font) - ;; Discards any state that can be re-obtained with QueryFont. This is - ;; simply a performance hint for memory-limited systems. - (declare (type font font)) - (setf (font-font-info-internal font) nil - (font-char-infos-internal font) nil)) - -(defun query-font (font) - ;; Internal function called by font and char info accessors - (declare (type font font)) - (declare (clx-values font-info)) - (let ((display (font-display font)) - font-id - font-info - props) - (setq font-id (font-id font)) ;; May issue an open-font request - (with-buffer-request-and-reply (display +x-queryfont+ 60) - ((resource-id font-id)) - (let* ((min-byte2 (card16-get 40)) - (max-byte2 (card16-get 42)) - (min-byte1 (card8-get 49)) - (max-byte1 (card8-get 50)) - (min-char min-byte2) - (max-char (index+ (index-ash max-byte1 8) max-byte2)) - (nfont-props (card16-get 46)) - (nchar-infos (index* (card32-get 56) 6)) - (char-info (make-array nchar-infos :element-type 'int16))) - (setq font-info - (make-font-info - :direction (member8-get 48 :left-to-right :right-to-left) - :min-char min-char - :max-char max-char - :min-byte1 min-byte1 - :max-byte1 max-byte1 - :min-byte2 min-byte2 - :max-byte2 max-byte2 - :all-chars-exist-p (boolean-get 51) - :default-char (card16-get 44) - :ascent (int16-get 52) - :descent (int16-get 54) - :min-bounds (char-info-get 8) - :max-bounds (char-info-get 24))) - (setq props (sequence-get :length (index* 2 nfont-props) :format int32 - :result-type 'list :index 60)) - (sequence-get :length nchar-infos :format int16 :data char-info - :index (index+ 60 (index* 2 nfont-props 4))) - (setf (font-char-infos-internal font) char-info) - (setf (font-font-info-internal font) font-info))) - ;; Replace atom id's with keywords in the plist - (do ((p props (cddr p))) - ((endp p)) - (setf (car p) (atom-name display (car p)))) - (setf (font-info-properties font-info) props) - font-info)) - -(defun close-font (font) - ;; This might not generate a protocol request if the font is reference - ;; counted locally. - (declare (type font font)) - (when (and (not (plusp (decf (font-reference-count font)))) - (font-id-internal font)) - (let ((display (font-display font)) - (id (font-id-internal font))) - (declare (type display display)) - ;; Remove font from cache - (setf (display-font-cache display) (delete font (display-font-cache display))) - ;; Close the font - (with-buffer-request (display +x-closefont+) - (resource-id id))))) - -(defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list)) - (declare (type display display) - (type string pattern) - (type card16 max-fonts) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence string))) - (let ((string (string pattern))) - (with-buffer-request-and-reply (display +x-listfonts+ size :sizes (8 16)) - ((card16 max-fonts (length string)) - (string string)) - (values - (read-sequence-string - buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+))))) - -(defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list)) - ;; Note: Was called list-fonts-with-info. - ;; Returns "pseudo" fonts that contain basic font metrics and properties, but - ;; no per-character metrics and no resource-ids. These pseudo fonts will be - ;; converted (internally) to real fonts dynamically as needed, by issuing an - ;; OpenFont request. However, the OpenFont might fail, in which case the - ;; invalid-font error can arise. - (declare (type display display) - (type string pattern) - (type card16 max-fonts) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence font))) - (let ((string (string pattern)) - (result nil)) - (with-buffer-request-and-reply (display +x-listfontswithinfo+ 60 - :sizes (8 16) :multiple-reply t) - ((card16 max-fonts (length string)) - (string string)) - (cond ((zerop (card8-get 1)) t) - (t - (let* ((name-len (card8-get 1)) - (min-byte2 (card16-get 40)) - (max-byte2 (card16-get 42)) - (min-byte1 (card8-get 49)) - (max-byte1 (card8-get 50)) - (min-char min-byte2) - (max-char (index+ (index-ash max-byte1 8) max-byte2)) - (nfont-props (card16-get 46)) - (font - (make-font - :display display - :name nil - :font-info-internal - (make-font-info - :direction (member8-get 48 :left-to-right :right-to-left) - :min-char min-char - :max-char max-char - :min-byte1 min-byte1 - :max-byte1 max-byte1 - :min-byte2 min-byte2 - :max-byte2 max-byte2 - :all-chars-exist-p (boolean-get 51) - :default-char (card16-get 44) - :ascent (int16-get 52) - :descent (int16-get 54) - :min-bounds (char-info-get 8) - :max-bounds (char-info-get 24) - :properties (sequence-get :length (index* 2 nfont-props) - :format int32 - :result-type 'list - :index 60))))) - (setf (font-name font) (string-get name-len (index+ 60 (index* 2 nfont-props 4)))) - (push font result)) - nil))) - ;; Replace atom id's with keywords in the plist - (dolist (font result) - (do ((p (font-properties font) (cddr p))) - ((endp p)) - (setf (car p) (atom-name display (car p))))) - (coerce (nreverse result) result-type))) - -(defun font-path (display &key (result-type 'list)) - (declare (type display display) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence (or string pathname)))) - (with-buffer-request-and-reply (display +x-getfontpath+ size :sizes (8 16)) - () - (values - (read-sequence-string - buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+)))) - -(defun set-font-path (display paths) - (declare (type display display) - (type (clx-sequence (or string pathname)) paths)) - (let ((path-length (length paths)) - (request-length 8)) - ;; Find the request length - (dotimes (i path-length) - (let* ((string (string (elt paths i))) - (len (length string))) - (incf request-length (1+ len)))) - (with-buffer-request (display +x-setfontpath+ :length request-length) - (length (ceiling request-length 4)) - (card16 path-length) - (pad16 nil) - (progn - (incf buffer-boffset 8) - (dotimes (i path-length) - (let* ((string (string (elt paths i))) - (len (length string))) - (card8-put 0 len) - (string-put 1 string :appending t :header-length 1) - (incf buffer-boffset (1+ len)))) - (setf (buffer-boffset display) (lround buffer-boffset))))) - paths) - -(defsetf font-path set-font-path) diff --git a/src/eclx/gcontext.lisp b/src/eclx/gcontext.lisp deleted file mode 100644 index ffe6b7dfd..000000000 --- a/src/eclx/gcontext.lisp +++ /dev/null @@ -1,974 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; GContext - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -;;; GContext values are usually cached locally in the GContext object. -;;; This is required because the X.11 server doesn't have any requests -;;; for getting GContext values back. -;;; -;;; GContext changes are cached until force-GContext-changes is called. -;;; All the requests that use GContext (including the GContext accessors, -;;; but not the SETF's) call force-GContext-changes. -;;; In addition, the macro WITH-GCONTEXT may be used to provide a -;;; local view if a GContext. -;;; -;;; Each GContext keeps a copy of the values the server has seen, and -;;; a copy altered by SETF, called the LOCAL-STATE (bad name...). -;;; The SETF accessors increment a timestamp in the GContext. -;;; When the timestamp in a GContext isn't equal to the timestamp in -;;; the local-state, changes have been made, and force-GContext-changes -;;; loops through the GContext and local-state, sending differences to -;;; the server, and updating GContext. -;;; -;;; WITH-GCONTEXT works by BINDING the local-state slot in a GContext to -;;; a private copy. This is easy (and fast) for lisp machines, but other -;;; lisps will have problems. Fortunately, most other lisps don't care, -;;; because they don't run in a multi-processing shared-address space -;;; environment. -#+cmu -(ext:file-comment - "$Header$") - -(in-package :xlib) - -;; GContext state accessors -;; The state vector contains all card32s to speed server updating - -(eval-when (:execute :compile-toplevel :load-toplevel) - -(defconstant +gcontext-fast-change-length+ #.(length *gcontext-components*)) - -(macrolet ((def-gc-internals (name &rest extras) - (let ((macros nil) - (indexes nil) - (masks nil) - (index 0)) - (dolist (name *gcontext-components*) - (push `(defmacro ,(xintern 'gcontext-internal- name) (state) - `(svref ,state ,,index)) - macros) - (setf (getf indexes name) index) - (push (ash 1 index) masks) - (incf index)) - (dolist (extra extras) - (push `(defmacro ,(xintern 'gcontext-internal- (first extra)) (state) - `(svref ,state ,,index)) - macros) - ;; don't override already correct index entries - (unless (or (getf indexes (second extra)) (getf indexes (first extra))) - (setf (getf indexes (or (second extra) (first extra))) index)) - (push (logior (ash 1 index) - (if (second extra) - (ash 1 (position (second extra) *gcontext-components*)) - 0)) - masks) - (incf index)) - `(within-definition (def-gc-internals ,name) - ,@(nreverse macros) - (eval-when (:execute :compile-toplevel :load-toplevel) - (defparameter *gcontext-data-length* ,index) - (defparameter *gcontext-indexes* ',indexes) - (defparameter *gcontext-masks* - ',(coerce (nreverse masks) 'simple-vector))))))) - (def-gc-internals ignore - (:clip :clip-mask) (:dash :dashes) (:font-obj :font) (:timestamp))) - -) ;; end EVAL-WHEN - -(deftype gcmask () '(unsigned-byte #.+gcontext-fast-change-length+)) - -(deftype xgcmask () '(unsigned-byte #.*gcontext-data-length*)) - -(defstruct (gcontext-extension (:type vector) (:copier nil)) ;; un-named - (name nil :type symbol :read-only t) - (default nil :type t :read-only t) - (set-function #'(lambda (gcontext value) - (declare (ignore gcontext)) - value) - :type (function (gcontext t) t) :read-only t) - (copy-function #'(lambda (from-gc to-gc value) - (declare (ignore from-gc to-gc)) - value) - :type (function (gcontext gcontext t) t) :read-only t)) - -(defvar *gcontext-extensions* nil) ;; list of gcontext-extension - -;; Gcontext state Resource -(defvar *gcontext-local-state-cache* nil) ;; List of unused gcontext local states - -(defmacro gcontext-state-next (state) - `(svref ,state 0)) - -(defun allocate-gcontext-state () - ;; Allocate a gcontext-state - ;; Loop until a local state is found that's large enough to hold - ;; any extensions that may exist. - (let ((length (index+ *gcontext-data-length* (length *gcontext-extensions*)))) - (declare (type array-index length)) - (loop - (let ((state (or (threaded-atomic-pop *gcontext-local-state-cache* - gcontext-state-next gcontext-state) - (make-array length :initial-element nil)))) - (declare (type gcontext-state state)) - (when (index>= (length state) length) - (return state)))))) - -(defun deallocate-gcontext-state (state) - (declare (type gcontext-state state)) - (fill state nil) - (threaded-atomic-push state *gcontext-local-state-cache* - gcontext-state-next gcontext-state)) - -;; Temp-Gcontext Resource -(defvar *temp-gcontext-cache* nil) ;; List of unused gcontexts - -(defun allocate-temp-gcontext () - (or (threaded-atomic-pop *temp-gcontext-cache* gcontext-next gcontext) - (make-gcontext :local-state '#() :server-state '#()))) - -(defun deallocate-temp-gcontext (gc) - (declare (type gcontext gc)) - (threaded-atomic-push gc *temp-gcontext-cache* gcontext-next gcontext)) - -;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared -;; as (type ), there is an accessor: - -;(defun gcontext- (gcontext) -; ;; The value will be nil if the last value stored is unknown (e.g., the cache was -; ;; off, or the component was copied from a gcontext with unknown state). -; (declare (type gcontext gcontext) -; (clx-values ))) - -;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared -;; as (type (or null ) ), there is a setf for the corresponding accessor: - -;(defsetf gcontext- (gcontext) (value) -; ) - -;; Generate all the accessors and defsetf's for GContext - -(defmacro xgcmask->gcmask (mask) - `(the gcmask (logand ,mask #.(1- (ash 1 +gcontext-fast-change-length+))))) - -(defmacro access-gcontext ((gcontext local-state) &body body) - `(let ((,local-state (gcontext-local-state ,gcontext))) - (declare (type gcontext-state ,local-state)) - ,@body)) - -(defmacro modify-gcontext ((gcontext local-state) &body body) - ;; The timestamp must be altered after the modification - `(let ((,local-state (gcontext-local-state ,gcontext))) - (declare (type gcontext-state ,local-state)) - (prog1 - (progn ,@body) - (setf (gcontext-internal-timestamp ,local-state) 0)))) - -(defmacro def-gc-accessor (name type) - (let* ((gcontext-name (xintern 'gcontext- name)) - (internal-accessor (xintern 'gcontext-internal- name)) - (internal-setfer (xintern 'set- gcontext-name))) - `(within-definition (,name def-gc-accessor) - - (defun ,gcontext-name (gcontext) - (declare (type gcontext gcontext)) - (declare (clx-values (or null ,type))) - (let ((value (,internal-accessor (gcontext-local-state gcontext)))) - (declare (type (or null card32) value)) - (when value ;; Don't do anything when value isn't known - (let ((%buffer (gcontext-display gcontext))) - (declare (type display %buffer)) - %buffer - (decode-type ,type value))))) - - (defun ,internal-setfer (gcontext value) - (declare (type gcontext gcontext) - (type ,type value)) - (modify-gcontext (gcontext local-state) - (setf (,internal-accessor local-state) (encode-type ,type value)) - ,@(when (eq type 'pixmap) - ;; write-through pixmaps, because the protocol allows - ;; the server to copy the pixmap contents at the time - ;; of the store, rather than continuing to share with - ;; the pixmap. - `((let ((server-state (gcontext-server-state gcontext))) - (setf (,internal-accessor server-state) nil)))) - value)) - - (defsetf ,gcontext-name ,internal-setfer)))) - -(defmacro incf-internal-timestamp (state) - (let ((ts (gensym))) - `(let ((,ts (the fixnum (gcontext-internal-timestamp ,state)))) - (declare (type fixnum ,ts)) - ;; the probability seems low enough - (setq ,ts (if (= ,ts most-positive-fixnum) - 1 - (the fixnum (1+ ,ts)))) - (setf (gcontext-internal-timestamp ,state) ,ts)))) - -(def-gc-accessor function boole-constant) -(def-gc-accessor plane-mask card32) -(def-gc-accessor foreground card32) -(def-gc-accessor background card32) -(def-gc-accessor line-width card16) -(def-gc-accessor line-style (member :solid :dash :double-dash)) -(def-gc-accessor cap-style (member :not-last :butt :round :projecting)) -(def-gc-accessor join-style (member :miter :round :bevel)) -(def-gc-accessor fill-style (member :solid :tiled :stippled :opaque-stippled)) -(def-gc-accessor fill-rule (member :even-odd :winding)) -(def-gc-accessor tile pixmap) -(def-gc-accessor stipple pixmap) -(def-gc-accessor ts-x int16) ;; Tile-Stipple-X-origin -(def-gc-accessor ts-y int16) ;; Tile-Stipple-Y-origin -;; (def-GC-accessor font font) ;; See below -(def-gc-accessor subwindow-mode (member :clip-by-children :include-inferiors)) -(def-gc-accessor exposures (member :off :on)) -(def-gc-accessor clip-x int16) -(def-gc-accessor clip-y int16) -;; (def-GC-accessor clip-mask) ;; see below -(def-gc-accessor dash-offset card16) -;; (def-GC-accessor dashes) ;; see below -(def-gc-accessor arc-mode (member :chord :pie-slice)) - - -(defun gcontext-clip-mask (gcontext) - (declare (type gcontext gcontext)) - (declare (clx-values (or null (member :none) pixmap rect-seq) - (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)))) - (access-gcontext (gcontext local-state) - (multiple-value-bind (clip clip-mask) - (without-interrupts - (values (gcontext-internal-clip local-state) - (gcontext-internal-clip-mask local-state))) - (if (null clip) - (values (let ((%buffer (gcontext-display gcontext))) - (declare (type display %buffer)) - (decode-type (or (member :none) pixmap) clip-mask)) - nil) - (values (second clip) - (decode-type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) - (first clip))))))) - -(defsetf gcontext-clip-mask (gcontext &optional ordering) (clip-mask) - ;; A bit strange, but retains setf form. - ;; a nil clip-mask is transformed to an empty vector - `(set-gcontext-clip-mask ,gcontext ,ordering ,clip-mask)) - -(defun set-gcontext-clip-mask (gcontext ordering clip-mask) - ;; a nil clip-mask is transformed to an empty vector - (declare (type gcontext gcontext) - (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) ordering) - (type (or (member :none) pixmap rect-seq) clip-mask)) - (unless clip-mask (x-type-error clip-mask '(or (member :none) pixmap rect-seq))) - (multiple-value-bind (clip-mask clip) - (typecase clip-mask - (pixmap (values (pixmap-id clip-mask) nil)) - ((member :none) (values 0 nil)) - (sequence - (values nil - (list (encode-type - (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) - ordering) - (copy-seq clip-mask)))) - (otherwise (x-type-error clip-mask '(or (member :none) pixmap rect-seq)))) - (modify-gcontext (gcontext local-state) - (let ((server-state (gcontext-server-state gcontext))) - (declare (type gcontext-state server-state)) - (without-interrupts - (setf (gcontext-internal-clip local-state) clip - (gcontext-internal-clip-mask local-state) clip-mask) - (if (null clip) - (setf (gcontext-internal-clip server-state) nil) - (setf (gcontext-internal-clip-mask server-state) nil)) - (when (and clip-mask (not (zerop clip-mask))) - ;; write-through clip-mask pixmap, because the protocol allows the - ;; server to copy the pixmap contents at the time of the store, - ;; rather than continuing to share with the pixmap. - (setf (gcontext-internal-clip-mask server-state) nil)))))) - clip-mask) - -(defun gcontext-dashes (gcontext) - (declare (type gcontext gcontext)) - (declare (clx-values (or null card8 sequence))) - (access-gcontext (gcontext local-state) - (multiple-value-bind (dash dashes) - (without-interrupts - (values (gcontext-internal-dash local-state) - (gcontext-internal-dashes local-state))) - (if (null dash) - dashes - dash)))) - -(defsetf gcontext-dashes set-gcontext-dashes) - -(defun set-gcontext-dashes (gcontext dashes) - (declare (type gcontext gcontext) - (type (or card8 sequence) dashes)) - (multiple-value-bind (dashes dash) - (if (type? dashes 'sequence) - (if (zerop (length dashes)) - (x-type-error dashes '(or card8 sequence) "non-empty sequence") - (values nil (or (copy-seq dashes) (vector)))) - (values (encode-type card8 dashes) nil)) - (modify-gcontext (gcontext local-state) - (let ((server-state (gcontext-server-state gcontext))) - (declare (type gcontext-state server-state)) - (without-interrupts - (setf (gcontext-internal-dash local-state) dash - (gcontext-internal-dashes local-state) dashes) - (if (null dash) - (setf (gcontext-internal-dash server-state) nil) - (setf (gcontext-internal-dashes server-state) nil)))))) - dashes) - -(defun gcontext-font (gcontext &optional metrics-p) - ;; If the stored font is known, it is returned. If it is not known and - ;; metrics-p is false, then nil is returned. If it is not known and - ;; metrics-p is true, then a pseudo font is returned. Full metric and - ;; property information can be obtained, but the font does not have a name or - ;; a resource-id, and attempts to use it where a resource-id is required will - ;; result in an invalid-font error. - (declare (type gcontext gcontext) - (type generalized-boolean metrics-p)) - (declare (clx-values (or null font))) - (access-gcontext (gcontext local-state) - (let ((font (gcontext-internal-font-obj local-state))) - (or font - (when metrics-p - ;; XXX this isn't correct - (make-font :display (gcontext-display gcontext) - :id (gcontext-id gcontext) - :name nil)))))) - -(defsetf gcontext-font set-gcontext-font) - -(defun set-gcontext-font (gcontext font) - (declare (type gcontext gcontext) - (type fontable font)) - (let* ((font-object (if (font-p font) font (open-font (gcontext-display gcontext) font))) - (font (and font-object (font-id font-object)))) - ;; XXX need to check font has id (and name?) - (modify-gcontext (gcontext local-state) - (let ((server-state (gcontext-server-state gcontext))) - (declare (type gcontext-state server-state)) - (without-interrupts - (setf (gcontext-internal-font-obj local-state) font-object - (gcontext-internal-font local-state) font) - ;; check against font, not against font-obj - (if (null font) - (setf (gcontext-internal-font server-state) nil) - (setf (gcontext-internal-font-obj server-state) font-object)))))) - font) - -(defun force-gcontext-changes-internal (gcontext) - ;; Force any delayed changes. - (declare (type gcontext gcontext)) - #.(declare-buffun) - - (let ((display (gcontext-display gcontext)) - (server-state (gcontext-server-state gcontext)) - (local-state (gcontext-local-state gcontext))) - (declare (type display display) - (type gcontext-state server-state local-state)) - - ;; Update server when timestamps don't match - (unless (= (the fixnum (gcontext-internal-timestamp local-state)) - (the fixnum (gcontext-internal-timestamp server-state))) - - ;; The display is already locked. - (macrolet ((with-buffer ((buffer &key timeout) &body body) - `(progn (progn ,buffer ,@(and timeout `(,timeout)) nil) - ,@body))) - - ;; Because there is no locking on the local state we have to - ;; assume that state will change and set timestamps up front, - ;; otherwise by the time we figured out there were no changes - ;; and tried to store the server stamp as the local stamp, the - ;; local stamp might have since been modified. - (setf (gcontext-internal-timestamp local-state) - (incf-internal-timestamp server-state)) - - (block no-changes - (let ((last-request (buffer-last-request display))) - (with-buffer-request (display +x-changegc+) - (gcontext gcontext) - (progn - (do ((i 0 (index+ i 1)) - (bit 1 (the xgcmask (ash bit 1))) - (nbyte 12) - (mask 0) - (local 0)) - ((index>= i +gcontext-fast-change-length+) - (when (zerop mask) - ;; If nothing changed, restore last-request and quit - (setf (buffer-last-request display) - (if (zerop (buffer-last-request display)) - nil - last-request)) - (return-from no-changes nil)) - (card29-put 8 mask) - (card16-put 2 (index-ash nbyte -2)) - (index-incf (buffer-boffset display) nbyte)) - (declare (type array-index i nbyte) - (type xgcmask bit) - (type gcmask mask) - (type (or null card32) local)) - (unless (eql (the (or null card32) (svref server-state i)) - (setq local (the (or null card32) (svref local-state i)))) - (setf (svref server-state i) local) - (card32-put nbyte local) - (setq mask (the gcmask (logior mask bit))) - (index-incf nbyte 4))))))) - - ;; Update GContext extensions - (do ((extension *gcontext-extensions* (cdr extension)) - (i *gcontext-data-length* (index+ i 1)) - (local)) - ((endp extension)) - (unless (eql (svref server-state i) - (setq local (svref local-state i))) - (setf (svref server-state i) local) - (funcall (gcontext-extension-set-function (car extension)) gcontext local))) - - ;; Update clipping rectangles - (multiple-value-bind (local-clip server-clip) - (without-interrupts - (values (gcontext-internal-clip local-state) - (gcontext-internal-clip server-state))) - (unless (equalp local-clip server-clip) - (setf (gcontext-internal-clip server-state) nil) - (unless (null local-clip) - (with-buffer-request (display +x-setcliprectangles+) - (data (first local-clip)) - (gcontext gcontext) - ;; XXX treat nil correctly - (card16 (or (gcontext-internal-clip-x local-state) 0) - (or (gcontext-internal-clip-y local-state) 0)) - ;; XXX this has both int16 and card16 values - ((sequence :format int16) (second local-clip))) - (setf (gcontext-internal-clip server-state) local-clip)))) - - ;; Update dashes - (multiple-value-bind (local-dash server-dash) - (without-interrupts - (values (gcontext-internal-dash local-state) - (gcontext-internal-dash server-state))) - (unless (equalp local-dash server-dash) - (setf (gcontext-internal-dash server-state) nil) - (unless (null local-dash) - (with-buffer-request (display +x-setdashes+) - (gcontext gcontext) - ;; XXX treat nil correctly - (card16 (or (gcontext-internal-dash-offset local-state) 0) - (length local-dash)) - ((sequence :format card8) local-dash)) - (setf (gcontext-internal-dash server-state) local-dash)))))))) - -(defun force-gcontext-changes (gcontext) - ;; Force any delayed changes. - (declare (type gcontext gcontext)) - (let ((display (gcontext-display gcontext)) - (server-state (gcontext-server-state gcontext)) - (local-state (gcontext-local-state gcontext))) - (declare (type gcontext-state server-state local-state)) - ;; Update server when timestamps don't match - (unless (= (the fixnum (gcontext-internal-timestamp local-state)) - (the fixnum (gcontext-internal-timestamp server-state))) - (with-display (display) - (force-gcontext-changes-internal gcontext))))) - -;;; WARNING: WITH-GCONTEXT WORKS MUCH MORE EFFICIENTLY WHEN THE OPTIONS BEING "BOUND" ARE -;;; SET IN THE GCONTEXT ON ENTRY. BECAUSE THERE'S NO WAY TO GET THE VALUE OF AN -;;; UNKNOWN GC COMPONENT, WITH-GCONTEXT MUST CREATE A TEMPORARY GC, COPY THE UNKNOWN -;;; COMPONENTS TO THE TEMPORARY GC, ALTER THE GC BEING USED, THEN COPY COMPOMENTS -;;; BACK. - -(defmacro with-gcontext ((gcontext &rest options &key clip-ordering - &allow-other-keys) - &body body) - ;; "Binds" the gcontext components specified by options within the - ;; dynamic scope of the body (i.e., indefinite scope and dynamic - ;; extent), on a per-process basis in a multi-process environment. - ;; The body is not surrounded by a with-display. If cache-p is nil or - ;; the some component states are unknown, this will implement - ;; save/restore by creating a temporary gcontext and doing - ;; copy-gcontext-components to and from it. - - (declare (arglist (gcontext &rest options &key - function plane-mask foreground background - line-width line-style cap-style join-style - fill-style fill-rule arc-mode tile stipple ts-x - ts-y font subwindow-mode exposures clip-x clip-y - clip-mask clip-ordering dash-offset dashes - &allow-other-keys) - &body body)) - (remf options :clip-ordering) - - (let ((gc (gensym)) - (saved-state (gensym)) - (temp-gc (gensym)) - (temp-mask (gensym)) - (temp-vars nil) - (setfs nil) - (indexes nil) ; List of gcontext field indices - (extension-indexes nil) ; List of gcontext extension field indices - (ts-index (getf *gcontext-indexes* :timestamp))) - - (do* ((option options (cddr option)) - (name (car option) (car option)) - (value (cadr option) (cadr option))) - ((endp option) (setq setfs (nreverse setfs))) - (let ((index (getf *gcontext-indexes* name))) - (if index - (push index indexes) - (let ((extension (find name *gcontext-extensions* - :key #'gcontext-extension-name))) - (if extension - (progn - (push (xintern "Internal-" 'gcontext- name "-State-Index") - extension-indexes)) - (x-type-error name 'gcontext-key))))) - (let ((accessor `(,(xintern 'gcontext- name) ,gc - ,@(when (eq name :clip-mask) `(,clip-ordering)))) - (temp-var (gensym))) - (when value - (push `(,temp-var ,value) temp-vars) - (push `(when ,temp-var (setf ,accessor ,temp-var)) setfs)))) - (if setfs - `(multiple-value-bind (,gc ,saved-state ,temp-mask ,temp-gc) - (copy-gcontext-local-state ,gcontext ',indexes ,@extension-indexes) - (declare (type gcontext ,gc) - (type gcontext-state ,saved-state) - (type xgcmask ,temp-mask) - (type (or null gcontext) ,temp-gc)) - (with-gcontext-bindings (,gc ,saved-state - ,(append indexes extension-indexes) - ,ts-index ,temp-mask ,temp-gc) - (let ,temp-vars - ,@setfs) - ,@body)) - `(progn ,@body)))) - -(defun copy-gcontext-local-state (gcontext indexes &rest extension-indices) - ;; Called from WITH-GCONTEXT to save the fields in GCONTEXT indicated by MASK - (declare (type gcontext gcontext) - (type list indexes) - (dynamic-extent extension-indices)) - (let ((local-state (gcontext-local-state gcontext)) - (saved-state (allocate-gcontext-state)) - (cache-p (gcontext-cache-p gcontext))) - (declare (type gcontext-state local-state saved-state)) - (setf (gcontext-internal-timestamp saved-state) 1) - (let ((temp-gc nil) - (temp-mask 0) - (extension-mask 0)) - (declare (type xgcmask temp-mask) - (type integer extension-mask)) - (dolist (i indexes) - (when (or (not (setf (svref saved-state i) (svref local-state i))) - (not cache-p)) - (setq temp-mask - (the xgcmask (logior temp-mask - (the xgcmask (svref *gcontext-masks* i))))))) - (dolist (i extension-indices) - (when (or (not (setf (svref saved-state i) (svref local-state i))) - (not cache-p)) - (setq extension-mask - (the xgcmask (logior extension-mask (ash 1 i)))))) - (when (or (plusp temp-mask) - (plusp extension-mask)) - ;; Copy to temporary GC when field unknown or cache-p false - (let ((display (gcontext-display gcontext))) - (declare (type display display)) - (with-display (display) - (setq temp-gc (allocate-temp-gcontext)) - (setf (gcontext-id temp-gc) (allocate-resource-id display gcontext 'gcontext) - (gcontext-display temp-gc) display - (gcontext-drawable temp-gc) (gcontext-drawable gcontext) - (gcontext-server-state temp-gc) saved-state - (gcontext-local-state temp-gc) saved-state) - ;; Create a new (temporary) gcontext - (with-buffer-request (display +x-creategc+) - (gcontext temp-gc) - (drawable (gcontext-drawable gcontext)) - (card29 0)) - ;; Copy changed components to the temporary gcontext - (when (plusp temp-mask) - (with-buffer-request (display +x-copygc+) - (gcontext gcontext) - (gcontext temp-gc) - (card29 (xgcmask->gcmask temp-mask)))) - ;; Copy extension fields to the new gcontext - (when (plusp extension-mask) - ;; Copy extension fields from temp back to gcontext - (do ((bit (ash extension-mask (- *gcontext-data-length*)) (ash bit -1)) - (i 0 (index+ i 1))) - ((zerop bit)) - (let ((copy-function (gcontext-extension-copy-function - (elt *gcontext-extensions* i)))) - (funcall copy-function gcontext temp-gc - (svref local-state (index+ i *gcontext-data-length*)))))) - ))) - (values gcontext saved-state (logior temp-mask extension-mask) temp-gc)))) - -(defun restore-gcontext-temp-state (gcontext temp-mask temp-gc) - (declare (type gcontext gcontext temp-gc) - (type xgcmask temp-mask)) - (let ((display (gcontext-display gcontext))) - (declare (type display display)) - (with-display (display) - (with-buffer-request (display +x-copygc+) - (gcontext temp-gc) - (gcontext gcontext) - (card29 (xgcmask->gcmask temp-mask))) - ;; Copy extension fields from temp back to gcontext - (do ((bit (ash temp-mask (- *gcontext-data-length*)) (ash bit -1)) - (extensions *gcontext-extensions* (cdr extensions)) - (i *gcontext-data-length* (index+ i 1)) - (local-state (gcontext-local-state temp-gc))) - ((zerop bit)) - (let ((copy-function (gcontext-extension-copy-function (car extensions)))) - (funcall copy-function temp-gc gcontext (svref local-state i)))) - ;; free gcontext - (with-buffer-request (display +x-freegc+) - (gcontext temp-gc)) - (deallocate-resource-id display (gcontext-id temp-gc) 'gcontext) - (deallocate-temp-gcontext temp-gc) - ;; Copy saved state back to server state - (do ((server-state (gcontext-server-state gcontext)) - (bit (xgcmask->gcmask temp-mask) (the gcmask (ash bit -1))) - (i 0 (index+ i 1))) - ((zerop bit) - (incf-internal-timestamp server-state)) - (declare (type gcontext-state server-state) - (type gcmask bit) - (type array-index i)) - (when (oddp bit) - (setf (svref server-state i) nil)))))) - -(defun create-gcontext (&rest options &key (drawable (required-arg drawable)) - function plane-mask foreground background - line-width line-style cap-style join-style fill-style fill-rule - arc-mode tile stipple ts-x ts-y font subwindow-mode - exposures clip-x clip-y clip-mask clip-ordering - dash-offset dashes - (cache-p t) - &allow-other-keys) - ;; Only non-nil components are passed on in the request, but for effective caching - ;; assumptions have to be made about what the actual protocol defaults are. For - ;; all gcontext components, a value of nil causes the default gcontext value to be - ;; used. For clip-mask, this implies that an empty rect-seq cannot be represented - ;; as a list. Note: use of stringable as font will cause an implicit open-font. - ;; Note: papers over protocol SetClipRectangles and SetDashes special cases. If - ;; cache-p is true, then gcontext state is cached locally, and changing a gcontext - ;; component will have no effect unless the new value differs from the cached - ;; value. Component changes (setfs and with-gcontext) are always deferred - ;; regardless of the cache mode, and sent over the protocol only when required by a - ;; local operation or by an explicit call to force-gcontext-changes. - (declare (type drawable drawable) ; Required to be non-null - (type (or null boole-constant) function) - (type (or null pixel) plane-mask foreground background) - (type (or null card16) line-width dash-offset) - (type (or null int16) ts-x ts-y clip-x clip-y) - (type (or null (member :solid :dash :double-dash)) line-style) - (type (or null (member :not-last :butt :round :projecting)) cap-style) - (type (or null (member :miter :round :bevel)) join-style) - (type (or null (member :solid :tiled :opaque-stippled :stippled)) fill-style) - (type (or null (member :even-odd :winding)) fill-rule) - (type (or null (member :chord :pie-slice)) arc-mode) - (type (or null pixmap) tile stipple) - (type (or null fontable) font) - (type (or null (member :clip-by-children :include-inferiors)) subwindow-mode) - (type (or null (member :on :off)) exposures) - (type (or null (member :none) pixmap rect-seq) clip-mask) - (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering) - (type (or null card8 sequence) dashes) - (dynamic-extent options) - (type generalized-boolean cache-p)) - (declare (clx-values gcontext)) - (let* ((display (drawable-display drawable)) - (gcontext (make-gcontext :display display :drawable drawable :cache-p cache-p)) - (local-state (gcontext-local-state gcontext)) - (server-state (gcontext-server-state gcontext)) - (gcontextid (allocate-resource-id display gcontext 'gcontext))) - (declare (type display display) - (type gcontext gcontext) - (type resource-id gcontextid) - (type gcontext-state local-state server-state)) - (setf (gcontext-id gcontext) gcontextid) - - (unless function (setf (gcontext-function gcontext) boole-1)) - ;; using the depth of the drawable would be better, but ... - (unless plane-mask (setf (gcontext-plane-mask gcontext) #xffffffff)) - (unless foreground (setf (gcontext-foreground gcontext) 0)) - (unless background (setf (gcontext-background gcontext) 1)) - (unless line-width (setf (gcontext-line-width gcontext) 0)) - (unless line-style (setf (gcontext-line-style gcontext) :solid)) - (unless cap-style (setf (gcontext-cap-style gcontext) :butt)) - (unless join-style (setf (gcontext-join-style gcontext) :miter)) - (unless fill-style (setf (gcontext-fill-style gcontext) :solid)) - (unless fill-rule (setf (gcontext-fill-rule gcontext) :even-odd)) - (unless arc-mode (setf (gcontext-arc-mode gcontext) :pie-slice)) - (unless ts-x (setf (gcontext-ts-x gcontext) 0)) - (unless ts-y (setf (gcontext-ts-y gcontext) 0)) - (unless subwindow-mode (setf (gcontext-subwindow-mode gcontext) - :clip-by-children)) - (unless exposures (setf (gcontext-exposures gcontext) :on)) - (unless clip-mask (setf (gcontext-clip-mask gcontext) :none)) - (unless clip-x (setf (gcontext-clip-x gcontext) 0)) - (unless clip-y (setf (gcontext-clip-y gcontext) 0)) - (unless dashes (setf (gcontext-dashes gcontext) 4)) - (unless dash-offset (setf (gcontext-dash-offset gcontext) 0)) - ;; a bit kludgy, but ... - (replace server-state local-state) - - (when function (setf (gcontext-function gcontext) function)) - (when plane-mask (setf (gcontext-plane-mask gcontext) plane-mask)) - (when foreground (setf (gcontext-foreground gcontext) foreground)) - (when background (setf (gcontext-background gcontext) background)) - (when line-width (setf (gcontext-line-width gcontext) line-width)) - (when line-style (setf (gcontext-line-style gcontext) line-style)) - (when cap-style (setf (gcontext-cap-style gcontext) cap-style)) - (when join-style (setf (gcontext-join-style gcontext) join-style)) - (when fill-style (setf (gcontext-fill-style gcontext) fill-style)) - (when fill-rule (setf (gcontext-fill-rule gcontext) fill-rule)) - (when arc-mode (setf (gcontext-arc-mode gcontext) arc-mode)) - (when tile (setf (gcontext-tile gcontext) tile)) - (when stipple (setf (gcontext-stipple gcontext) stipple)) - (when ts-x (setf (gcontext-ts-x gcontext) ts-x)) - (when ts-y (setf (gcontext-ts-y gcontext) ts-y)) - (when font (setf (gcontext-font gcontext) font)) - (when subwindow-mode (setf (gcontext-subwindow-mode gcontext) subwindow-mode)) - (when exposures (setf (gcontext-exposures gcontext) exposures)) - (when clip-x (setf (gcontext-clip-x gcontext) clip-x)) - (when clip-y (setf (gcontext-clip-y gcontext) clip-y)) - (when clip-mask (setf (gcontext-clip-mask gcontext clip-ordering) clip-mask)) - (when dash-offset (setf (gcontext-dash-offset gcontext) dash-offset)) - (when dashes (setf (gcontext-dashes gcontext) dashes)) - - (setf (gcontext-internal-timestamp server-state) 1) - (setf (gcontext-internal-timestamp local-state) - ;; SetClipRectangles or SetDashes request need to be sent? - (if (or (gcontext-internal-clip local-state) - (gcontext-internal-dash local-state)) - ;; Yes, mark local state "modified" to ensure - ;; force-gcontext-changes will occur. - 0 - ;; No, mark local state "unmodified" - 1)) - - (with-buffer-request (display +x-creategc+) - (resource-id gcontextid) - (drawable drawable) - (progn (do* ((i 0 (index+ i 1)) - (bit 1 (the xgcmask (ash bit 1))) - (nbyte 16) - (mask 0) - (local (svref local-state i) (svref local-state i))) - ((index>= i +gcontext-fast-change-length+) - (card29-put 12 mask) - (card16-put 2 (index-ash nbyte -2)) - (index-incf (buffer-boffset display) nbyte)) - (declare (type array-index i nbyte) - (type xgcmask bit) - (type gcmask mask) - (type (or null card32) local)) - (unless (eql local (the (or null card32) (svref server-state i))) - (setf (svref server-state i) local) - (card32-put nbyte local) - (setq mask (the gcmask (logior mask bit))) - (index-incf nbyte 4))))) - - ;; Initialize extensions - (do ((extensions *gcontext-extensions* (cdr extensions)) - (i *gcontext-data-length* (index+ i 1))) - ((endp extensions)) - (declare (type list extensions) - (type array-index i)) - (setf (svref server-state i) - (setf (svref local-state i) - (gcontext-extension-default (car extensions))))) - - ;; Set extension values - (do* ((option-list options (cddr option-list)) - (option (car option-list) (car option-list)) - (extension)) - ((endp option-list)) - (declare (type list option-list)) - (cond ((getf *gcontext-indexes* option)) ; Gcontext field - ((member option '(:drawable :clip-ordering :cache-p))) ; Optional parameter - ((setq extension (find option *gcontext-extensions* - :key #'gcontext-extension-name)) - (funcall (gcontext-extension-set-function extension) - gcontext (second option-list))) - (t (x-type-error option 'gcontext-key)))) - gcontext)) - -(defun copy-gcontext-components (src dst &rest keys) - (declare (type gcontext src dst) - (dynamic-extent keys)) - ;; you might ask why this isn't just a bunch of - ;; (setf (gcontext- dst) (gcontext- src)) - ;; the answer is that you can do that yourself if you want, what we are - ;; providing here is access to the protocol request, which will generally - ;; be more efficient (particularly for things like clip and dash lists). - (when keys - (let ((display (gcontext-display src)) - (mask 0)) - (declare (type xgcmask mask)) - (with-display (display) - (force-gcontext-changes-internal src) - (force-gcontext-changes-internal dst) - - ;; collect entire mask and handle extensions - (dolist (key keys) - (let ((i (getf *gcontext-indexes* key))) - (declare (type (or null array-index) i)) - (if i - (setq mask (the xgcmask (logior mask - (the xgcmask (svref *gcontext-masks* i))))) - (multiple-value-bind (extension index) - (find key *gcontext-extensions* :key #'gcontext-extension-name) - (if extension - (funcall (gcontext-extension-copy-function extension) - src dst (svref (gcontext-local-state src) - (index+ index *gcontext-data-length*))) - (x-type-error key 'gcontext-key)))))) - - (when (plusp mask) - (do ((src-server-state (gcontext-server-state src)) - (dst-server-state (gcontext-server-state dst)) - (dst-local-state (gcontext-local-state dst)) - (bit mask (the xgcmask (ash bit -1))) - (i 0 (index+ i 1))) - ((zerop bit) - (incf-internal-timestamp dst-server-state) - (setf (gcontext-internal-timestamp dst-local-state) 0)) - (declare (type gcontext-state src-server-state dst-server-state dst-local-state) - (type xgcmask bit) - (type array-index i)) - (when (oddp bit) - (setf (svref dst-local-state i) - (setf (svref dst-server-state i) (svref src-server-state i))))) - (with-buffer-request (display +x-copygc+) - (gcontext src dst) - (card29 (xgcmask->gcmask mask)))))))) - -(defun copy-gcontext (src dst) - (declare (type gcontext src dst)) - ;; Copies all components. - (apply #'copy-gcontext-components src dst *gcontext-components*) - (do ((extensions *gcontext-extensions* (cdr extensions)) - (i *gcontext-data-length* (index+ i 1))) - ((endp extensions)) - (funcall (gcontext-extension-copy-function (car extensions)) - src dst (svref (gcontext-local-state src) i)))) - -(defun free-gcontext (gcontext) - (declare (type gcontext gcontext)) - (let ((display (gcontext-display gcontext))) - (with-buffer-request (display +x-freegc+) - (gcontext gcontext)) - (deallocate-resource-id display (gcontext-id gcontext) 'gcontext) - (deallocate-gcontext-state (gcontext-server-state gcontext)) - (deallocate-gcontext-state (gcontext-local-state gcontext)) - nil)) - -(defmacro define-gcontext-accessor (name &key default set-function copy-function) - ;; This will define a new gcontext accessor called NAME. - ;; Defines the gcontext-NAME accessor function and its defsetf. - ;; Gcontext's will cache DEFAULT-VALUE and the last value SETF'ed when - ;; gcontext-cache-p is true. The NAME keyword will be allowed in - ;; CREATE-GCONTEXT, WITH-GCONTEXT, and COPY-GCONTEXT-COMPONENTS. - ;; SET-FUNCTION will be called with parameters (GCONTEXT NEW-VALUE) - ;; from create-gcontext, and force-gcontext-changes. - ;; COPY-FUNCTION will be called with parameters (src-gc dst-gc src-value) - ;; from copy-gcontext and copy-gcontext-components. - ;; The copy-function defaults to: - ;; (lambda (ignore dst-gc value) - ;; (if value - ;; (,set-function dst-gc value) - ;; (error "Can't copy unknown GContext component ~a" ',name))) - (declare (type symbol name) - (type t default) - (type symbol set-function) ;; required - (type symbol copy-function)) - (let* ((gc-name (intern (concatenate 'string - (string 'gcontext-) - (string name)))) ;; in current package - (key-name (kintern name)) - (setfer (xintern "Set-" gc-name)) - (internal-set-function (xintern "Internal-Set-" gc-name)) - (internal-copy-function (xintern "Internal-Copy-" gc-name)) - (internal-state-index (xintern "Internal-" gc-name "-State-Index"))) - (unless copy-function - (setq copy-function - `(lambda (src-gc dst-gc value) - (declare (ignore src-gc)) - (if value - (,set-function dst-gc value) - (error "Can't copy unknown GContext component ~a" ',name))))) - `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter ,internal-state-index - (add-gcontext-extension ',key-name ,default ',internal-set-function - ',internal-copy-function)) - ) ;; end eval-when - (defun ,gc-name (gcontext) - (svref (gcontext-local-state gcontext) ,internal-state-index)) - (defun ,setfer (gcontext new-value) - (let ((local-state (gcontext-local-state gcontext))) - (setf (gcontext-internal-timestamp local-state) 0) - (setf (svref local-state ,internal-state-index) new-value))) - (defsetf ,gc-name ,setfer) - (defun ,internal-set-function (gcontext new-value) - (,set-function gcontext new-value) - (setf (svref (gcontext-server-state gcontext) ,internal-state-index) - (setf (svref (gcontext-local-state gcontext) ,internal-state-index) - new-value))) - (defun ,internal-copy-function (src-gc dst-gc new-value) - (,copy-function src-gc dst-gc new-value) - (setf (svref (gcontext-local-state dst-gc) ,internal-state-index) - (setf (svref (gcontext-server-state dst-gc) ,internal-state-index) - new-value))) - ',name))) - -;; GContext extension fields are treated in much the same way as normal GContext -;; components. The current value is stored in a slot of the gcontext-local-state, -;; and the value known to the server is in a slot of the gcontext-server-state. -;; The slot-number is defined by its position in the *gcontext-extensions* list. -;; The value of the special variable |Internal-GCONTEXT-name| (where "name" is -;; the extension component name) reflects this position. The position within -;; *gcontext-extensions* and the value of the special value are determined at -;; LOAD time to facilitate merging of seperately compiled extension files. - -(defun add-gcontext-extension (name default-value set-function copy-function) - (declare (type symbol name) - (type t default-value) - (type (function (gcontext t) t) set-function) - (type (function (gcontext gcontext t) t) copy-function)) - (let ((number (or (position name *gcontext-extensions* :key #'gcontext-extension-name) - (prog1 (length *gcontext-extensions*) - (push nil *gcontext-extensions*))))) - (setf (nth number *gcontext-extensions*) - (make-gcontext-extension :name name - :default default-value - :set-function set-function - :copy-function copy-function)) - (+ number *gcontext-data-length*))) diff --git a/src/eclx/graphics.lisp b/src/eclx/graphics.lisp deleted file mode 100644 index 7f7047ae8..000000000 --- a/src/eclx/graphics.lisp +++ /dev/null @@ -1,450 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; CLX drawing requests - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; -#+cmu -(ext:file-comment - "$Header$") - -(in-package :xlib) - -(defvar *inhibit-appending* nil) - -(defun draw-point (drawable gcontext x y) - ;; Should be clever about appending to existing buffered protocol request. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y)) - (let ((display (drawable-display drawable))) - (declare (type display display)) - (with-display (display) - (force-gcontext-changes-internal gcontext) - (with-buffer-output (display :length +requestsize+) - (let* ((last-request-byte (display-last-request display)) - (current-boffset buffer-boffset)) - ;; To append or not append, that is the question - (if (and (not *inhibit-appending*) - last-request-byte - ;; Same request? - (= (aref-card8 buffer-bbuf last-request-byte) +x-polypoint+) - (progn ;; Set buffer pointers to last request - (set-buffer-offset last-request-byte) - ;; same drawable and gcontext? - (or (compare-request (4) - (data 0) - (drawable drawable) - (gcontext gcontext)) - (progn ;; If failed, reset buffer pointers - (set-buffer-offset current-boffset) - nil)))) - ;; Append request - (progn - ;; Set new request length - (card16-put 2 (index+ 1 (index-ash (index- current-boffset last-request-byte) - -2))) - (set-buffer-offset current-boffset) - (put-items (0) ; Insert new point - (int16 x y)) - (setf (display-boffset display) (index+ buffer-boffset 4))) - ;; New Request - (progn - (put-items (4) - (code +x-polypoint+) - (data 0) ;; Relative-p false - (length 4) - (drawable drawable) - (gcontext gcontext) - (int16 x y)) - (buffer-new-request-number display) - (setf (buffer-last-request display) buffer-boffset) - (setf (display-boffset display) (index+ buffer-boffset 16))))))) - (display-invoke-after-function display))) - - -(defun draw-points (drawable gcontext points &optional relative-p) - (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence points) ;(repeat-seq (integer x) (integer y)) - (type generalized-boolean relative-p)) - (with-buffer-request ((drawable-display drawable) +x-polypoint+ :gc-force gcontext) - ((data boolean) relative-p) - (drawable drawable) - (gcontext gcontext) - ((sequence :format int16) points))) - -(defun draw-line (drawable gcontext x1 y1 x2 y2 &optional relative-p) - ;; Should be clever about appending to existing buffered protocol request. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x1 y1 x2 y2) - (type generalized-boolean relative-p)) - (let ((display (drawable-display drawable))) - (declare (type display display)) - (when relative-p - (incf x2 x1) - (incf y2 y1)) - (with-display (display) - (force-gcontext-changes-internal gcontext) - (with-buffer-output (display :length +requestsize+) - (let* ((last-request-byte (display-last-request display)) - (current-boffset buffer-boffset)) - ;; To append or not append, that is the question - (if (and (not *inhibit-appending*) - last-request-byte - ;; Same request? - (= (aref-card8 buffer-bbuf last-request-byte) +x-polysegment+) - (progn ;; Set buffer pointers to last request - (set-buffer-offset last-request-byte) - ;; same drawable and gcontext? - (or (compare-request (4) - (drawable drawable) - (gcontext gcontext)) - (progn ;; If failed, reset buffer pointers - (set-buffer-offset current-boffset) - nil)))) - ;; Append request - (progn - ;; Set new request length - (card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte) - -2))) - (set-buffer-offset current-boffset) - (put-items (0) ; Insert new point - (int16 x1 y1 x2 y2)) - (setf (display-boffset display) (index+ buffer-boffset 8))) - ;; New Request - (progn - (put-items (4) - (code +x-polysegment+) - (length 5) - (drawable drawable) - (gcontext gcontext) - (int16 x1 y1 x2 y2)) - (buffer-new-request-number display) - (setf (buffer-last-request display) buffer-boffset) - (setf (display-boffset display) (index+ buffer-boffset 20))))))) - (display-invoke-after-function display))) - -(defun draw-lines (drawable gcontext points &key relative-p fill-p (shape :complex)) - (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence points) ;(repeat-seq (integer x) (integer y)) - (type generalized-boolean relative-p fill-p) - (type (member :complex :non-convex :convex) shape)) - (if fill-p - (fill-polygon drawable gcontext points relative-p shape) - (with-buffer-request ((drawable-display drawable) +x-polyline+ :gc-force gcontext) - ((data boolean) relative-p) - (drawable drawable) - (gcontext gcontext) - ((sequence :format int16) points)))) - -;; Internal function called from DRAW-LINES -(defun fill-polygon (drawable gcontext points relative-p shape) - ;; This is clever about appending to previous requests. Should it be? - (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence points) ;(repeat-seq (integer x) (integer y)) - (type generalized-boolean relative-p) - (type (member :complex :non-convex :convex) shape)) - (with-buffer-request ((drawable-display drawable) +x-fillpoly+ :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - ((member8 :complex :non-convex :convex) shape) - (boolean relative-p) - ((sequence :format int16) points))) - -(defun draw-segments (drawable gcontext segments) - (declare (type drawable drawable) - (type gcontext gcontext) - ;; (repeat-seq (integer x1) (integer y1) (integer x2) (integer y2))) - (type sequence segments)) - (with-buffer-request ((drawable-display drawable) +x-polysegment+ :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - ((sequence :format int16) segments))) - -(defun draw-rectangle (drawable gcontext x y width height &optional fill-p) - ;; Should be clever about appending to existing buffered protocol request. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type card16 width height) - (type generalized-boolean fill-p)) - (let ((display (drawable-display drawable)) - (request (if fill-p +x-polyfillrectangle+ +x-polyrectangle+))) - (declare (type display display) - (type card16 request)) - (with-display (display) - (force-gcontext-changes-internal gcontext) - (with-buffer-output (display :length +requestsize+) - (let* ((last-request-byte (display-last-request display)) - (current-boffset buffer-boffset)) - ;; To append or not append, that is the question - (if (and (not *inhibit-appending*) - last-request-byte - ;; Same request? - (= (aref-card8 buffer-bbuf last-request-byte) request) - (progn ;; Set buffer pointers to last request - (set-buffer-offset last-request-byte) - ;; same drawable and gcontext? - (or (compare-request (4) - (drawable drawable) - (gcontext gcontext)) - (progn ;; If failed, reset buffer pointers - (set-buffer-offset current-boffset) - nil)))) - ;; Append request - (progn - ;; Set new request length - (card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte) - -2))) - (set-buffer-offset current-boffset) - (put-items (0) ; Insert new point - (int16 x y) - (card16 width height)) - (setf (display-boffset display) (index+ buffer-boffset 8))) - ;; New Request - (progn - (put-items (4) - (code request) - (length 5) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (card16 width height)) - (buffer-new-request-number display) - (setf (buffer-last-request display) buffer-boffset) - (setf (display-boffset display) (index+ buffer-boffset 20))))))) - (display-invoke-after-function display))) - -(defun draw-rectangles (drawable gcontext rectangles &optional fill-p) - (declare (type drawable drawable) - (type gcontext gcontext) - ;; (repeat-seq (integer x) (integer y) (integer width) (integer height))) - (type sequence rectangles) - (type generalized-boolean fill-p)) - (with-buffer-request ((drawable-display drawable) - (if fill-p +x-polyfillrectangle+ +x-polyrectangle+) - :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - ((sequence :format int16) rectangles))) - -(defun draw-arc (drawable gcontext x y width height angle1 angle2 &optional fill-p) - ;; Should be clever about appending to existing buffered protocol request. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type card16 width height) - (type angle angle1 angle2) - (type generalized-boolean fill-p)) - (let ((display (drawable-display drawable)) - (request (if fill-p +x-polyfillarc+ +x-polyarc+))) - (declare (type display display) - (type card16 request)) - (with-display (display) - (force-gcontext-changes-internal gcontext) - (with-buffer-output (display :length +requestsize+) - (let* ((last-request-byte (display-last-request display)) - (current-boffset buffer-boffset)) - ;; To append or not append, that is the question - (if (and (not *inhibit-appending*) - last-request-byte - ;; Same request? - (= (aref-card8 buffer-bbuf last-request-byte) request) - (progn ;; Set buffer pointers to last request - (set-buffer-offset last-request-byte) - ;; same drawable and gcontext? - (or (compare-request (4) - (drawable drawable) - (gcontext gcontext)) - (progn ;; If failed, reset buffer pointers - (set-buffer-offset current-boffset) - nil)))) - ;; Append request - (progn - ;; Set new request length - (card16-put 2 (index+ 3 (index-ash (index- current-boffset last-request-byte) - -2))) - (set-buffer-offset current-boffset) - (put-items (0) ; Insert new point - (int16 x y) - (card16 width height) - (angle angle1 angle2)) - (setf (display-boffset display) (index+ buffer-boffset 12))) - ;; New Request - (progn - (put-items (4) - (code request) - (length 6) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (card16 width height) - (angle angle1 angle2)) - (buffer-new-request-number display) - (setf (buffer-last-request display) buffer-boffset) - (setf (display-boffset display) (index+ buffer-boffset 24))))))) - (display-invoke-after-function display))) - -(defun draw-arcs-list (drawable gcontext arcs &optional fill-p) - (declare (type drawable drawable) - (type gcontext gcontext) - (type list arcs) - (type generalized-boolean fill-p)) - (let* ((display (drawable-display drawable)) - (limit (index- (buffer-size display) 12)) - (length (length arcs)) - (request (if fill-p +x-polyfillarc+ +x-polyarc+))) - (with-buffer-request ((drawable-display drawable) request :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - (progn - (card16-put 2 (index+ (index-ash length -1) 3)) ; Set request length (in words) - (set-buffer-offset (index+ buffer-boffset 12)) ; Position to start of data - (do ((arc arcs)) - ((endp arc) - (setf (buffer-boffset display) buffer-boffset)) - ;; Make sure there's room - (when (index>= buffer-boffset limit) - (setf (buffer-boffset display) buffer-boffset) - (buffer-flush display) - (set-buffer-offset (buffer-boffset display))) - (int16-put 0 (pop arc)) - (int16-put 2 (pop arc)) - (card16-put 4 (pop arc)) - (card16-put 6 (pop arc)) - (angle-put 8 (pop arc)) - (angle-put 10 (pop arc)) - (set-buffer-offset (index+ buffer-boffset 12))))))) - -(defun draw-arcs-vector (drawable gcontext arcs &optional fill-p) - (declare (type drawable drawable) - (type gcontext gcontext) - (type vector arcs) - (type generalized-boolean fill-p)) - (let* ((display (drawable-display drawable)) - (limit (index- (buffer-size display) 12)) - (length (length arcs)) - (request (if fill-p +x-polyfillarc+ +x-polyarc+))) - (with-buffer-request ((drawable-display drawable) request :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - (progn - (card16-put 2 (index+ (index-ash length -1) 3)) ; Set request length (in words) - (set-buffer-offset (index+ buffer-boffset 12)) ; Position to start of data - (do ((n 0 (index+ n 6)) - (length (length arcs))) - ((index>= n length) - (setf (buffer-boffset display) buffer-boffset)) - ;; Make sure there's room - (when (index>= buffer-boffset limit) - (setf (buffer-boffset display) buffer-boffset) - (buffer-flush display) - (set-buffer-offset (buffer-boffset display))) - (int16-put 0 (aref arcs (index+ n 0))) - (int16-put 2 (aref arcs (index+ n 1))) - (card16-put 4 (aref arcs (index+ n 2))) - (card16-put 6 (aref arcs (index+ n 3))) - (angle-put 8 (aref arcs (index+ n 4))) - (angle-put 10 (aref arcs (index+ n 5))) - (set-buffer-offset (index+ buffer-boffset 12))))))) - -(defun draw-arcs (drawable gcontext arcs &optional fill-p) - (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence arcs) - (type generalized-boolean fill-p)) - (etypecase arcs - (list (draw-arcs-list drawable gcontext arcs fill-p)) - (vector (draw-arcs-vector drawable gcontext arcs fill-p)))) - -;; The following image routines are bare minimum. It may be useful to define -;; some form of "image" object to hide representation details and format -;; conversions. It also may be useful to provide stream-oriented interfaces -;; for reading and writing the data. - -(defun put-raw-image (drawable gcontext data &key - (start 0) - (depth (required-arg depth)) - (x (required-arg x)) - (y (required-arg y)) - (width (required-arg width)) - (height (required-arg height)) - (left-pad 0) - (format (required-arg format))) - ;; Data must be a sequence of 8-bit quantities, already in the appropriate format - ;; for transmission; the caller is responsible for all byte and bit swapping and - ;; compaction. Start is the starting index in data; the end is computed from the - ;; other arguments. - (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence data) ; Sequence of integers - (type array-index start) - (type card8 depth left-pad) ;; required - (type int16 x y) ;; required - (type card16 width height) ;; required - (type (member :bitmap :xy-pixmap :z-pixmap) format)) - (with-buffer-request ((drawable-display drawable) +x-putimage+ :gc-force gcontext) - ((data (member :bitmap :xy-pixmap :z-pixmap)) format) - (drawable drawable) - (gcontext gcontext) - (card16 width height) - (int16 x y) - (card8 left-pad depth) - (pad16 nil) - ((sequence :format card8 :start start) data))) - -(defun get-raw-image (drawable &key - data - (start 0) - (x (required-arg x)) - (y (required-arg y)) - (width (required-arg width)) - (height (required-arg height)) - (plane-mask #xffffffff) - (format (required-arg format)) - (result-type '(vector card8))) - ;; If data is given, it is modified in place (and returned), otherwise a new sequence - ;; is created and returned, with a size computed from the other arguments and the - ;; returned depth. The sequence is filled with 8-bit quantities, in transmission - ;; format; the caller is responsible for any byte and bit swapping and compaction - ;; required for further local use. - (declare (type drawable drawable) - (type (or null sequence) data) ;; sequence of integers - (type int16 x y) ;; required - (type card16 width height) ;; required - (type array-index start) - (type pixel plane-mask) - (type (member :xy-pixmap :z-pixmap) format)) - (declare (clx-values (clx-sequence integer) depth visual-info)) - (let ((display (drawable-display drawable))) - (with-buffer-request-and-reply (display +x-getimage+ nil :sizes (8 32)) - (((data (member error :xy-pixmap :z-pixmap)) format) - (drawable drawable) - (int16 x y) - (card16 width height) - (card32 plane-mask)) - (let ((depth (card8-get 1)) - (length (* 4 (card32-get 4))) - (visual (resource-id-get 8))) - (values (sequence-get :result-type result-type :format card8 - :length length :start start :data data - :index +replysize+) - depth - (visual-info display visual)))))) diff --git a/src/eclx/image.lisp b/src/eclx/image.lisp deleted file mode 100644 index 1eef8073e..000000000 --- a/src/eclx/image.lisp +++ /dev/null @@ -1,2673 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;;; CLX Image functions - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; -#+cmu -(ext:file-comment - "$Header$") - -(in-package :xlib) - -(defmacro with-image-data-buffer ((buffer size) &body body) - (declare (indentation 0 4 1 1)) - `(let ((.reply-buffer. (allocate-reply-buffer ,size))) - (declare (type reply-buffer .reply-buffer.)) - (unwind-protect - (let ((,buffer (reply-ibuf8 .reply-buffer.))) - (declare (type buffer-bytes ,buffer)) - (with-vector (,buffer buffer-bytes) - ,@body)) - (deallocate-reply-buffer .reply-buffer.)))) - -(def-clx-class (image (:constructor nil) (:copier nil) (:predicate nil)) - ;; Public structure - (width 0 :type card16 :read-only t) - (height 0 :type card16 :read-only t) - (depth 1 :type card8 :read-only t) - (plist nil :type list)) - -;; Image-Plist accessors: -(defmacro image-name (image) `(getf (image-plist ,image) :name)) -(defmacro image-x-hot (image) `(getf (image-plist ,image) :x-hot)) -(defmacro image-y-hot (image) `(getf (image-plist ,image) :y-hot)) -(defmacro image-red-mask (image) `(getf (image-plist ,image) :red-mask)) -(defmacro image-blue-mask (image) `(getf (image-plist ,image) :blue-mask)) -(defmacro image-green-mask (image) `(getf (image-plist ,image) :green-mask)) - -(defun print-image (image stream depth) - (declare (type image image) - (ignore depth)) - (print-unreadable-object (image stream :type t) - (when (image-name image) - (write-string (string (image-name image)) stream) - (write-string " " stream)) - (prin1 (image-width image) stream) - (write-string "x" stream) - (prin1 (image-height image) stream) - (write-string "x" stream) - (prin1 (image-depth image) stream))) - -(defparameter *empty-data-x* '#.(make-sequence '(array card8 (*)) 0)) - -(defparameter *empty-data-z* - '#.(make-array '(0 0) :element-type 'pixarray-1-element-type)) - -(def-clx-class (image-x (:include image) (:copier nil) - (:print-function print-image)) - ;; Use this format for shoveling image data - ;; Private structure. Accessors for these NOT exported. - (format :z-pixmap :type (member :bitmap :xy-pixmap :z-pixmap)) - (bytes-per-line 0 :type card16) - (bits-per-pixel 1 :type (member 1 4 8 16 24 32)) - (bit-lsb-first-p +image-bit-lsb-first-p+ :type generalized-boolean) ; Bit order - (byte-lsb-first-p +image-byte-lsb-first-p+ :type generalized-boolean) ; Byte order - (data *empty-data-x* :type (array card8 (*))) ; row-major - (unit +image-unit+ :type (member 8 16 32)) ; Bitmap unit - (pad +image-pad+ :type (member 8 16 32)) ; Scanline pad - (left-pad 0 :type card8)) ; Left pad - -(def-clx-class (image-xy (:include image) (:copier nil) - (:print-function print-image)) - ;; Public structure - ;; Use this format for image processing - (bitmap-list nil :type list)) ;; list of bitmaps - -(def-clx-class (image-z (:include image) (:copier nil) - (:print-function print-image)) - ;; Public structure - ;; Use this format for image processing - (bits-per-pixel 1 :type (member 1 4 8 16 24 32)) - (pixarray *empty-data-z* :type pixarray)) - -(defun create-image (&key width height depth - (data (required-arg data)) - plist name x-hot y-hot - red-mask blue-mask green-mask - bits-per-pixel format bytes-per-line - (byte-lsb-first-p - #+clx-little-endian t - #-clx-little-endian nil) - (bit-lsb-first-p - #+clx-little-endian t - #-clx-little-endian nil) - unit pad left-pad) - ;; Returns an image-x image-xy or image-z structure, depending on the - ;; type of the :DATA parameter. - (declare - (type (or null card16) width height) ; Required - (type (or null card8) depth) ; Defualts to 1 - (type (or buffer-bytes ; Returns image-x - list ; Returns image-xy - pixarray) data) ; Returns image-z - (type list plist) - (type (or null stringable) name) - (type (or null card16) x-hot y-hot) - (type (or null pixel) red-mask blue-mask green-mask) - (type (or null (member 1 4 8 16 24 32)) bits-per-pixel) - - ;; The following parameters are ignored for image-xy and image-z: - (type (or null (member :bitmap :xy-pixmap :z-pixmap)) - format) ; defaults to :z-pixmap - (type (or null card16) bytes-per-line) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) - (type (or null (member 8 16 32)) unit pad) - (type (or null card8) left-pad)) - (declare (clx-values image)) - (let ((image - (etypecase data - (buffer-bytes ; image-x - (let ((data data)) - (declare (type buffer-bytes data)) - (unless depth (setq depth (or bits-per-pixel 1))) - (unless format - (setq format (if (= depth 1) :xy-pixmap :z-pixmap))) - (unless bits-per-pixel - (setq bits-per-pixel - (cond ((eq format :xy-pixmap) 1) - ((index> depth 24) 32) - ((index> depth 16) 24) - ((index> depth 8) 16) - ((index> depth 4) 8) - ((index> depth 1) 4) - (t 1)))) - (unless width (required-arg width)) - (unless height (required-arg height)) - (unless bytes-per-line - (let* ((pad (or pad 8)) - (bits-per-line (index* width bits-per-pixel)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line pad) pad))) - (declare (type array-index pad bits-per-line - padded-bits-per-line)) - (setq bytes-per-line (index-ceiling padded-bits-per-line 8)))) - (unless unit (setq unit +image-unit+)) - (unless pad - (setq pad - (dolist (pad '(32 16 8)) - (when (and (index<= pad +image-pad+) - (zerop - (index-mod - (index* bytes-per-line 8) pad))) - (return pad))))) - (unless left-pad (setq left-pad 0)) - (make-image-x - :width width :height height :depth depth :plist plist - :format format :data data - :bits-per-pixel bits-per-pixel - :bytes-per-line bytes-per-line - :byte-lsb-first-p byte-lsb-first-p - :bit-lsb-first-p bit-lsb-first-p - :unit unit :pad pad :left-pad left-pad))) - (list ; image-xy - (let ((data data)) - (declare (type list data)) - (unless depth (setq depth (length data))) - (when data - (unless width (setq width (array-dimension (car data) 1))) - (unless height (setq height (array-dimension (car data) 0)))) - (make-image-xy - :width width :height height :plist plist :depth depth - :bitmap-list data))) - (pixarray ; image-z - (let ((data data)) - (declare (type pixarray data)) - (unless width (setq width (array-dimension data 1))) - (unless height (setq height (array-dimension data 0))) - (unless bits-per-pixel - (setq bits-per-pixel - (etypecase data - (pixarray-32 32) - (pixarray-24 24) - (pixarray-16 16) - (pixarray-8 8) - (pixarray-4 4) - (pixarray-1 1))))) - (unless depth (setq depth bits-per-pixel)) - (make-image-z - :width width :height height :depth depth :plist plist - :bits-per-pixel bits-per-pixel :pixarray data))))) - (declare (type image image)) - (when name (setf (image-name image) name)) - (when x-hot (setf (image-x-hot image) x-hot)) - (when y-hot (setf (image-y-hot image) y-hot)) - (when red-mask (setf (image-red-mask image) red-mask)) - (when blue-mask (setf (image-blue-mask image) blue-mask)) - (when green-mask (setf (image-green-mask image) green-mask)) - image)) - -;;;----------------------------------------------------------------------------- -;;; Swapping stuff - -(defun image-noswap - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p) - (ignore lsb-first-p)) - #.(declare-buffun) - (if (index= srcinc destinc) - (buffer-replace - dest src destoff - (index+ destoff (index* srcinc (index1- height)) srclen) - srcoff) - (do* ((h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc)) - (destend (index+ deststart srclen) (index+ deststart srclen))) - ((index-zerop h)) - (declare (type array-index srcstart deststart destend) - (type card16 h)) - (buffer-replace dest src deststart destend srcstart)))) - -(defun image-swap-two-bytes - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (do ((length (index* (index-ceiling srclen 2) 2)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 2) - (if lsb-first-p - (setf (aref dest (index1+ (index+ deststart length))) - (the card8 (aref src (index+ srcstart length)))) - (setf (aref dest (index+ deststart length)) - (the card8 (aref src (index1+ (index+ srcstart length))))))) - (do ((i length (index- i 2)) - (srcidx srcstart (index+ srcidx 2)) - (destidx deststart (index+ destidx 2))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 (aref src (index1+ srcidx)))) - (setf (aref dest (index1+ destidx)) - (the card8 (aref src srcidx)))))))) - -(defun image-swap-three-bytes - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (do ((length (index* (index-ceiling srclen 3) 3)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 3) - (when (index= (index- srclen length) 2) - (setf (aref dest (index+ deststart length 1)) - (the card8 (aref src (index+ srcstart length 1))))) - (if lsb-first-p - (setf (aref dest (index+ deststart length 2)) - (the card8 (aref src (index+ srcstart length)))) - (setf (aref dest (index+ deststart length)) - (the card8 (aref src (index+ srcstart length 2)))))) - (do ((i length (index- i 3)) - (srcidx srcstart (index+ srcidx 3)) - (destidx deststart (index+ destidx 3))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 (aref src (index+ srcidx 2)))) - (setf (aref dest (index1+ destidx)) - (the card8 (aref src (index1+ srcidx)))) - (setf (aref dest (index+ destidx 2)) - (the card8 (aref src srcidx)))))))) - -(defun image-swap-four-bytes - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (do ((length (index* (index-ceiling srclen 4) 4)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 4) - (unless lsb-first-p - (setf (aref dest (index+ deststart length)) - (the card8 (aref src (index+ srcstart length 3))))) - (when (if lsb-first-p - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 1)) - (the card8 (aref src (index+ srcstart length 2))))) - (when (if (null lsb-first-p) - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 2)) - (the card8 (aref src (index+ srcstart length 1))))) - (when lsb-first-p - (setf (aref dest (index+ deststart length 3)) - (the card8 (aref src (index+ srcstart length)))))) - (do ((i length (index- i 4)) - (srcidx srcstart (index+ srcidx 4)) - (destidx deststart (index+ destidx 4))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 (aref src (index+ srcidx 3)))) - (setf (aref dest (index1+ destidx)) - (the card8 (aref src (index+ srcidx 2)))) - (setf (aref dest (index+ destidx 2)) - (the card8 (aref src (index1+ srcidx)))) - (setf (aref dest (index+ destidx 3)) - (the card8 (aref src srcidx)))))))) - -(defun image-swap-words - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (do ((length (index* (index-ceiling srclen 4) 4)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 4) - (unless lsb-first-p - (setf (aref dest (index+ deststart length 1)) - (the card8 (aref src (index+ srcstart length 3))))) - (when (if lsb-first-p - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length)) - (the card8 (aref src (index+ srcstart length 2))))) - (when (if (null lsb-first-p) - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 3)) - (the card8 (aref src (index+ srcstart length 1))))) - (when lsb-first-p - (setf (aref dest (index+ deststart length 2)) - (the card8 (aref src (index+ srcstart length)))))) - (do ((i length (index- i 4)) - (srcidx srcstart (index+ srcidx 4)) - (destidx deststart (index+ destidx 4))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 (aref src (index+ srcidx 2)))) - (setf (aref dest (index1+ destidx)) - (the card8 (aref src (index+ srcidx 3)))) - (setf (aref dest (index+ destidx 2)) - (the card8 (aref src srcidx))) - (setf (aref dest (index+ destidx 3)) - (the card8 (aref src (index1+ srcidx))))))))) - -(defun image-swap-nibbles - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p) - (ignore lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (do ((h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index srcstart deststart) - (type card16 h)) - (do ((i srclen (index1- i)) - (srcidx srcstart (index1+ srcidx)) - (destidx deststart (index1+ destidx))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 - (let ((byte (aref src srcidx))) - (declare (type card8 byte)) - (dpb (the card4 (ldb (byte 4 0) byte)) - (byte 4 4) - (the card4 (ldb (byte 4 4) byte))))))))))) - -(defun image-swap-nibbles-left - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p) - (ignore lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (do ((h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index srcstart deststart) - (type card16 h)) - (do ((i srclen (index1- i)) - (srcidx srcstart (index1+ srcidx)) - (destidx deststart (index1+ destidx))) - ((index= i 1) - (setf (aref dest destidx) - (the card8 - (let ((byte1 (aref src srcidx))) - (declare (type card8 byte1)) - (dpb (the card4 (ldb (byte 4 0) byte1)) - (byte 4 4) - 0))))) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 - (let ((byte1 (aref src srcidx)) - (byte2 (aref src (index1+ srcidx)))) - (declare (type card8 byte1 byte2)) - (dpb (the card4 (ldb (byte 4 0) byte1)) - (byte 4 4) - (the card4 (ldb (byte 4 4) byte2))))))))))) - -(defparameter - *image-byte-reverse* - '#.(coerce - '#( - 0 128 64 192 32 160 96 224 16 144 80 208 48 176 112 240 - 8 136 72 200 40 168 104 232 24 152 88 216 56 184 120 248 - 4 132 68 196 36 164 100 228 20 148 84 212 52 180 116 244 - 12 140 76 204 44 172 108 236 28 156 92 220 60 188 124 252 - 2 130 66 194 34 162 98 226 18 146 82 210 50 178 114 242 - 10 138 74 202 42 170 106 234 26 154 90 218 58 186 122 250 - 6 134 70 198 38 166 102 230 22 150 86 214 54 182 118 246 - 14 142 78 206 46 174 110 238 30 158 94 222 62 190 126 254 - 1 129 65 193 33 161 97 225 17 145 81 209 49 177 113 241 - 9 137 73 201 41 169 105 233 25 153 89 217 57 185 121 249 - 5 133 69 197 37 165 101 229 21 149 85 213 53 181 117 245 - 13 141 77 205 45 173 109 237 29 157 93 221 61 189 125 253 - 3 131 67 195 35 163 99 227 19 147 83 211 51 179 115 243 - 11 139 75 203 43 171 107 235 27 155 91 219 59 187 123 251 - 7 135 71 199 39 167 103 231 23 151 87 215 55 183 119 247 - 15 143 79 207 47 175 111 239 31 159 95 223 63 191 127 255) - '(vector card8))) - -(defun image-swap-bits - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p) - (ignore lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (let ((byte-reverse *image-byte-reverse*)) - (with-vector (byte-reverse (simple-array card8 (256))) - (macrolet ((br (byte) - `(the card8 (aref byte-reverse (the card8 ,byte))))) - (do ((h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index srcstart deststart) - (type card16 h)) - (do ((i srclen (index1- i)) - (srcidx srcstart (index1+ srcidx)) - (destidx deststart (index1+ destidx))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) (br (aref src srcidx))))))))))) - -(defun image-swap-bits-and-two-bytes - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (let ((byte-reverse *image-byte-reverse*)) - (with-vector (byte-reverse (simple-array card8 (256))) - (macrolet ((br (byte) - `(the card8 (aref byte-reverse (the card8 ,byte))))) - (do ((length (index* (index-ceiling srclen 2) 2)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 2) - (if lsb-first-p - (setf (aref dest (index1+ (index+ deststart length))) - (br (aref src (index+ srcstart length)))) - (setf (aref dest (index+ deststart length)) - (br (aref src (index1+ (index+ srcstart length))))))) - (do ((i length (index- i 2)) - (srcidx srcstart (index+ srcidx 2)) - (destidx deststart (index+ destidx 2))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (br (aref src (index1+ srcidx)))) - (setf (aref dest (index1+ destidx)) - (br (aref src srcidx))))))))))) - -(defun image-swap-bits-and-four-bytes - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (let ((byte-reverse *image-byte-reverse*)) - (with-vector (byte-reverse (simple-array card8 (256))) - (macrolet ((br (byte) - `(the card8 (aref byte-reverse (the card8 ,byte))))) - (do ((length (index* (index-ceiling srclen 4) 4)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 4) - (unless lsb-first-p - (setf (aref dest (index+ deststart length)) - (br (aref src (index+ srcstart length 3))))) - (when (if lsb-first-p - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 1)) - (br (aref src (index+ srcstart length 2))))) - (when (if (null lsb-first-p) - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 2)) - (br (aref src (index+ srcstart length 1))))) - (when lsb-first-p - (setf (aref dest (index+ deststart length 3)) - (br (aref src (index+ srcstart length)))))) - (do ((i length (index- i 4)) - (srcidx srcstart (index+ srcidx 4)) - (destidx deststart (index+ destidx 4))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (br (aref src (index+ srcidx 3)))) - (setf (aref dest (index1+ destidx)) - (br (aref src (index+ srcidx 2)))) - (setf (aref dest (index+ destidx 2)) - (br (aref src (index1+ srcidx)))) - (setf (aref dest (index+ destidx 3)) - (br (aref src srcidx))))))))))) - -(defun image-swap-bits-and-words - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (let ((byte-reverse *image-byte-reverse*)) - (with-vector (byte-reverse (simple-array card8 (256))) - (macrolet ((br (byte) - `(the card8 (aref byte-reverse (the card8 ,byte))))) - (do ((length (index* (index-ceiling srclen 4) 4)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 4) - (unless lsb-first-p - (setf (aref dest (index+ deststart length 1)) - (br (aref src (index+ srcstart length 3))))) - (when (if lsb-first-p - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length)) - (br (aref src (index+ srcstart length 2))))) - (when (if (null lsb-first-p) - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 3)) - (br (aref src (index+ srcstart length 1))))) - (when lsb-first-p - (setf (aref dest (index+ deststart length 2)) - (br (aref src (index+ srcstart length)))))) - (do ((i length (index- i 4)) - (srcidx srcstart (index+ srcidx 4)) - (destidx deststart (index+ destidx 4))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (br (aref src (index+ srcidx 2)))) - (setf (aref dest (index1+ destidx)) - (br (aref src (index+ srcidx 3)))) - (setf (aref dest (index+ destidx 2)) - (br (aref src srcidx))) - (setf (aref dest (index+ destidx 3)) - (br (aref src (index1+ srcidx)))))))))))) - -;;; The following table gives the bit ordering within bytes (when accessed -;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to -;;; 31, where bit 0 should be leftmost on the display. For a given byte -;;; labelled A-B, A is for the most significant bit of the byte, and B is -;;; for the least significant bit. -;;; -;;; legend: -;;; 1 scanline-unit = 8 -;;; 2 scanline-unit = 16 -;;; 4 scanline-unit = 32 -;;; M byte-order = MostSignificant -;;; L byte-order = LeastSignificant -;;; m bit-order = MostSignificant -;;; l bit-order = LeastSignificant -;;; -;;; -;;; format ordering -;;; -;;; 1Mm 00-07 08-15 16-23 24-31 -;;; 2Mm 00-07 08-15 16-23 24-31 -;;; 4Mm 00-07 08-15 16-23 24-31 -;;; 1Ml 07-00 15-08 23-16 31-24 -;;; 2Ml 15-08 07-00 31-24 23-16 -;;; 4Ml 31-24 23-16 15-08 07-00 -;;; 1Lm 00-07 08-15 16-23 24-31 -;;; 2Lm 08-15 00-07 24-31 16-23 -;;; 4Lm 24-31 16-23 08-15 00-07 -;;; 1Ll 07-00 15-08 23-16 31-24 -;;; 2Ll 07-00 15-08 23-16 31-24 -;;; 4Ll 07-00 15-08 23-16 31-24 -;;; -;;; -;;; The following table gives the required conversion between any two -;;; formats. It is based strictly on the table above. If you believe one, -;;; you should believe the other. -;;; -;;; legend: -;;; n no changes -;;; s reverse 8-bit units within 16-bit units -;;; l reverse 8-bit units within 32-bit units -;;; w reverse 16-bit units within 32-bit units -;;; r reverse bits within 8-bit units -;;; sr s+R -;;; lr l+R -;;; wr w+R - -(defparameter - *image-swap-function* - '#.(make-array - '(12 12) :initial-contents - (let ((n 'image-noswap) - (s 'image-swap-two-bytes) - (l 'image-swap-four-bytes) - (w 'image-swap-words) - (r 'image-swap-bits) - (sr 'image-swap-bits-and-two-bytes) - (lr 'image-swap-bits-and-four-bytes) - (wr 'image-swap-bits-and-words)) - (list #| 1Mm 2Mm 4Mm 1Ml 2Ml 4Ml 1Lm 2Lm 4Lm 1Ll 2Ll 4Ll |# - (list #| 1Mm |# n n n r sr lr n s l r r r ) - (list #| 2Mm |# n n n r sr lr n s l r r r ) - (list #| 4Mm |# n n n r sr lr n s l r r r ) - (list #| 1Ml |# r r r n s l r sr lr n n n ) - (list #| 2Ml |# sr sr sr s n w sr r wr s s s ) - (list #| 4Ml |# lr lr lr l w n lr wr r l l l ) - (list #| 1Lm |# n n n r sr lr n s l r r r ) - (list #| 2Lm |# s s s sr r wr s n w sr sr sr) - (list #| 4Lm |# l l l lr wr r l w n lr lr lr) - (list #| 1Ll |# r r r n s l r sr lr n n n ) - (list #| 2Ll |# r r r n s l r sr lr n n n ) - (list #| 4Ll |# r r r n s l r sr lr n n n ))))) - -;;; Of course, the table above is a lie. We also need to factor in the -;;; order of the source data to cope with swapping half of a unit at the -;;; end of a scanline, since we are trying to avoid de-ref'ing off the -;;; end of the source. -;;; -;;; Defines whether the first half of a unit has the first half of the data - -(defparameter - *image-swap-lsb-first-p* - '#.(make-array - 12 :initial-contents - (list t #| 1mm |# - t #| 2mm |# - t #| 4mm |# - t #| 1ml |# - nil #| 2ml |# - nil #| 4ml |# - t #| 1lm |# - nil #| 2lm |# - nil #| 4lm |# - t #| 1ll |# - t #| 2ll |# - t #| 4ll |# - ))) - -(defun image-swap-function - (bits-per-pixel - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) - (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p) - (clx-values function lsb-first-p)) - (cond ((index= bits-per-pixel 1) - (let ((from-index - (index+ - (ecase from-bitmap-unit (32 2) (16 1) (8 0)) - (if from-bit-lsb-first-p 3 0) - (if from-byte-lsb-first-p 6 0)))) - (values - (aref *image-swap-function* from-index - (index+ - (ecase to-bitmap-unit (32 2) (16 1) (8 0)) - (if to-bit-lsb-first-p 3 0) - (if to-byte-lsb-first-p 6 0))) - (aref *image-swap-lsb-first-p* from-index)))) - (t - (values - (if (if (index= bits-per-pixel 4) - (eq from-bit-lsb-first-p to-bit-lsb-first-p) - (eq from-byte-lsb-first-p to-byte-lsb-first-p)) - 'image-noswap - (ecase bits-per-pixel - (4 'image-swap-nibbles) - (8 'image-noswap) - (16 'image-swap-two-bytes) - (24 'image-swap-three-bytes) - (32 'image-swap-four-bytes))) - from-byte-lsb-first-p)))) - - -;;;----------------------------------------------------------------------------- -;;; GET-IMAGE - -(defun read-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index-ceiling x 8)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y)) - (left-bits (the array-index - (mod (the (integer #x-FFFF 0) (- x)) - 8))) - (right-bits (index-mod (index- width left-bits) 8)) - (middle-bits (- width left-bits right-bits)) - (middle-bytes (floor middle-bits 8))) - ((index>= y height)) - (declare (type array-index start y left-bits right-bits)) - (declare (fixnum middle-bits middle-bytes)) - (cond ((< middle-bits 0) - (let ((byte (aref buffer-bbuf (index1- start))) - (x left-bits)) - (declare (type card8 byte) - (type array-index x)) - (when (index> right-bits 6) - (setf (aref array y (index- x 1)) - (read-image-load-byte 1 7 byte))) - (when (and (index> left-bits 1) - (index> right-bits 5)) - (setf (aref array y (index- x 2)) - (read-image-load-byte 1 6 byte))) - (when (and (index> left-bits 2) - (index> right-bits 4)) - (setf (aref array y (index- x 3)) - (read-image-load-byte 1 5 byte))) - (when (and (index> left-bits 3) - (index> right-bits 3)) - (setf (aref array y (index- x 4)) - (read-image-load-byte 1 4 byte))) - (when (and (index> left-bits 4) - (index> right-bits 2)) - (setf (aref array y (index- x 5)) - (read-image-load-byte 1 3 byte))) - (when (and (index> left-bits 5) - (index> right-bits 1)) - (setf (aref array y (index- x 6)) - (read-image-load-byte 1 2 byte))) - (when (index> left-bits 6) - (setf (aref array y (index- x 7)) - (read-image-load-byte 1 1 byte))))) - (t - (unless (index-zerop left-bits) - (let ((byte (aref buffer-bbuf (index1- start))) - (x left-bits)) - (declare (type card8 byte) - (type array-index x)) - (setf (aref array y (index- x 1)) - (read-image-load-byte 1 7 byte)) - (when (index> left-bits 1) - (setf (aref array y (index- x 2)) - (read-image-load-byte 1 6 byte)) - (when (index> left-bits 2) - (setf (aref array y (index- x 3)) - (read-image-load-byte 1 5 byte)) - (when (index> left-bits 3) - (setf (aref array y (index- x 4)) - (read-image-load-byte 1 4 byte)) - (when (index> left-bits 4) - (setf (aref array y (index- x 5)) - (read-image-load-byte 1 3 byte)) - (when (index> left-bits 5) - (setf (aref array y (index- x 6)) - (read-image-load-byte 1 2 byte)) - (when (index> left-bits 6) - (setf (aref array y (index- x 7)) - (read-image-load-byte 1 1 byte)) - )))))))) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (x left-bits (index+ x 8))) - ((index>= i end) - (unless (index-zerop right-bits) - (let ((byte (aref buffer-bbuf end)) - (x (index+ left-bits middle-bits))) - (declare (type card8 byte) - (type array-index x)) - (setf (aref array y (index+ x 0)) - (read-image-load-byte 1 0 byte)) - (when (index> right-bits 1) - (setf (aref array y (index+ x 1)) - (read-image-load-byte 1 1 byte)) - (when (index> right-bits 2) - (setf (aref array y (index+ x 2)) - (read-image-load-byte 1 2 byte)) - (when (index> right-bits 3) - (setf (aref array y (index+ x 3)) - (read-image-load-byte 1 3 byte)) - (when (index> right-bits 4) - (setf (aref array y (index+ x 4)) - (read-image-load-byte 1 4 byte)) - (when (index> right-bits 5) - (setf (aref array y (index+ x 5)) - (read-image-load-byte 1 5 byte)) - (when (index> right-bits 6) - (setf (aref array y (index+ x 6)) - (read-image-load-byte 1 6 byte)) - ))))))))) - (declare (type array-index end i x)) - (let ((byte (aref buffer-bbuf i))) - (declare (type card8 byte)) - (setf (aref array y (index+ x 0)) - (read-image-load-byte 1 0 byte)) - (setf (aref array y (index+ x 1)) - (read-image-load-byte 1 1 byte)) - (setf (aref array y (index+ x 2)) - (read-image-load-byte 1 2 byte)) - (setf (aref array y (index+ x 3)) - (read-image-load-byte 1 3 byte)) - (setf (aref array y (index+ x 4)) - (read-image-load-byte 1 4 byte)) - (setf (aref array y (index+ x 5)) - (read-image-load-byte 1 5 byte)) - (setf (aref array y (index+ x 6)) - (read-image-load-byte 1 6 byte)) - (setf (aref array y (index+ x 7)) - (read-image-load-byte 1 7 byte)))) - ))))) - -(defun read-pixarray-4 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index-ceiling x 2)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y)) - (left-nibbles (mod (the fixnum (- x)) 2)) - (right-nibbles (index-mod (index- width left-nibbles) 2)) - (middle-nibbles (index- width left-nibbles right-nibbles)) - (middle-bytes (index-floor middle-nibbles 2))) - ((index>= y height)) - (declare (type array-index start y - left-nibbles right-nibbles middle-nibbles middle-bytes)) - (unless (index-zerop left-nibbles) - (setf (aref array y 0) - (read-image-load-byte - 4 4 (aref buffer-bbuf (index1- start))))) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (x left-nibbles (index+ x 2))) - ((index>= i end) - (unless (index-zerop right-nibbles) - (setf (aref array y (index+ left-nibbles middle-nibbles)) - (read-image-load-byte 4 0 (aref buffer-bbuf end))))) - (declare (type array-index end i x)) - (let ((byte (aref buffer-bbuf i))) - (declare (type card8 byte)) - (setf (aref array y (index+ x 0)) - (read-image-load-byte 4 0 byte)) - (setf (aref array y (index+ x 1)) - (read-image-load-byte 4 4 byte)))) - ))) - -(defun read-pixarray-8 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-8 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - x) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) - (declare (type array-index start y)) - (do* ((end (index+ start width)) - (i start (index1+ i)) - (x 0 (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref array y x) - (the card8 (aref buffer-bbuf i))))))) - -(defun read-pixarray-16 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-16 array) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index* x 2)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) - (declare (type array-index start y)) - (do* ((end (index+ start (index* width 2))) - (i start (index+ i 2)) - (x 0 (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref array y x) - (read-image-assemble-bytes - (aref buffer-bbuf (index+ i 0)) - (aref buffer-bbuf (index+ i 1)))))))) - -(defun read-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index* x 3)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) - (declare (type array-index start y)) - (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x 0 (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref array y x) - (read-image-assemble-bytes - (aref buffer-bbuf (index+ i 0)) - (aref buffer-bbuf (index+ i 1)) - (aref buffer-bbuf (index+ i 2)))))))) - -(defun read-pixarray-32 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-32 array) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index* x 4)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) - (declare (type array-index start y)) - (do* ((end (index+ start (index* width 4))) - (i start (index+ i 4)) - (x 0 (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref array y x) - (read-image-assemble-bytes - (aref buffer-bbuf (index+ i 0)) - (aref buffer-bbuf (index+ i 1)) - (aref buffer-bbuf (index+ i 2)) - (aref buffer-bbuf (index+ i 3)))))))) - -(defun read-pixarray-internal - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel read-pixarray-function - from-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type array-index boffset padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type function read-pixarray-function) - (type (member 8 16 32) from-unit to-unit) - (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p)) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - from-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (if (eq image-swap-function 'image-noswap) - (funcall - read-pixarray-function - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) - (with-image-data-buffer (buf (index* height padded-bytes-per-line)) - (funcall - (symbol-function image-swap-function) bbuf buf - (index+ boffset (index* y padded-bytes-per-line)) 0 - (index-ceiling (index* (index+ x width) bits-per-pixel) 8) - padded-bytes-per-line padded-bytes-per-line height - image-swap-lsb-first-p) - (funcall - read-pixarray-function - buf 0 pixarray x 0 width height padded-bytes-per-line - bits-per-pixel))))) - -(defun read-pixarray - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type array-index boffset padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (unless (fast-read-pixarray - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (read-pixarray-internal - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel - (ecase bits-per-pixel - ( 1 #'read-pixarray-1 ) - ( 4 #'read-pixarray-4 ) - ( 8 #'read-pixarray-8 ) - (16 #'read-pixarray-16) - (24 #'read-pixarray-24) - (32 #'read-pixarray-32)) - unit byte-lsb-first-p bit-lsb-first-p - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+))) - -(defun read-xy-format-image-x - (buffer-bbuf index length data width height depth - padded-bytes-per-line padded-bytes-per-plane - unit byte-lsb-first-p bit-lsb-first-p pad) - (declare (type buffer-bytes buffer-bbuf) - (type card16 width height) - (type array-index index length padded-bytes-per-line - padded-bytes-per-plane) - (type image-depth depth) - (type (member 8 16 32) unit pad) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) - (clx-values image-x)) - (assert (index<= (index* depth padded-bytes-per-plane) length)) - (let* ((bytes-per-line (index-ceiling width 8)) - (data-length (index* padded-bytes-per-plane depth))) - (declare (type array-index bytes-per-line data-length)) - (cond (data - (check-type data buffer-bytes) - (assert (index>= (length data) data-length))) - (t - (setq data (make-array data-length :element-type 'card8)))) - (do ((plane 0 (index1+ plane))) - ((index>= plane depth)) - (declare (type image-depth plane)) - (image-noswap - buffer-bbuf data - (index+ index (index* plane padded-bytes-per-plane)) - (index* plane padded-bytes-per-plane) - bytes-per-line padded-bytes-per-line padded-bytes-per-line - height byte-lsb-first-p)) - (create-image - :width width :height height :depth depth :data data - :bits-per-pixel 1 :format :xy-pixmap - :bytes-per-line padded-bytes-per-line - :unit unit :pad pad - :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) - -(defun read-z-format-image-x - (buffer-bbuf index length data width height depth - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p pad bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type card16 width height) - (type array-index index length padded-bytes-per-line) - (type image-depth depth) - (type (member 8 16 32) unit pad) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (clx-values image-x)) - (assert (index<= (index* height padded-bytes-per-line) length)) - (let ((bytes-per-line (index-ceiling (index* width bits-per-pixel) 8)) - (data-length (index* padded-bytes-per-line height))) - (declare (type array-index bytes-per-line data-length)) - (cond (data - (check-type data buffer-bytes) - (assert (index>= (length data) data-length))) - (t - (setq data (make-array data-length :element-type 'card8)))) - (image-noswap - buffer-bbuf data index 0 bytes-per-line padded-bytes-per-line - padded-bytes-per-line height byte-lsb-first-p) - (create-image - :width width :height height :depth depth :data data - :bits-per-pixel bits-per-pixel :format :z-pixmap - :bytes-per-line padded-bytes-per-line - :unit unit :pad pad - :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) - -(defun read-image-xy (bbuf index length data x y width height depth - padded-bytes-per-line padded-bytes-per-plane - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type card16 x y width height) - (type array-index index length padded-bytes-per-line - padded-bytes-per-plane) - (type image-depth depth) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) - (clx-values image-xy)) - (check-type data list) - (multiple-value-bind (dimensions element-type) - (if data - (values (array-dimensions (first data)) - (array-element-type (first data))) - (values (list height - (index* (index-ceiling width +image-pad+) +image-pad+)) - 'pixarray-1-element-type)) - (do* ((arrays data) - (result nil) - (limit (index+ length index)) - (plane 0 (1+ plane)) - (index index (index+ index padded-bytes-per-plane))) - ((or (>= plane depth) - (index> (index+ index padded-bytes-per-plane) limit)) - (setq data (nreverse result) depth (length data))) - (declare (type array-index limit index) - (type image-depth plane) - (type list arrays result)) - (let ((array (or (pop arrays) - (make-array dimensions :element-type element-type)))) - (declare (type pixarray-1 array)) - (push array result) - (read-pixarray - bbuf index array x y width height padded-bytes-per-line 1 - unit byte-lsb-first-p bit-lsb-first-p))) - (create-image - :width width :height height :depth depth :data data))) - -(defun read-image-z (bbuf index length data x y width height depth - padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type card16 x y width height) - (type array-index index length padded-bytes-per-line) - (type image-depth depth) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) - (clx-values image-z)) - (assert (index<= (index* (index+ y height) padded-bytes-per-line) length)) - (let* ((image-bits-per-line (index* width bits-per-pixel)) - (image-pixels-per-line - (index-ceiling - (index* (index-ceiling image-bits-per-line +image-pad+) - +image-pad+) - bits-per-pixel))) - (declare (type array-index image-bits-per-line image-pixels-per-line)) - (unless data - (setq data - (make-array - (list height image-pixels-per-line) - :element-type (ecase bits-per-pixel - (1 'pixarray-1-element-type) - (4 'pixarray-4-element-type) - (8 'pixarray-8-element-type) - (16 'pixarray-16-element-type) - (24 'pixarray-24-element-type) - (32 'pixarray-32-element-type))))) - (read-pixarray - bbuf index data x y width height padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (create-image - :width width :height height :depth depth :data data - :bits-per-pixel bits-per-pixel))) - -(defun get-image (drawable &key - data - (x (required-arg x)) - (y (required-arg y)) - (width (required-arg width)) - (height (required-arg height)) - plane-mask format result-type) - (declare (type drawable drawable) - (type (or buffer-bytes list pixarray) data) - (type int16 x y) ;; required - (type card16 width height) ;; required - (type (or null pixel) plane-mask) - (type (or null (member :xy-pixmap :z-pixmap)) format) - (type (or null (member image-xy image-x image-z)) result-type) - (clx-values image visual-info)) - (unless result-type - (setq result-type (ecase format - (:xy-pixmap 'image-xy) - (:z-pixmap 'image-z) - ((nil) 'image-x)))) - (unless format - (setq format (case result-type - (image-xy :xy-pixmap) - ((image-z image-x) :z-pixmap)))) - (unless (ecase result-type - (image-xy (eq format :xy-pixmap)) - (image-z (eq format :z-pixmap)) - (image-x t)) - (error "Result-type ~s is incompatable with format ~s" - result-type format)) - (unless plane-mask (setq plane-mask #xffffffff)) - (let ((display (drawable-display drawable))) - (with-buffer-request-and-reply (display +x-getimage+ nil :sizes (8 32)) - (((data (member error :xy-pixmap :z-pixmap)) format) - (drawable drawable) - (int16 x y) - (card16 width height) - (card32 plane-mask)) - (let* ((depth (card8-get 1)) - (length (index* 4 (card32-get 4))) - (visual-info (visual-info display (resource-id-get 8))) - (bitmap-format (display-bitmap-format display)) - (unit (bitmap-format-unit bitmap-format)) - (byte-lsb-first-p (display-image-lsb-first-p display)) - (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) - (declare (type image-depth depth) - (type array-index length) - (type (or null visual-info) visual-info) - (type bitmap-format bitmap-format) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (multiple-value-bind (pad bits-per-pixel) - (ecase format - (:xy-pixmap - (values (bitmap-format-pad bitmap-format) 1)) - (:z-pixmap - (if (= depth 1) - (values (bitmap-format-pad bitmap-format) 1) - (let ((pixmap-format - (find depth (display-pixmap-formats display) - :key #'pixmap-format-depth))) - (declare (type pixmap-format pixmap-format)) - (values (pixmap-format-scanline-pad pixmap-format) - (pixmap-format-bits-per-pixel pixmap-format)))))) - (declare (type (member 8 16 32) pad) - (type (member 1 4 8 16 24 32) bits-per-pixel)) - (let* ((bits-per-line (index* bits-per-pixel width)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line pad) pad)) - (padded-bytes-per-line - (index-ceiling padded-bits-per-line 8)) - (padded-bytes-per-plane - (index* padded-bytes-per-line height)) - (image - (ecase result-type - (image-x - (ecase format - (:xy-pixmap - (read-xy-format-image-x - buffer-bbuf +replysize+ length data - width height depth - padded-bytes-per-line padded-bytes-per-plane - unit byte-lsb-first-p bit-lsb-first-p - pad)) - (:z-pixmap - (read-z-format-image-x - buffer-bbuf +replysize+ length data - width height depth - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p - pad bits-per-pixel)))) - (image-xy - (read-image-xy - buffer-bbuf +replysize+ length data - 0 0 width height depth - padded-bytes-per-line padded-bytes-per-plane - unit byte-lsb-first-p bit-lsb-first-p)) - (image-z - (read-image-z - buffer-bbuf +replysize+ length data - 0 0 width height depth padded-bytes-per-line - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p))))) - (declare (type image image) - (type array-index bits-per-line - padded-bits-per-line padded-bytes-per-line)) - (when visual-info - (unless (zerop (visual-info-red-mask visual-info)) - (setf (image-red-mask image) - (visual-info-red-mask visual-info))) - (unless (zerop (visual-info-green-mask visual-info)) - (setf (image-green-mask image) - (visual-info-green-mask visual-info))) - (unless (zerop (visual-info-blue-mask visual-info)) - (setf (image-blue-mask image) - (visual-info-blue-mask visual-info)))) - (values image visual-info))))))) - - -;;;----------------------------------------------------------------------------- -;;; PUT-IMAGE - -(defun write-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (right-bits (index-mod width 8)) - (middle-bits (index- width right-bits)) - (middle-bytes (index-ceiling middle-bits 8)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y right-bits middle-bits - middle-bytes start)) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (start-x x) - (x start-x (index+ x 8))) - ((index>= i end) - (unless (index-zerop right-bits) - (let ((x (index+ start-x middle-bits))) - (declare (type array-index x)) - (setf (aref buffer-bbuf end) - (write-image-assemble-bytes - (aref array y (index+ x 0)) - (if (index> right-bits 1) - (aref array y (index+ x 1)) - 0) - (if (index> right-bits 2) - (aref array y (index+ x 2)) - 0) - (if (index> right-bits 3) - (aref array y (index+ x 3)) - 0) - (if (index> right-bits 4) - (aref array y (index+ x 4)) - 0) - (if (index> right-bits 5) - (aref array y (index+ x 5)) - 0) - (if (index> right-bits 6) - (aref array y (index+ x 6)) - 0) - 0))))) - (declare (type array-index end i start-x x)) - (setf (aref buffer-bbuf i) - (write-image-assemble-bytes - (aref array y (index+ x 0)) - (aref array y (index+ x 1)) - (aref array y (index+ x 2)) - (aref array y (index+ x 3)) - (aref array y (index+ x 4)) - (aref array y (index+ x 5)) - (aref array y (index+ x 6)) - (aref array y (index+ x 7)))))))) - -(defun write-pixarray-4 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (right-nibbles (index-mod width 2)) - (middle-nibbles (index- width right-nibbles)) - (middle-bytes (index-ceiling middle-nibbles 2)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y right-nibbles middle-nibbles - middle-bytes start)) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (start-x x) - (x start-x (index+ x 2))) - ((index>= i end) - (unless (index-zerop right-nibbles) - (setf (aref buffer-bbuf end) - (write-image-assemble-bytes - (aref array y (index+ start-x middle-nibbles)) - 0)))) - (declare (type array-index end i start-x x)) - (setf (aref buffer-bbuf i) - (write-image-assemble-bytes - (aref array y (index+ x 0)) - (aref array y (index+ x 1)))))))) - -(defun write-pixarray-8 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-8 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y start)) - (do* ((end (index+ start width)) - (i start (index1+ i)) - (x x (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref buffer-bbuf i) (the card8 (aref array y x))))))) - -(defun write-pixarray-16 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-16 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y start)) - (do* ((end (index+ start (index* width 2))) - (i start (index+ i 2)) - (x x (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (let ((pixel (aref array y x))) - (declare (type pixarray-16-element-type pixel)) - (setf (aref buffer-bbuf (index+ i 0)) - (write-image-load-byte 0 pixel 16)) - (setf (aref buffer-bbuf (index+ i 1)) - (write-image-load-byte 8 pixel 16))))))) - -(defun write-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index y start)) - (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x x (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (let ((pixel (aref array y x))) - (declare (type pixarray-24-element-type pixel)) - (setf (aref buffer-bbuf (index+ i 0)) - (write-image-load-byte 0 pixel 24)) - (setf (aref buffer-bbuf (index+ i 1)) - (write-image-load-byte 8 pixel 24)) - (setf (aref buffer-bbuf (index+ i 2)) - (write-image-load-byte 16 pixel 24))))))) - -(defun write-pixarray-32 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-32 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y start)) - (do* ((end (index+ start (index* width 4))) - (i start (index+ i 4)) - (x x (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (let ((pixel (aref array y x))) - (declare (type pixarray-32-element-type pixel)) - (setf (aref buffer-bbuf (index+ i 0)) - (write-image-load-byte 0 pixel 32)) - (setf (aref buffer-bbuf (index+ i 1)) - (write-image-load-byte 8 pixel 32)) - (setf (aref buffer-bbuf (index+ i 2)) - (write-image-load-byte 16 pixel 32)) - (setf (aref buffer-bbuf (index+ i 3)) - (write-image-load-byte 24 pixel 32))))))) - -(defun write-pixarray-internal - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel write-pixarray-function - from-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type function write-pixarray-function) - (type (member 8 16 32) from-unit to-unit) - (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p)) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - from-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (if (eq image-swap-function 'image-noswap) - (funcall - write-pixarray-function - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) - (with-image-data-buffer (buf (index* height padded-bytes-per-line)) - (funcall - write-pixarray-function - buf 0 pixarray x y width height padded-bytes-per-line - bits-per-pixel) - (funcall - (symbol-function image-swap-function) buf bbuf 0 boffset - (index-ceiling (index* width bits-per-pixel) 8) - padded-bytes-per-line padded-bytes-per-line height - image-swap-lsb-first-p))))) - -(defun write-pixarray - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (unless (fast-write-pixarray - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (write-pixarray-internal - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel - (ecase bits-per-pixel - ( 1 #'write-pixarray-1 ) - ( 4 #'write-pixarray-4 ) - ( 8 #'write-pixarray-8 ) - (16 #'write-pixarray-16) - (24 #'write-pixarray-24) - (32 #'write-pixarray-32)) - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+ - unit byte-lsb-first-p bit-lsb-first-p))) - -(defun write-xy-format-image-x-data - (data obuf data-start obuf-start x y width height - from-padded-bytes-per-line to-padded-bytes-per-line - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type buffer-bytes data obuf) - (type array-index data-start obuf-start - from-padded-bytes-per-line to-padded-bytes-per-line) - (type card16 x y width height) - (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) - (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p)) - (assert (index-zerop (index-mod x 8))) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - 1 - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (let ((x-mod-unit (index-mod x from-bitmap-unit))) - (declare (type card16 x-mod-unit)) - (if (and (index-plusp x-mod-unit) - (not (eq from-byte-lsb-first-p from-bit-lsb-first-p))) - (let* ((temp-width (index+ width x-mod-unit)) - (temp-bytes-per-line (index-ceiling temp-width 8)) - (temp-padded-bits-per-line - (index* (index-ceiling temp-width from-bitmap-unit) - from-bitmap-unit)) - (temp-padded-bytes-per-line - (index-ceiling temp-padded-bits-per-line 8))) - (declare (type card16 temp-width temp-bytes-per-line - temp-padded-bits-per-line temp-padded-bytes-per-line)) - (with-image-data-buffer - (buf (index* height temp-padded-bytes-per-line)) - (funcall - (symbol-function image-swap-function) data buf - (index+ data-start - (index* y from-padded-bytes-per-line) - (index-floor (index- x x-mod-unit) 8)) - 0 temp-bytes-per-line from-padded-bytes-per-line - temp-padded-bytes-per-line height image-swap-lsb-first-p) - (write-xy-format-image-x-data - buf obuf 0 obuf-start x-mod-unit 0 width height - temp-padded-bytes-per-line to-padded-bytes-per-line - from-bitmap-unit to-byte-lsb-first-p to-byte-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p))) - (funcall - (symbol-function image-swap-function) data obuf - (index+ data-start - (index* y from-padded-bytes-per-line) - (index-floor x 8)) - obuf-start (index-ceiling width 8) from-padded-bytes-per-line - to-padded-bytes-per-line height image-swap-lsb-first-p))))) - -(defun write-xy-format-image-x - (display image src-x src-y width height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type display display) - (type image-x image) - (type int16 src-x src-y) - (type card16 width height) - (type array-index padded-bytes-per-line) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (dotimes (plane (image-depth image)) - (let ((data-start - (index* (index* plane (image-height image)) - (image-x-bytes-per-line image))) - (src-y src-y) - (height height)) - (declare (type int16 src-y) - (type card16 height)) - (loop - (when (index-zerop height) (return)) - (let ((nlines - (index-min (index-floor (index- (buffer-size display) - (buffer-boffset display)) - padded-bytes-per-line) - height))) - (declare (type array-index nlines)) - (when (index-plusp nlines) - (write-xy-format-image-x-data - (image-x-data image) (buffer-obuf8 display) - data-start (buffer-boffset display) - src-x src-y width nlines - (image-x-bytes-per-line image) padded-bytes-per-line - (image-x-unit image) (image-x-byte-lsb-first-p image) - (image-x-bit-lsb-first-p image) - unit byte-lsb-first-p bit-lsb-first-p) - (index-incf (buffer-boffset display) - (index* nlines padded-bytes-per-line)) - (index-incf src-y nlines) - (when (index-zerop (index-decf height nlines)) (return)))) - (buffer-flush display))))) - -(defun write-z-format-image-x-data - (data obuf data-start obuf-start x y width height - from-padded-bytes-per-line to-padded-bytes-per-line - bits-per-pixel - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type buffer-bytes data obuf) - (type array-index data-start obuf-start - from-padded-bytes-per-line to-padded-bytes-per-line) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) - (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p)) - (if (index= bits-per-pixel 1) - (write-xy-format-image-x-data - data obuf data-start obuf-start x y width height - from-padded-bytes-per-line to-padded-bytes-per-line - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (let ((srcoff - (index+ data-start - (index* y from-padded-bytes-per-line) - (index-floor (index* x bits-per-pixel) 8))) - (srclen (index-ceiling (index* width bits-per-pixel) 8))) - (declare (type array-index srcoff srclen)) - (if (and (index= bits-per-pixel 4) (index-oddp x)) - (with-image-data-buffer (buf (index* height to-padded-bytes-per-line)) - (image-swap-nibbles-left - data buf srcoff 0 srclen - from-padded-bytes-per-line to-padded-bytes-per-line height nil) - (write-z-format-image-x-data - buf obuf 0 obuf-start 0 0 width height - to-padded-bytes-per-line to-padded-bytes-per-line - bits-per-pixel - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (funcall - (symbol-function image-swap-function) data obuf srcoff obuf-start - srclen from-padded-bytes-per-line to-padded-bytes-per-line height - image-swap-lsb-first-p)))))) - -(defun write-z-format-image-x (display image src-x src-y width height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type display display) - (type image-x image) - (type int16 src-x src-y) - (type card16 width height) - (type array-index padded-bytes-per-line) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (loop - (when (index-zerop height) (return)) - (let ((nlines - (index-min (index-floor (index- (buffer-size display) - (buffer-boffset display)) - padded-bytes-per-line) - height))) - (declare (type array-index nlines)) - (when (index-plusp nlines) - (write-z-format-image-x-data - (image-x-data image) (buffer-obuf8 display) 0 (buffer-boffset display) - src-x src-y width nlines - (image-x-bytes-per-line image) padded-bytes-per-line - (image-x-bits-per-pixel image) - (image-x-unit image) (image-x-byte-lsb-first-p image) - (image-x-bit-lsb-first-p image) - unit byte-lsb-first-p bit-lsb-first-p) - (index-incf (buffer-boffset display) - (index* nlines padded-bytes-per-line)) - (index-incf src-y nlines) - (when (index-zerop (index-decf height nlines)) (return)))) - (buffer-flush display))) - -(defun write-image-xy (display image src-x src-y width height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type display display) - (type image-xy image) - (type array-index padded-bytes-per-line) - (type int16 src-x src-y) - (type card16 width height) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (dolist (bitmap (image-xy-bitmap-list image)) - (declare (type pixarray-1 bitmap)) - (let ((src-y src-y) - (height height)) - (declare (type int16 src-y) - (type card16 height)) - (loop - (let ((nlines - (index-min (index-floor (index- (buffer-size display) - (buffer-boffset display)) - padded-bytes-per-line) - height))) - (declare (type array-index nlines)) - (when (index-plusp nlines) - (write-pixarray - (buffer-obuf8 display) (buffer-boffset display) - bitmap src-x src-y width nlines - padded-bytes-per-line 1 - unit byte-lsb-first-p bit-lsb-first-p) - (index-incf (buffer-boffset display) - (index* nlines padded-bytes-per-line)) - (index-incf src-y nlines) - (when (index-zerop (index-decf height nlines)) (return)))) - (buffer-flush display))))) - -(defun write-image-z (display image src-x src-y width height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type display display) - (type image-z image) - (type array-index padded-bytes-per-line) - (type int16 src-x src-y) - (type card16 width height) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (loop - (let ((bits-per-pixel (image-z-bits-per-pixel image)) - (nlines - (index-min (index-floor (index- (buffer-size display) - (buffer-boffset display)) - padded-bytes-per-line) - height))) - (declare (type (member 1 4 8 16 24 32) bits-per-pixel) - (type array-index nlines)) - (when (index-plusp nlines) - (write-pixarray - (buffer-obuf8 display) (buffer-boffset display) - (image-z-pixarray image) src-x src-y width nlines - padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (index-incf (buffer-boffset display) - (index* nlines padded-bytes-per-line)) - (index-incf src-y nlines) - (when (index-zerop (index-decf height nlines)) (return)))) - (buffer-flush display))) - -;;; Note: The only difference between a format of :bitmap and :xy-pixmap -;;; of depth 1 is that when sending a :bitmap format the foreground -;;; and background in the gcontext are used. - -(defun put-image (drawable gcontext image &key - (src-x 0) (src-y 0) ;Position within image - (x (required-arg x)) ;Position within drawable - (y (required-arg y)) - width height - bitmap-p) - ;; Copy an image into a drawable. - ;; WIDTH and HEIGHT default from IMAGE. - ;; When BITMAP-P, force format to be :bitmap when depth=1. - ;; This causes gcontext to supply foreground & background pixels. - (declare (type drawable drawable) - (type gcontext gcontext) - (type image image) - (type int16 x y) ;; required - (type int16 src-x src-y) - (type (or null card16) width height) - (type generalized-boolean bitmap-p)) - (let* ((format - (etypecase image - (image-x (image-x-format (the image-x image))) - (image-xy :xy-pixmap) - (image-z :z-pixmap))) - (src-x - (if (image-x-p image) - (index+ src-x (image-x-left-pad (the image-x image))) - src-x)) - (image-width (image-width image)) - (image-height (image-height image)) - (width (min (or width image-width) (index- image-width src-x))) - (height (min (or height image-height) (index- image-height src-y))) - (depth (image-depth image)) - (display (drawable-display drawable)) - (bitmap-format (display-bitmap-format display)) - (unit (bitmap-format-unit bitmap-format)) - (byte-lsb-first-p (display-image-lsb-first-p display)) - (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) - (declare (type (member :bitmap :xy-pixmap :z-pixmap) format) - (type fixnum src-x image-width image-height width height) - (type image-depth depth) - (type display display) - (type bitmap-format bitmap-format) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (when (and bitmap-p (not (index= depth 1))) - (error "Bitmaps must have depth 1")) - (unless (<= 0 src-x (index1- (image-width image))) - (error "src-x not inside image")) - (unless (<= 0 src-y (index1- (image-height image))) - (error "src-y not inside image")) - (when (and (index> width 0) (index> height 0)) - (multiple-value-bind (pad bits-per-pixel) - (ecase format - ((:bitmap :xy-pixmap) - (values (bitmap-format-pad bitmap-format) 1)) - (:z-pixmap - (if (= depth 1) - (values (bitmap-format-pad bitmap-format) 1) - (let ((pixmap-format - (find depth (display-pixmap-formats display) - :key #'pixmap-format-depth))) - (declare (type (or null pixmap-format) pixmap-format)) - (if (null pixmap-format) - (error "The depth of the image ~s does not match any server pixmap format." image)) - (if (not (= (etypecase image - (image-z (image-z-bits-per-pixel image)) - (image-x (image-x-bits-per-pixel image))) - (pixmap-format-bits-per-pixel pixmap-format))) - ;; We could try to use the "/* XXX slow, but works */" - ;; code in XPutImage from X11R4 here. However, that - ;; would require considerable support code - ;; (see XImUtil.c, etc). - (error "The bits-per-pixel of the image ~s does not match any server pixmap format." image)) - (values (pixmap-format-scanline-pad pixmap-format) - (pixmap-format-bits-per-pixel pixmap-format)))))) - (declare (type (member 8 16 32) pad) - (type (member 1 4 8 16 24 32) bits-per-pixel)) - (let* ((left-pad - (if (or (eq format :xy-pixmap) (= depth 1)) - (index-mod src-x (index-min pad +image-pad+)) - 0)) - (left-padded-src-x (index- src-x left-pad)) - (left-padded-width (index+ width left-pad)) - (bits-per-line (index* left-padded-width bits-per-pixel)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line pad) pad)) - (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) - (request-bytes-per-line - (ecase format - ((:bitmap :xy-pixmap) (index* padded-bytes-per-line depth)) - (:z-pixmap padded-bytes-per-line))) - (max-bytes-per-request - (index* (index- (display-max-request-length display) 6) 4)) - (max-request-height - (floor max-bytes-per-request request-bytes-per-line))) - (declare (type card8 left-pad) - (type int16 left-padded-src-x) - (type card16 left-padded-width) - (type array-index bits-per-line padded-bits-per-line - padded-bytes-per-line request-bytes-per-line - max-bytes-per-request max-request-height)) - ;; Be sure that a scanline can fit in a request - (when (index-zerop max-request-height) - (error "Can't even fit one image scanline in a request")) - ;; Be sure a scanline can fit in a buffer - (buffer-ensure-size display padded-bytes-per-line) - ;; Send the image in multiple requests to avoid exceeding the - ;; request limit - (do* ((request-src-y src-y (index+ request-src-y request-height)) - (request-y y (index+ request-y request-height)) - (height-remaining - height (the fixnum (- height-remaining request-height))) - (request-height - (index-min height-remaining max-request-height) - (index-min height-remaining max-request-height))) - ((<= height-remaining 0)) - (declare (type array-index request-src-y request-height) - (fixnum height-remaining)) - (let* ((request-bytes (index* request-bytes-per-line request-height)) - (request-words (index-ceiling request-bytes 4)) - (request-length (index+ request-words 6))) - (declare (type array-index request-bytes) - (type card16 request-words request-length)) - (with-buffer-request (display +x-putimage+ :gc-force gcontext) - ((data (member :bitmap :xy-pixmap :z-pixmap)) - (cond ((or (eq format :bitmap) bitmap-p) :bitmap) - ((plusp left-pad) :xy-pixmap) - (t format))) - (drawable drawable) - (gcontext gcontext) - (card16 width request-height) - (int16 x request-y) - (card8 left-pad depth) - (pad16 nil) - (progn - (length-put 2 request-length) - (setf (buffer-boffset display) (advance-buffer-offset 24)) - (etypecase image - (image-x - (ecase (image-x-format (the image-x image)) - ((:bitmap :xy-pixmap) - (write-xy-format-image-x - display image left-padded-src-x request-src-y - left-padded-width request-height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p)) - (:z-pixmap - (write-z-format-image-x - display image left-padded-src-x request-src-y - left-padded-width request-height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p)))) - (image-xy - (write-image-xy - display image left-padded-src-x request-src-y - left-padded-width request-height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p)) - (image-z - (write-image-z - display image left-padded-src-x request-src-y - left-padded-width request-height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p))) - ;; Be sure the request is padded to a multiple of 4 bytes - (buffer-pad-request display (index- (index* request-words 4) request-bytes)) - ))))))))) - -;;;----------------------------------------------------------------------------- -;;; COPY-IMAGE - -(defun xy-format-image-x->image-x (image x y width height) - (declare (type image-x image) - (type card16 x y width height) - (clx-values image-x)) - (let* ((padded-x (index+ x (image-x-left-pad image))) - (left-pad (index-mod padded-x 8)) - (x (index- padded-x left-pad)) - (unit (image-x-unit image)) - (byte-lsb-first-p (image-x-byte-lsb-first-p image)) - (bit-lsb-first-p (image-x-bit-lsb-first-p image)) - (pad (image-x-pad image)) - (padded-width - (index* (index-ceiling (index+ width left-pad) pad) pad)) - (padded-bytes-per-line (index-ceiling padded-width 8)) - (padded-bytes-per-plane (index* padded-bytes-per-line height)) - (length (index* padded-bytes-per-plane (image-depth image))) - (obuf (make-array length :element-type 'card8))) - (declare (type card16 x) - (type card8 left-pad) - (type (member 8 16 32) unit pad) - (type array-index padded-width padded-bytes-per-line - padded-bytes-per-plane length) - (type buffer-bytes obuf)) - (dotimes (plane (image-depth image)) - (let ((data-start - (index* (image-x-bytes-per-line image) - (image-height image) - plane)) - (obuf-start - (index* padded-bytes-per-plane - plane))) - (declare (type array-index data-start obuf-start)) - (write-xy-format-image-x-data - (image-x-data image) obuf data-start obuf-start - x y width height - (image-x-bytes-per-line image) padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p - unit byte-lsb-first-p bit-lsb-first-p))) - (create-image - :width width :height height :depth (image-depth image) - :data obuf :format (image-x-format image) :bits-per-pixel 1 - :bytes-per-line padded-bytes-per-line - :unit unit :pad pad :left-pad left-pad - :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) - -(defun z-format-image-x->image-x (image x y width height) - (declare (type image-x image) - (type card16 x y width height) - (clx-values image-x)) - (let* ((padded-x (index+ x (image-x-left-pad image))) - (left-pad - (if (index= (image-depth image) 1) - (index-mod padded-x 8) - 0)) - (x (index- padded-x left-pad)) - (bits-per-pixel (image-x-bits-per-pixel image)) - (unit (image-x-unit image)) - (byte-lsb-first-p (image-x-byte-lsb-first-p image)) - (bit-lsb-first-p (image-x-bit-lsb-first-p image)) - (pad (image-x-pad image)) - (bits-per-line (index* (index+ width left-pad) bits-per-pixel)) - (padded-bits-per-line (index* (index-ceiling bits-per-line pad) pad)) - (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) - (padded-bytes-per-plane (index* padded-bytes-per-line height)) - (length (index* padded-bytes-per-plane (image-depth image))) - (obuf (make-array length :element-type 'card8))) - (declare (type card16 x) - (type card8 left-pad) - (type (member 8 16 32) unit pad) - (type array-index bits-per-pixel padded-bytes-per-line - padded-bytes-per-plane length) - (type buffer-bytes obuf)) - (write-z-format-image-x-data - (image-x-data image) obuf 0 0 - x y width height - (image-x-bytes-per-line image) padded-bytes-per-line - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p - unit byte-lsb-first-p bit-lsb-first-p) - (create-image - :width width :height height :depth (image-depth image) - :data obuf :format :z-pixmap :bits-per-pixel bits-per-pixel - :bytes-per-line padded-bytes-per-line - :unit unit :pad pad :left-pad left-pad - :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) - -(defun image-x->image-x (image x y width height) - (declare (type image-x image) - (type card16 x y width height) - (clx-values image-x)) - (ecase (image-x-format image) - ((:bitmap :xy-pixmap) - (xy-format-image-x->image-x image x y width height)) - (:z-pixmap - (z-format-image-x->image-x image x y width height)))) - -(defun image-x->image-xy (image x y width height) - (declare (type image-x image) - (type card16 x y width height) - (clx-values image-xy)) - (unless (or (eq (image-x-format image) :bitmap) - (eq (image-x-format image) :xy-pixmap) - (and (eq (image-x-format image) :z-pixmap) - (index= (image-depth image) 1))) - (error "Format conversion from ~S to ~S not supported" - (image-x-format image) :xy-pixmap)) - (read-image-xy - (image-x-data image) 0 (length (image-x-data image)) nil - (index+ x (image-x-left-pad image)) y width height - (image-depth image) (image-x-bytes-per-line image) - (index* (image-x-bytes-per-line image) (image-height image)) - (image-x-unit image) (image-x-byte-lsb-first-p image) - (image-x-bit-lsb-first-p image))) - -(defun image-x->image-z (image x y width height) - (declare (type image-x image) - (type card16 x y width height) - (clx-values image-z)) - (unless (or (eq (image-x-format image) :z-pixmap) - (eq (image-x-format image) :bitmap) - (and (eq (image-x-format image) :xy-pixmap) - (index= (image-depth image) 1))) - (error "Format conversion from ~S to ~S not supported" - (image-x-format image) :z-pixmap)) - (read-image-z - (image-x-data image) 0 (length (image-x-data image)) nil - (index+ x (image-x-left-pad image)) y width height - (image-depth image) (image-x-bytes-per-line image) - (image-x-bits-per-pixel image) - (image-x-unit image) (image-x-byte-lsb-first-p image) - (image-x-bit-lsb-first-p image))) - -(defun copy-pixarray (array x y width height bits-per-pixel) - (declare (type pixarray array) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel)) - (let* ((bits-per-line (index* bits-per-pixel width)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line +image-pad+) +image-pad+)) - (padded-width (index-ceiling padded-bits-per-line bits-per-pixel)) - (copy (make-array (list height padded-width) - :element-type (array-element-type array)))) - (declare (type array-index bits-per-line padded-bits-per-line padded-width) - (type pixarray copy)) - #.(declare-buffun) - (unless (fast-copy-pixarray array copy x y width height bits-per-pixel) - (macrolet - ((copy (array-type element-type) - `(let ((array array) - (copy copy)) - (declare (type ,array-type array copy)) - (do* ((dst-y 0 (index1+ dst-y)) - (src-y y (index1+ src-y))) - ((index>= dst-y height)) - (declare (type card16 dst-y src-y)) - (do* ((dst-x 0 (index1+ dst-x)) - (src-x x (index1+ src-x))) - ((index>= dst-x width)) - (declare (type card16 dst-x src-x)) - (setf (aref copy dst-y dst-x) - (the ,element-type - (aref array src-y src-x)))))))) - (ecase bits-per-pixel - (1 (copy pixarray-1 pixarray-1-element-type)) - (4 (copy pixarray-4 pixarray-4-element-type)) - (8 (copy pixarray-8 pixarray-8-element-type)) - (16 (copy pixarray-16 pixarray-16-element-type)) - (24 (copy pixarray-24 pixarray-24-element-type)) - (32 (copy pixarray-32 pixarray-32-element-type))))) - copy)) - -(defun image-xy->image-x (image x y width height) - (declare (type image-xy image) - (type card16 x y width height) - (clx-values image-x)) - (let* ((padded-bits-per-line - (index* (index-ceiling width +image-pad+) +image-pad+)) - (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) - (padded-bytes-per-plane (index* padded-bytes-per-line height)) - (bytes-total (index* padded-bytes-per-plane (image-depth image))) - (data (make-array bytes-total :element-type 'card8))) - (declare (type array-index padded-bits-per-line padded-bytes-per-line - padded-bytes-per-plane bytes-total) - (type buffer-bytes data)) - (let ((index 0)) - (declare (type array-index index)) - (dolist (bitmap (image-xy-bitmap-list image)) - (declare (type pixarray-1 bitmap)) - (write-pixarray - data index bitmap x y width height padded-bytes-per-line 1 - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+) - (index-incf index padded-bytes-per-plane))) - (create-image - :width width :height height :depth (image-depth image) - :data data :format :xy-pixmap :bits-per-pixel 1 - :bytes-per-line padded-bytes-per-line - :unit +image-unit+ :pad +image-pad+ - :byte-lsb-first-p +image-byte-lsb-first-p+ - :bit-lsb-first-p +image-bit-lsb-first-p+))) - -(defun image-xy->image-xy (image x y width height) - (declare (type image-xy image) - (type card16 x y width height) - (clx-values image-xy)) - (create-image - :width width :height height :depth (image-depth image) - :data (mapcar - #'(lambda (array) - (declare (type pixarray-1 array)) - (copy-pixarray array x y width height 1)) - (image-xy-bitmap-list image)))) - -(defun image-xy->image-z (image x y width height) - (declare (type image-z image) - (type card16 x y width height) - (ignore image x y width height)) - (error "Format conversion from ~S to ~S not supported" - :xy-pixmap :z-pixmap)) - -(defun image-z->image-x (image x y width height) - (declare (type image-z image) - (type card16 x y width height) - (clx-values image-x)) - (let* ((bits-per-line (index* width (image-z-bits-per-pixel image))) - (padded-bits-per-line - (index* (index-ceiling bits-per-line +image-pad+) +image-pad+)) - (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) - (bytes-total - (index* padded-bytes-per-line height (image-depth image))) - (data (make-array bytes-total :element-type 'card8)) - (bits-per-pixel (image-z-bits-per-pixel image))) - (declare (type array-index bits-per-line padded-bits-per-line - padded-bytes-per-line bytes-total) - (type buffer-bytes data) - (type (member 1 4 8 16 24 32) bits-per-pixel)) - (write-pixarray - data 0 (image-z-pixarray image) x y width height padded-bytes-per-line - (image-z-bits-per-pixel image) - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+) - (create-image - :width width :height height :depth (image-depth image) - :data data :format :z-pixmap - :bits-per-pixel bits-per-pixel - :bytes-per-line padded-bytes-per-line - :unit +image-unit+ :pad +image-pad+ - :byte-lsb-first-p +image-byte-lsb-first-p+ - :bit-lsb-first-p +image-bit-lsb-first-p+))) - -(defun image-z->image-xy (image x y width height) - (declare (type image-z image) - (type card16 x y width height) - (ignore image x y width height)) - (error "Format conversion from ~S to ~S not supported" - :z-pixmap :xy-pixmap)) - -(defun image-z->image-z (image x y width height) - (declare (type image-z image) - (type card16 x y width height) - (clx-values image-z)) - (create-image - :width width :height height :depth (image-depth image) - :data (copy-pixarray - (image-z-pixarray image) x y width height - (image-z-bits-per-pixel image)))) - -(defun copy-image (image &key (x 0) (y 0) width height result-type) - ;; Copy with optional sub-imaging and format conversion. - ;; result-type defaults to (type-of image) - (declare (type image image) - (type card16 x y) - (type (or null card16) width height) ;; Default from image - (type (or null (member image-x image-xy image-z)) result-type)) - (declare (clx-values image)) - (let* ((image-width (image-width image)) - (image-height (image-height image)) - (width (or width image-width)) - (height (or height image-height))) - (declare (type card16 image-width image-height width height)) - (unless (<= 0 x (the fixnum (1- image-width))) - (error "x not inside image")) - (unless (<= 0 y (the fixnum (1- image-height))) - (error "y not inside image")) - (setq width (index-min width (max (the fixnum (- image-width x)) 0))) - (setq height (index-min height (max (the fixnum (- image-height y)) 0))) - (let ((copy - (etypecase image - (image-x - (ecase result-type - ((nil image-x) (image-x->image-x image x y width height)) - (image-xy (image-x->image-xy image x y width height)) - (image-z (image-x->image-z image x y width height)))) - (image-xy - (ecase result-type - (image-x (image-xy->image-x image x y width height)) - ((nil image-xy) (image-xy->image-xy image x y width height)) - (image-z (image-xy->image-z image x y width height)))) - (image-z - (ecase result-type - (image-x (image-z->image-x image x y width height)) - (image-xy (image-z->image-xy image x y width height)) - ((nil image-z) (image-z->image-z image x y width height))))))) - (declare (type image copy)) - (setf (image-plist copy) (copy-list (image-plist image))) - (when (and (image-x-hot image) (not (index-zerop x))) - (setf (image-x-hot copy) (index- (image-x-hot image) x))) - (when (and (image-y-hot image) (not (index-zerop y))) - (setf (image-y-hot copy) (index- (image-y-hot image) y))) - copy))) - - -;;;----------------------------------------------------------------------------- -;;; Image I/O functions - - -(defun read-bitmap-file (pathname) - ;; Creates an image from a C include file in standard X11 format - (declare (type (or pathname string stream) pathname)) - (declare (clx-values image)) - (with-open-file (fstream pathname :direction :input) - (let ((line "") - (properties nil) - (name nil) - (name-end nil)) - (declare (type string line) - (type stringable name) - (type list properties)) - ;; Get properties - (loop - (setq line (read-line fstream)) - (unless (char= (aref line 0) #\#) (return)) - (flet ((read-keyword (line start end) - (kintern - (substitute - #\- #\_ - (string-upcase - (subseq line start end)) - :test #'char=)))) - (when (null name) - (setq name-end (position #\_ line :test #'char= :from-end t) - name (read-keyword line 8 name-end)) - (unless (eq name :image) - (setf (getf properties :name) name))) - (let* ((ind-start (index1+ name-end)) - (ind-end (position #\Space line :test #'char= - :start ind-start)) - (ind (read-keyword line ind-start ind-end)) - (val-start (index1+ ind-end)) - (val (parse-integer line :start val-start))) - (setf (getf properties ind) val)))) - ;; Calculate sizes - (multiple-value-bind (width height depth left-pad) - (flet ((extract-property (ind &rest default) - (prog1 (apply #'getf properties ind default) - (remf properties ind)))) - (values (extract-property :width) - (extract-property :height) - (extract-property :depth 1) - (extract-property :left-pad 0))) - (declare (type (or null card16) width height) - (type image-depth depth) - (type card8 left-pad)) - (unless (and width height) (error "Not a BITMAP file")) - (let* ((bits-per-pixel - (cond ((index> depth 24) 32) - ((index> depth 16) 24) - ((index> depth 8) 16) - ((index> depth 4) 8) - ((index> depth 1) 4) - (t 1))) - (bits-per-line (index* width bits-per-pixel)) - (bytes-per-line (index-ceiling bits-per-line 8)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line 32) 32)) - (padded-bytes-per-line - (index-ceiling padded-bits-per-line 8)) - (data (make-array (* padded-bytes-per-line height) - :element-type 'card8)) - (line-base 0) - (byte 0)) - (declare (type array-index bits-per-line bytes-per-line - padded-bits-per-line padded-bytes-per-line - line-base byte) - (type buffer-bytes data)) - (with-vector (data buffer-bytes) - (flet ((parse-hex (char) - (second - (assoc char - '((#\0 0) (#\1 1) (#\2 2) (#\3 3) - (#\4 4) (#\5 5) (#\6 6) (#\7 7) - (#\8 8) (#\9 9) (#\a 10) (#\b 11) - (#\c 12) (#\d 13) (#\e 14) (#\f 15)) - :test #'char-equal)))) - (declare (inline parse-hex)) - ;; Read data - ;; Note: using read-line instead of read-char would be 20% faster, - ;; but would cons a lot of garbage... - (dotimes (i height) - (dotimes (j bytes-per-line) - (loop (when (eql (read-char fstream) #\x) (return))) - (setf (aref data (index+ line-base byte)) - (index+ (index-ash (parse-hex (read-char fstream)) 4) - (parse-hex (read-char fstream)))) - (incf byte)) - (setq byte 0 - line-base (index+ line-base padded-bytes-per-line))))) - ;; Compensate for left-pad in width and x-hot - (index-decf width left-pad) - (when (and (getf properties :x-hot) (plusp (getf properties :x-hot))) - (index-decf (getf properties :x-hot) left-pad)) - (create-image - :width width :height height - :depth depth :bits-per-pixel bits-per-pixel - :data data :plist properties :format :z-pixmap - :bytes-per-line padded-bytes-per-line - :unit 32 :pad 32 :left-pad left-pad - :byte-lsb-first-p t :bit-lsb-first-p t)))))) - -(defun write-bitmap-file (pathname image &optional name) - ;; Writes an image to a C include file in standard X11 format - ;; NAME argument used for variable prefixes. Defaults to "image" - (declare (type (or pathname string stream) pathname) - (type image image) - (type (or null stringable) name)) - (unless (typep image 'image-x) - (setq image (copy-image image :result-type 'image-x))) - (let* ((plist (image-plist image)) - (name (or name (image-name image) 'image)) - (left-pad (image-x-left-pad image)) - (width (index+ (image-width image) left-pad)) - (height (image-height image)) - (depth - (if (eq (image-x-format image) :z-pixmap) - (image-depth image) - 1)) - (bits-per-pixel (image-x-bits-per-pixel image)) - (bits-per-line (index* width bits-per-pixel)) - (bytes-per-line (index-ceiling bits-per-line 8)) - (last (index* bytes-per-line height)) - (count 0)) - (declare (type list plist) - (type stringable name) - (type card8 left-pad) - (type card16 width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type image-depth depth) - (type array-index bits-per-line bytes-per-line count last)) - ;; Move x-hot by left-pad, if there is an x-hot, so image readers that - ;; don't know about left pad get the hot spot in the right place. We have - ;; already increased width by left-pad. - (when (getf plist :x-hot) - (setq plist (copy-list plist)) - (index-incf (getf plist :x-hot) left-pad)) - (with-image-data-buffer (data last) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - (image-x-unit image) (image-x-byte-lsb-first-p image) - (image-x-bit-lsb-first-p image) 32 t t) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (funcall - (symbol-function image-swap-function) (image-x-data image) - data 0 0 bytes-per-line (image-x-bytes-per-line image) - bytes-per-line height image-swap-lsb-first-p)) - (with-vector (data buffer-bytes) - (setq name (string-downcase (string name))) - (with-open-file (fstream pathname :direction :output) - (format fstream "#define ~a_width ~d~%" name width) - (format fstream "#define ~a_height ~d~%" name height) - (unless (= depth 1) - (format fstream "#define ~a_depth ~d~%" name depth)) - (unless (zerop left-pad) - (format fstream "#define ~a_left_pad ~d~%" name left-pad)) - (do ((prop plist (cddr prop))) - ((endp prop)) - (when (and (not (member (car prop) '(:width :height))) - (numberp (cadr prop))) - (format fstream "#define ~a_~a ~d~%" - name - (substitute - #\_ #\- (string-downcase (string (car prop))) - :test #'char=) - (cadr prop)))) - (format fstream "static char ~a_bits[] = {" name) - (dotimes (i height) - (dotimes (j bytes-per-line) - (when (zerop (index-mod count 15)) - (terpri fstream) - (write-char #\space fstream)) - (write-string "0x" fstream) - ;; Faster than (format fstream "0x~2,'0x," byte) - (let ((byte (aref data count)) - (translate "0123456789abcdef")) - (declare (type card8 byte)) - (write-char (char translate (ldb (byte 4 4) byte)) fstream) - (write-char (char translate (ldb (byte 4 0) byte)) fstream)) - (index-incf count) - (unless (index= count last) - (write-char #\, fstream)))) - (format fstream "};~%" fstream)))))) - -(defun bitmap-image (&optional plist &rest patterns) - ;; Create an image containg pattern - ;; PATTERNS are bit-vector constants (e.g. #*10101) - ;; If the first parameter is a list, its used as the image property-list. - (declare (type (or list bit-vector) plist) - (type list patterns)) ;; list of bitvector - (declare (clx-values image)) - (unless (listp plist) - (push plist patterns) - (setq plist nil)) - (let* ((width (length (first patterns))) - (height (length patterns)) - (bitarray (make-array (list height width) :element-type 'bit)) - (row 0)) - (declare (type card16 width height row) - (type pixarray-1 bitarray)) - (dolist (pattern patterns) - (declare (type simple-bit-vector pattern)) - (dotimes (col width) - (declare (type card16 col)) - (setf (aref bitarray row col) (the bit (aref pattern col)))) - (incf row)) - (create-image :width width :height height :plist plist :data bitarray))) - -(defun image-pixmap (drawable image &key gcontext width height depth) - ;; Create a pixmap containing IMAGE. Size defaults from the image. - ;; DEPTH is the pixmap depth. - ;; GCONTEXT is used for putting the image into the pixmap. - ;; If none is supplied, then one is created, used then freed. - (declare (type drawable drawable) - (type image image) - (type (or null gcontext) gcontext) - (type (or null card16) width height) - (type (or null card8) depth)) - (declare (clx-values pixmap)) - (let* ((image-width (image-width image)) - (image-height (image-height image)) - (image-depth (image-depth image)) - (width (or width image-width)) - (height (or height image-height)) - (depth (or depth image-depth)) - (pixmap (create-pixmap :drawable drawable - :width width - :height height - :depth depth)) - (gc (or gcontext (create-gcontext - :drawable pixmap - :foreground 1 - :background 0)))) - (unless (= depth image-depth) - (if (= image-depth 1) - (unless gcontext (xlib::required-arg gcontext)) - (error "Pixmap depth ~d incompatable with image depth ~d" - depth image-depth))) - (put-image pixmap gc image :x 0 :y 0 :bitmap-p (and (= image-depth 1) - gcontext)) - ;; Tile when image-width is less than the pixmap width, or - ;; the image-height is less than the pixmap height. - ;; ??? Would it be better to create a temporary pixmap and - ;; ??? let the server do the tileing? - (do ((x image-width (+ x image-width))) - ((>= x width)) - (copy-area pixmap gc 0 0 image-width image-height pixmap x 0) - (incf image-width image-width)) - (do ((y image-height (+ y image-height))) - ((>= y height)) - (copy-area pixmap gc 0 0 image-width image-height pixmap 0 y) - (incf image-height image-height)) - (unless gcontext (free-gcontext gc)) - pixmap)) - diff --git a/src/eclx/input.lisp b/src/eclx/input.lisp deleted file mode 100644 index 2ea8f2bdc..000000000 --- a/src/eclx/input.lisp +++ /dev/null @@ -1,1870 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11 - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -;;; -;;; Change history: -;;; -;;; Date Author Description -;;; ------------------------------------------------------------------------------------- -;;; 12/10/87 LGO Created -#+cmu -(ext:file-comment - "$Header$") - -(in-package :xlib) - -;; Event Resource -(defvar *event-free-list* nil) ;; List of unused (processed) events - -(eval-when (:execute :compile-toplevel :load-toplevel) -(defconstant +max-events+ 64) ;; Maximum number of events supported (the X11 alpha release only has 34) -(defvar *event-key-vector* (make-array +max-events+ :initial-element nil) - "Vector of event keys - See define-event") -) -(defvar *event-macro-vector* (make-array +max-events+ :initial-element nil) - "Vector of event handler functions - See declare-event") -(defvar *event-handler-vector* (make-array +max-events+ :initial-element nil) - "Vector of event handler functions - See declare-event") -(defvar *event-send-vector* (make-array +max-events+ :initial-element nil) - "Vector of event sending functions - See declare-event") - -(defun allocate-event () - (or (threaded-atomic-pop *event-free-list* reply-next reply-buffer) - (make-reply-buffer +replysize+))) - -(defun deallocate-event (reply-buffer) - (declare (type reply-buffer reply-buffer)) - (setf (reply-size reply-buffer) +replysize+) - (threaded-atomic-push reply-buffer *event-free-list* reply-next reply-buffer)) - -;; Extensions are handled as follows: -;; DEFINITION: Use DEFINE-EXTENSION -;; -;; CODE: Use EXTENSION-CODE to get the X11 opcode for an extension. -;; This looks up the code on the display-extension-alist. -;; -;; EVENTS: Use DECLARE-EVENT to define events. This calls ALLOCATE-EXTENSION-EVENT-CODE -;; at LOAD time to define an internal event-code number -;; (stored in the 'event-code property of the event-name) -;; used to index the following vectors: -;; *event-key-vector* Used for getting the event-key -;; *event-macro-vector* Used for getting the event-parameter getting macros -;; -;; The GET-INTERNAL-EVENT-CODE function can be called at runtime to convert -;; a server event-code into an internal event-code used to index the following -;; vectors: -;; *event-handler-vector* Used for getting the event-handler function -;; *event-send-vector* Used for getting the event-sending function -;; -;; The GET-EXTERNAL-EVENT-CODE function can be called at runtime to convert -;; internal event-codes to external (server) codes. -;; -;; ERRORS: Use DEFINE-ERROR to define new error decodings. -;; - - -;; Any event-code greater than 34 is for an extension -(defparameter *first-extension-event-code* 35) - -(defvar *extensions* nil) ;; alist of (extension-name-symbol events errors) - -(defmacro define-extension (name &key events errors) - ;; Define extension NAME with EVENTS and ERRORS. - ;; Note: The case of NAME is important. - ;; To define the request, Use: - ;; (with-buffer-request (display (extension-opcode ,name)) ,@body) - ;; See the REQUESTS file for lots of examples. - ;; To define event handlers, use declare-event. - ;; To define error handlers, use declare-error and define-condition. - (declare (type stringable name) - (type list events errors)) - (let ((name-symbol (kintern name)) ;; Intern name in the keyword package - (event-list (mapcar #'canonicalize-event-name events))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (setq *extensions* (cons (list ',name-symbol ',event-list ',errors) - (delete ',name-symbol *extensions* :key #'car)))))) - -(eval-when (:compile-toplevel :execute :load-toplevel) -(defun canonicalize-event-name (event) - ;; Returns the event name keyword given an event name stringable - (declare (type stringable event)) - (declare (clx-values event-key)) - (kintern event)) -) ;; end eval-when - -(eval-when (:compile-toplevel :execute :load-toplevel) -(defun allocate-extension-event-code (name) - ;; Allocate an event-code for an extension - ;; This is executed at COMPILE and LOAD time from DECLARE-EVENT. - ;; The event-code is used at compile-time by macros to index the following vectors: - ;; *event-key-vector* *event-macro-vector* *event-handler-vector* *event-send-vector* - (let ((event-code (get name 'event-code))) - (declare (type (or null card8) event-code)) - (unless event-code - ;; First ensure the name is for a declared extension - (unless (dolist (extension *extensions*) - (when (member name (second extension)) - (return t))) - (x-type-error name 'event-key)) - (setq event-code (position nil *event-key-vector* - :start *first-extension-event-code*)) - (setf (svref *event-key-vector* event-code) name) - (setf (get name 'event-code) event-code)) - event-code)) -) ;; end eval-when - -(defun get-internal-event-code (display code) - ;; Given an X11 event-code, return the internal event-code. - ;; The internal event-code is used for indexing into the following vectors: - ;; *event-key-vector* *event-handler-vector* *event-send-vector* - ;; Returns NIL when the event-code is for an extension that isn't handled. - (declare (type display display) - (type card8 code)) - (declare (clx-values (or null card8))) - (setq code (logand #x7f code)) - (if (< code *first-extension-event-code*) - code - (let* ((code-offset (- code *first-extension-event-code*)) - (event-extensions (display-event-extensions display)) - (code (if (< code-offset (length event-extensions)) - (aref event-extensions code-offset) - 0))) - (declare (type card8 code-offset code)) - (when (zerop code) - (x-cerror "Ignore the event" - 'unimplemented-event :event-code code :display display)) - code))) - -(defun get-external-event-code (display event) - ;; Given an X11 event name, return the event-code - (declare (type display display) - (type event-key event)) - (declare (clx-values card8)) - (let ((code (get-event-code event))) - (declare (type (or null card8) code)) - (when (>= code *first-extension-event-code*) - (setq code (+ *first-extension-event-code* - (or (position code (display-event-extensions display)) - (x-error 'undefined-event :display display :event-name event))))) - code)) - -(defmacro extension-opcode (display name) - ;; Returns the major opcode for extension NAME. - ;; This is a macro to enable NAME to be interned for fast run-time - ;; retrieval. - ;; Note: The case of NAME is important. - (let ((name-symbol (kintern name))) ;; Intern name in the keyword package - `(or (second (assoc ',name-symbol (display-extension-alist ,display))) - (x-error 'absent-extension :name ',name-symbol :display ,display)))) - -(defun initialize-extensions (display) - ;; Initialize extensions for DISPLAY - (let ((event-extensions (make-array 16 :element-type 'card8 :initial-element 0)) - (extension-alist nil)) - (declare (type vector event-extensions) - (type list extension-alist)) - (dolist (extension *extensions*) - (let ((name (first extension)) - (events (second extension))) - (declare (type keyword name) - (type list events)) - (multiple-value-bind (major-opcode first-event first-error) - (query-extension display name) - (declare (type (or null card8) major-opcode first-event first-error)) - (when (and major-opcode (plusp major-opcode)) - (push (list name major-opcode first-event first-error) - extension-alist) - (when (plusp first-event) ;; When there are extension events - ;; Grow extension vector when needed - (let ((max-event (- (+ first-event (length events)) - *first-extension-event-code*))) - (declare (type card8 max-event)) - (when (>= max-event (length event-extensions)) - (let ((new-extensions (make-array (+ max-event 16) :element-type 'card8 - :initial-element 0))) - (declare (type vector new-extensions)) - (replace new-extensions event-extensions) - (setq event-extensions new-extensions)))) - (dolist (event events) - (declare (type symbol event)) - (setf (aref event-extensions (- first-event *first-extension-event-code*)) - (get-event-code event)) - (incf first-event))))))) - (setf (display-event-extensions display) event-extensions) - (setf (display-extension-alist display) extension-alist))) - -;; -;; Reply handlers -;; - -(defvar *pending-command-free-list* nil) - -(defun start-pending-command (display) - (declare (type display display)) - (let ((pending-command (or (threaded-atomic-pop *pending-command-free-list* - pending-command-next pending-command) - (make-pending-command)))) - (declare (type pending-command pending-command)) - (setf (pending-command-reply-buffer pending-command) nil) - (setf (pending-command-process pending-command) (current-process)) - (setf (pending-command-sequence pending-command) - (ldb (byte 16 0) (1+ (buffer-request-number display)))) - ;; Add the pending command to the end of the threaded list of pending - ;; commands for the display. - (with-event-queue-internal (display) - (threaded-nconc pending-command (display-pending-commands display) - pending-command-next pending-command)) - pending-command)) - -(defun stop-pending-command (display pending-command) - (declare (type display display) - (type pending-command pending-command)) - (with-event-queue-internal (display) - ;; Remove the pending command from the threaded list of pending commands - ;; for the display. - (threaded-delete pending-command (display-pending-commands display) - pending-command-next pending-command) - ;; Deallocate any reply buffers in this pending command - (loop - (let ((reply-buffer - (threaded-pop (pending-command-reply-buffer pending-command) - reply-next reply-buffer))) - (declare (type (or null reply-buffer) reply-buffer)) - (if reply-buffer - (deallocate-reply-buffer reply-buffer) - (return nil))))) - ;; Clear pointers to help the Garbage Collector - (setf (pending-command-process pending-command) nil) - ;; Deallocate this pending-command - (threaded-atomic-push pending-command *pending-command-free-list* - pending-command-next pending-command) - nil) - -;;; - -(defvar *reply-buffer-free-lists* (make-array 32 :initial-element nil)) - -(defun allocate-reply-buffer (size) - (declare (type array-index size)) - (if (index<= size +replysize+) - (allocate-event) - (let ((index (integer-length (index1- size)))) - (declare (type array-index index)) - (or (threaded-atomic-pop (svref *reply-buffer-free-lists* index) - reply-next reply-buffer) - (make-reply-buffer (index-ash 1 index)))))) - -(defun deallocate-reply-buffer (reply-buffer) - (declare (type reply-buffer reply-buffer)) - (let ((size (reply-size reply-buffer))) - (declare (type array-index size)) - (if (index<= size +replysize+) - (deallocate-event reply-buffer) - (let ((index (integer-length (index1- size)))) - (declare (type array-index index)) - (threaded-atomic-push reply-buffer (svref *reply-buffer-free-lists* index) - reply-next reply-buffer))))) - -;;; - -(defun read-error-input (display sequence reply-buffer token) - (declare (type display display) - (type reply-buffer reply-buffer) - (type card16 sequence)) - (tagbody - start - (with-event-queue-internal (display) - (let ((command - ;; Find any pending command with this sequence number. - (threaded-dolist (pending-command (display-pending-commands display) - pending-command-next pending-command) - (when (= (pending-command-sequence pending-command) sequence) - (return pending-command))))) - (declare (type (or null pending-command) command)) - (cond ((not (null command)) - ;; Give this reply to the pending command - (threaded-nconc reply-buffer (pending-command-reply-buffer command) - reply-next reply-buffer) - (process-wakeup (pending-command-process command))) - ((member :immediately (display-report-asynchronous-errors display)) - ;; No pending command and we should report the error immediately - (go report-error)) - (t - ;; No pending command found, count this as an asynchronous error - (threaded-nconc reply-buffer (display-asynchronous-errors display) - reply-next reply-buffer))))) - (return-from read-error-input nil) - report-error - (note-input-complete display token) - (apply #'report-error display - (prog1 (make-error display reply-buffer t) - (deallocate-event reply-buffer))))) - -(defun read-reply-input (display sequence length reply-buffer) - (declare (type display display) - (type (or null reply-buffer) reply-buffer) - (type card16 sequence) - (type array-index length)) - (unwind-protect - (progn - (when (index< +replysize+ length) - (let ((repbuf nil)) - (declare (type (or null reply-buffer) repbuf)) - (unwind-protect - (progn - (setq repbuf (allocate-reply-buffer length)) - (buffer-replace (reply-ibuf8 repbuf) (reply-ibuf8 reply-buffer) - 0 +replysize+) - (deallocate-event (shiftf reply-buffer repbuf nil))) - (when repbuf - (deallocate-reply-buffer repbuf)))) - (when (buffer-input display (reply-ibuf8 reply-buffer) +replysize+ length) - (return-from read-reply-input t)) - (setf (reply-data-size reply-buffer) length)) - (with-event-queue-internal (display) - ;; Find any pending command with this sequence number. - (let ((command - (threaded-dolist (pending-command (display-pending-commands display) - pending-command-next pending-command) - (when (= (pending-command-sequence pending-command) sequence) - (return pending-command))))) - (declare (type (or null pending-command) command)) - (when command - ;; Give this reply to the pending command - (threaded-nconc (shiftf reply-buffer nil) - (pending-command-reply-buffer command) - reply-next reply-buffer) - (process-wakeup (pending-command-process command))))) - nil) - (when reply-buffer - (deallocate-reply-buffer reply-buffer)))) - -(defun read-event-input (display code reply-buffer) - (declare (type display display) - (type card8 code) - (type reply-buffer reply-buffer)) - ;; Push the event in the input buffer on the display's event queue - (setf (event-code reply-buffer) - (get-internal-event-code display code)) - (enqueue-event reply-buffer display) - nil) - -(defun note-input-complete (display token) - (declare (type display display)) - (when (eq (display-input-in-progress display) token) - ;; Indicate that input is no longer in progress - (setf (display-input-in-progress display) nil) - ;; Let the event process get the first chance to do input - (let ((process (display-event-process display))) - (when (not (null process)) - (process-wakeup process))) - ;; Then give processes waiting for command responses a chance - (unless (display-input-in-progress display) - (with-event-queue-internal (display) - (threaded-dolist (command (display-pending-commands display) - pending-command-next pending-command) - (process-wakeup (pending-command-process command))))))) - -(defun read-input (display timeout force-output-p predicate &rest predicate-args) - (declare (type display display) - (type (or null number) timeout) - (type generalized-boolean force-output-p) - (dynamic-extent predicate-args)) - (declare (type function predicate) - (dynamic-extent predicate)) - (let ((reply-buffer nil) - (token (or (current-process) (cons nil nil)))) - (declare (type (or null reply-buffer) reply-buffer)) - (unwind-protect - (tagbody - loop - (when (display-dead display) - (x-error 'closed-display :display display)) - (when (apply predicate predicate-args) - (return-from read-input nil)) - ;; Check and see if we have to force output - (when (and force-output-p - (or (and (not (eq (display-input-in-progress display) token)) - (not (conditional-store - (display-input-in-progress display) nil token))) - (null (buffer-listen display)))) - (go force-output)) - ;; Ensure that ony one process is reading input. - (unless (or (eq (display-input-in-progress display) token) - (conditional-store (display-input-in-progress display) nil token)) - (if (eql timeout 0) - (return-from read-input :timeout) - ;;; XXX [pve]: this is the only location that has - ;;; process-block. I think we can rewrite this into something - ;;; more appropriate - (apply #'process-block "CLX Input Lock" - #'(lambda (display predicate &rest predicate-args) - (declare (type display display) - (dynamic-extent predicate-args) - (type function predicate) - (dynamic-extent predicate)) - (or (apply predicate predicate-args) - (null (display-input-in-progress display)) - (not (null (display-dead display))))) - display predicate predicate-args)) - (go loop)) - ;; Now start gobbling. - (setq reply-buffer (allocate-event)) - (with-buffer-input (reply-buffer :sizes (8 16 32)) - (let ((type 0)) - (declare (type card8 type)) - ;; Wait for input before we disallow aborts. - (unless (eql timeout 0) - (let ((eof-p (buffer-input-wait display timeout))) - (when eof-p (return-from read-input eof-p)))) - (without-aborts - (let ((eof-p (buffer-input display buffer-bbuf 0 +replysize+ - (if force-output-p 0 timeout)))) - (when eof-p - (when (eq eof-p :timeout) - (if force-output-p - (go force-output) - (return-from read-input :timeout))) - (setf (display-dead display) t) - (return-from read-input eof-p))) - (setf (reply-data-size reply-buffer) +replysize+) - (when (= (the card8 (setq type (read-card8 0))) 1) - ;; Normal replies can be longer than +replysize+, so we - ;; have to handle them while aborts are still disallowed. - (let ((value - (read-reply-input - display (read-card16 2) - (index+ +replysize+ (index* (read-card32 4) 4)) - (shiftf reply-buffer nil)))) - (when value - (return-from read-input value)) - (go loop)))) - (if (zerop type) - (read-error-input - display (read-card16 2) (shiftf reply-buffer nil) token) - (read-event-input - display (read-card8 0) (shiftf reply-buffer nil))))) - (go loop) - force-output - (note-input-complete display token) - (display-force-output display) - (setq force-output-p nil) - (go loop)) - (when (not (null reply-buffer)) - (deallocate-reply-buffer reply-buffer)) - (note-input-complete display token)))) - -(defun report-asynchronous-errors (display mode) - (when (and (display-asynchronous-errors display) - (member mode (display-report-asynchronous-errors display))) - (let ((aborted t)) - (unwind-protect - (loop - (let ((error - (with-event-queue-internal (display) - (threaded-pop (display-asynchronous-errors display) - reply-next reply-buffer)))) - (declare (type (or null reply-buffer) error)) - (if error - (apply #'report-error display - (prog1 (make-error display error t) - (deallocate-event error))) - (return (setq aborted nil))))) - ;; If we get aborted out of this, deallocate all outstanding asynchronous - ;; errors. - (when aborted - (with-event-queue-internal (display) - (loop - (let ((reply-buffer - (threaded-pop (display-asynchronous-errors display) - reply-next reply-buffer))) - (declare (type (or null reply-buffer) reply-buffer)) - (if reply-buffer - (deallocate-event reply-buffer) - (return nil)))))))))) - -(defun wait-for-event (display timeout force-output-p) - (declare (type display display) - (type (or null number) timeout) - (type generalized-boolean force-output-p)) - (let ((event-process-p (not (eql timeout 0)))) - (declare (type generalized-boolean event-process-p)) - (unwind-protect - (loop - (when event-process-p - (conditional-store (display-event-process display) nil (current-process))) - (let ((eof (read-input - display timeout force-output-p - #'(lambda (display) - (declare (type display display)) - (or (not (null (display-new-events display))) - (and (display-asynchronous-errors display) - (member :before-event-handling - (display-report-asynchronous-errors display)) - t))) - display))) - (when eof (return eof))) - ;; Report asynchronous errors here if the user wants us to. - (when event-process-p - (report-asynchronous-errors display :before-event-handling)) - (when (not (null (display-new-events display))) - (return nil))) - (when (and event-process-p - (eq (display-event-process display) (current-process))) - (setf (display-event-process display) nil))))) - -(defun read-reply (display pending-command) - (declare (type display display) - (type pending-command pending-command)) - (loop - (when (read-input display nil nil - #'(lambda (pending-command) - (declare (type pending-command pending-command)) - (not (null (pending-command-reply-buffer pending-command)))) - pending-command) - (x-error 'closed-display :display display)) - (let ((reply-buffer - (with-event-queue-internal (display) - (threaded-pop (pending-command-reply-buffer pending-command) - reply-next reply-buffer)))) - (declare (type reply-buffer reply-buffer)) - ;; Check for error. - (with-buffer-input (reply-buffer) - (ecase (read-card8 0) - (0 (apply #'report-error display - (prog1 (make-error display reply-buffer nil) - (deallocate-reply-buffer reply-buffer)))) - (1 (return reply-buffer))))))) - -;;; - -(defun event-listen (display &optional (timeout 0)) - (declare (type display display) - (type (or null number) timeout) - (clx-values number-of-events-queued eof-or-timeout)) - ;; Returns the number of events queued locally, if any, else nil. Hangs - ;; waiting for events, forever if timeout is nil, else for the specified - ;; number of seconds. - (let* ((current-event-symbol (car (display-current-event-symbol display))) - (current-event (and (boundp current-event-symbol) - (symbol-value current-event-symbol))) - (queue (if current-event - (reply-next (the reply-buffer current-event)) - (display-event-queue-head display)))) - (declare (type symbol current-event-symbol) - (type (or null reply-buffer) current-event queue)) - (if queue - (values - (with-event-queue-internal (display :timeout timeout) - (threaded-length queue reply-next reply-buffer)) - nil) - (with-event-queue (display :timeout timeout :inline t) - (let ((eof-or-timeout (wait-for-event display timeout nil))) - (if eof-or-timeout - (values nil eof-or-timeout) - (values - (with-event-queue-internal (display :timeout timeout) - (threaded-length (display-new-events display) - reply-next reply-buffer)) - nil))))))) - -(defun queue-event (display event-key &rest args &key append-p send-event-p &allow-other-keys) - ;; The event is put at the head of the queue if append-p is nil, else the tail. - ;; Additional arguments depend on event-key, and are as specified above with - ;; declare-event, except that both resource-ids and resource objects are accepted - ;; in the event components. - (declare (type display display) - (type event-key event-key) - (type generalized-boolean append-p send-event-p) - (dynamic-extent args)) - (unless (get event-key 'event-code) - (x-type-error event-key 'event-key)) - (let* ((event (allocate-event)) - (buffer (reply-ibuf8 event)) - (event-code (get event-key 'event-code))) - (declare (type reply-buffer event) - (type buffer-bytes buffer) - (type (or null card8) event-code)) - (unless event-code (x-type-error event-key 'event-key)) - (setf (event-code event) event-code) - (with-display (display) - (apply (svref *event-send-vector* event-code) display args) - (buffer-replace buffer - (display-obuf8 display) - 0 - +replysize+ - (index+ 12 (buffer-boffset display))) - (setf (aref buffer 0) (if send-event-p (logior event-code #x80) event-code) - (aref buffer 2) 0 - (aref buffer 3) 0)) - (with-event-queue (display) - (if append-p - (enqueue-event event display) - (with-event-queue-internal (display) - (threaded-requeue event - (display-event-queue-head display) - (display-event-queue-tail display) - reply-next reply-buffer)))))) - -(defun enqueue-event (new-event display) - (declare (type reply-buffer new-event) - (type display display)) - ;; Place EVENT at the end of the event queue for DISPLAY - (let* ((event-code (event-code new-event)) - (event-key (and (index< event-code (length *event-key-vector*)) - (svref *event-key-vector* event-code)))) - (declare (type array-index event-code) - (type (or null keyword) event-key)) - (if (null event-key) - (unwind-protect - (cerror "Ignore this event" "No handler for ~s event" event-key) - (deallocate-event new-event)) - (with-event-queue-internal (display) - (threaded-enqueue new-event - (display-event-queue-head display) - (display-event-queue-tail display) - reply-next reply-buffer) - (unless (display-new-events display) - (setf (display-new-events display) new-event)))))) - - -(defmacro define-event (name code) - `(eval-when (:execute :compile-toplevel :load-toplevel) - (setf (svref *event-key-vector* ,code) ',name) - (setf (get ',name 'event-code) ,code))) - -;; Event names. Used in "type" field in XEvent structures. Not to be -;; confused with event masks above. They start from 2 because 0 and 1 -;; are reserved in the protocol for errors and replies. */ - -(define-event :key-press 2) -(define-event :key-release 3) -(define-event :button-press 4) -(define-event :button-release 5) -(define-event :motion-notify 6) -(define-event :enter-notify 7) -(define-event :leave-notify 8) -(define-event :focus-in 9) -(define-event :focus-out 10) -(define-event :keymap-notify 11) -(define-event :exposure 12) -(define-event :graphics-exposure 13) -(define-event :no-exposure 14) -(define-event :visibility-notify 15) -(define-event :create-notify 16) -(define-event :destroy-notify 17) -(define-event :unmap-notify 18) -(define-event :map-notify 19) -(define-event :map-request 20) -(define-event :reparent-notify 21) -(define-event :configure-notify 22) -(define-event :configure-request 23) -(define-event :gravity-notify 24) -(define-event :resize-request 25) -(define-event :circulate-notify 26) -(define-event :circulate-request 27) -(define-event :property-notify 28) -(define-event :selection-clear 29) -(define-event :selection-request 30) -(define-event :selection-notify 31) -(define-event :colormap-notify 32) -(define-event :client-message 33) -(define-event :mapping-notify 34) - - -(defmacro declare-event (event-codes &body declares &environment env) - ;; Used to indicate the keyword arguments for handler functions in - ;; process-event and event-case. - ;; Generates the functions used in SEND-EVENT. - ;; A compiler warning is printed when all of EVENT-CODES are not - ;; defined by a preceding DEFINE-EXTENSION. - ;; The body is a list of declarations, each of which has the form: - ;; (type . items) Where type is a data-type, and items is a list of - ;; symbol names. The item order corresponds to the order of fields - ;; in the event sent by the server. An item may be a list of items. - ;; In this case, each item is aliased to the same event field. - ;; This is used to give all events an EVENT-WINDOW item. - ;; See the INPUT file for lots of examples. - (declare (type (or keyword list) event-codes) - (type (alist (field-type symbol) (field-names list)) - declares)) - (when (atom event-codes) (setq event-codes (list event-codes))) - (setq event-codes (mapcar #'canonicalize-event-name event-codes)) - (let* ((keywords nil) - (name (first event-codes)) - (get-macro (xintern name '-event-get-macro)) - (get-function (xintern name '-event-get)) - (put-function (xintern name '-event-put))) - (multiple-value-bind (get-code get-index get-sizes) - (get-put-items - 2 declares nil - #'(lambda (type index item args) - (flet ((event-get (type index item args) - (unless (member type '(pad8 pad16)) - `(,(kintern item) - (,(getify type) ,index ,@args))))) - (if (atom item) - (event-get type index item args) - (mapcan #'(lambda (item) - (event-get type index item args)) - item))))) - (declare (ignore get-index)) - (multiple-value-bind (put-code put-index put-sizes) - (get-put-items - 2 declares t - #'(lambda (type index item args) - (unless (member type '(pad8 pad16)) - (if (atom item) - (progn - (push item keywords) - `((,(putify type) ,index ,item ,@args))) - (let ((names (mapcar #'(lambda (name) (kintern name)) - item))) - (setq keywords (append item keywords)) - `((,(putify type) ,index - (check-consistency ',names ,@item) ,@args))))))) - (declare (ignore put-index)) - `(within-definition (,name declare-event) - (defun ,get-macro (display event-key variable) - ;; Note: we take pains to macroexpand the get-code here to enable application - ;; code to be compiled without having the CLX macros file loaded. - `(let ((%buffer ,display)) - (declare (ignorable %buffer)) - ,(getf `(:display (the display ,display) - :event-key (the keyword ,event-key) - :event-code (the card8 (logand #x7f (read-card8 0))) - :send-event-p (logbitp 7 (read-card8 0)) - ,@',(mapcar #'(lambda (form) - (clx-macroexpand form env)) - get-code)) - variable))) - - (defun ,get-function (display event handler) - (declare (type display display) - (type reply-buffer event)) - (declare (type function handler) - (dynamic-extent handler)) - (reading-event (event :display display :sizes (8 16 ,@get-sizes)) - (funcall handler - :display display - :event-key (svref *event-key-vector* (event-code event)) - :event-code (logand #x7f (card8-get 0)) - :send-event-p (logbitp 7 (card8-get 0)) - ,@get-code))) - - (defun ,put-function (display &key ,@(setq keywords (nreverse keywords)) - &allow-other-keys) - (declare (type display display)) - ,(when (member 'sequence keywords) - `(unless sequence (setq sequence (display-request-number display)))) - (with-buffer-output (display :sizes ,put-sizes - :index (index+ (buffer-boffset display) 12)) - ,@put-code)) - - ,@(mapcar #'(lambda (name) - (allocate-extension-event-code name) - `(let ((event-code (or (get ',name 'event-code) - (allocate-extension-event-code ',name)))) - (setf (svref *event-macro-vector* event-code) - (function ,get-macro)) - (setf (svref *event-handler-vector* event-code) - (function ,get-function)) - (setf (svref *event-send-vector* event-code) - (function ,put-function)))) - event-codes) - ',name))))) - -(defun check-consistency (names &rest args) - ;; Ensure all args are nil or have the same value. - ;; Returns the consistent non-nil value. - (let ((value (car args))) - (dolist (arg (cdr args)) - (if value - (when (and arg (not (eq arg value))) - (x-error 'inconsistent-parameters - :parameters (mapcan #'list names args))) - (setq value arg))) - value)) - -(declare-event (:key-press :key-release :button-press :button-release) - ;; for key-press and key-release, code is the keycode - ;; for button-press and button-release, code is the button number - (data code) - (card16 sequence) - ((or null card32) time) - (window root (window event-window)) - ((or null window) child) - (int16 root-x root-y x y) - (card16 state) - (boolean same-screen-p) - ) - -(declare-event :motion-notify - ((data boolean) hint-p) - (card16 sequence) - ((or null card32) time) - (window root (window event-window)) - ((or null window) child) - (int16 root-x root-y x y) - (card16 state) - (boolean same-screen-p)) - -(declare-event (:enter-notify :leave-notify) - ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual)) kind) - (card16 sequence) - ((or null card32) time) - (window root (window event-window)) - ((or null window) child) - (int16 root-x root-y x y) - (card16 state) - ((member8 :normal :grab :ungrab) mode) - ((bit 0) focus-p) - ((bit 1) same-screen-p)) - -(declare-event (:focus-in :focus-out) - ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual - :pointer :pointer-root :none)) - kind) - (card16 sequence) - (window (window event-window)) - ((member8 :normal :while-grabbed :grab :ungrab) mode)) - -(declare-event :keymap-notify - ((bit-vector256 0) keymap)) - -(declare-event :exposure - (card16 sequence) - (window (window event-window)) - (card16 x y width height count)) - -(declare-event :graphics-exposure - (card16 sequence) - (drawable (drawable event-window)) - (card16 x y width height) - (card16 minor) ;; Minor opcode - (card16 count) - (card8 major)) - -(declare-event :no-exposure - (card16 sequence) - (drawable (drawable event-window)) - (card16 minor) - (card8 major)) - -(declare-event :visibility-notify - (card16 sequence) - (window (window event-window)) - ((member8 :unobscured :partially-obscured :fully-obscured) state)) - -(declare-event :create-notify - (card16 sequence) - (window (parent event-window) window) - (int16 x y) - (card16 width height border-width) - (boolean override-redirect-p)) - -(declare-event :destroy-notify - (card16 sequence) - (window event-window window)) - -(declare-event :unmap-notify - (card16 sequence) - (window event-window window) - (boolean configure-p)) - -(declare-event :map-notify - (card16 sequence) - (window event-window window) - (boolean override-redirect-p)) - -(declare-event :map-request - (card16 sequence) - (window (parent event-window) window)) - -(declare-event :reparent-notify - (card16 sequence) - (window event-window window parent) - (int16 x y) - (boolean override-redirect-p)) - -(declare-event :configure-notify - (card16 sequence) - (window event-window window) - ((or null window) above-sibling) - (int16 x y) - (card16 width height border-width) - (boolean override-redirect-p)) - -(declare-event :configure-request - ((data (member8 :above :below :top-if :bottom-if :opposite)) stack-mode) - (card16 sequence) - (window (parent event-window) window) - ((or null window) above-sibling) - (int16 x y) - (card16 width height border-width value-mask)) - -(declare-event :gravity-notify - (card16 sequence) - (window event-window window) - (int16 x y)) - -(declare-event :resize-request - (card16 sequence) - (window (window event-window)) - (card16 width height)) - -(declare-event :circulate-notify - (card16 sequence) - (window event-window window parent) - ((member16 :top :bottom) place)) - -(declare-event :circulate-request - (card16 sequence) - (window (parent event-window) window) - (pad16 1 2) - ((member16 :top :bottom) place)) - -(declare-event :property-notify - (card16 sequence) - (window (window event-window)) - (keyword atom) ;; keyword - ((or null card32) time) - ((member8 :new-value :deleted) state)) - -(declare-event :selection-clear - (card16 sequence) - ((or null card32) time) - (window (window event-window)) - (keyword selection) ;; keyword - ) - -(declare-event :selection-request - (card16 sequence) - ((or null card32) time) - (window (window event-window) requestor) - (keyword selection target) - ((or null keyword) property) - ) - -(declare-event :selection-notify - (card16 sequence) - ((or null card32) time) - (window (window event-window)) - (keyword selection target) - ((or null keyword) property) - ) - -(declare-event :colormap-notify - (card16 sequence) - (window (window event-window)) - ((or null colormap) colormap) - (boolean new-p installed-p)) - -(declare-event :client-message - (data format) - (card16 sequence) - (window (window event-window)) - (keyword type) - ((client-message-sequence format) data)) - -(declare-event :mapping-notify - (card16 sequence) - ((member8 :modifier :keyboard :pointer) request) - (card8 start) ;; first key-code - (card8 count)) - - -;; -;; EVENT-LOOP -;; - -(defun event-loop-setup (display) - (declare (type display display) - (clx-values progv-vars progv-vals - current-event-symbol current-event-discarded-p-symbol)) - (let* ((progv-vars (display-current-event-symbol display)) - (current-event-symbol (first progv-vars)) - (current-event-discarded-p-symbol (second progv-vars))) - (declare (type list progv-vars) - (type symbol current-event-symbol current-event-discarded-p-symbol)) - (values - progv-vars - (list (if (boundp current-event-symbol) - ;; The current event is already bound, so bind it to the next - ;; event. - (let ((event (symbol-value current-event-symbol))) - (declare (type (or null reply-buffer) event)) - (and event (reply-next (the reply-buffer event)))) - ;; The current event isn't bound, so bind it to the head of the - ;; event queue. - (display-event-queue-head display)) - nil) - current-event-symbol - current-event-discarded-p-symbol))) - -(defun event-loop-step-before (display timeout force-output-p current-event-symbol) - (declare (type display display) - (type (or null number) timeout) - (type generalized-boolean force-output-p) - (type symbol current-event-symbol) - (clx-values event eof-or-timeout)) - (unless (symbol-value current-event-symbol) - (let ((eof-or-timeout (wait-for-event display timeout force-output-p))) - (when eof-or-timeout - (return-from event-loop-step-before (values nil eof-or-timeout)))) - (setf (symbol-value current-event-symbol) (display-new-events display))) - (let ((event (symbol-value current-event-symbol))) - (declare (type reply-buffer event)) - (with-event-queue-internal (display) - (when (eq event (display-new-events display)) - (setf (display-new-events display) (reply-next event)))) - (values event nil))) - -(defun dequeue-event (display event) - (declare (type display display) - (type reply-buffer event) - (clx-values next)) - ;; Remove the current event from the event queue - (with-event-queue-internal (display) - (let ((next (reply-next event)) - (head (display-event-queue-head display))) - (declare (type (or null reply-buffer) next head)) - (when (eq event (display-new-events display)) - (setf (display-new-events display) next)) - (cond ((eq event head) - (threaded-dequeue (display-event-queue-head display) - (display-event-queue-tail display) - reply-next reply-buffer)) - ((null head) - (setq next nil)) - (t - (do* ((previous head current) - (current (reply-next previous) (reply-next previous))) - ((or (null current) (eq event current)) - (when (eq event current) - (when (eq current (display-event-queue-tail display)) - (setf (display-event-queue-tail display) previous)) - (setf (reply-next previous) next))) - (declare (type reply-buffer previous) - (type (or null reply-buffer) current))))) - next))) - -(defun event-loop-step-after - (display event discard-p current-event-symbol current-event-discarded-p-symbol - &optional aborted) - (declare (type display display) - (type reply-buffer event) - (type generalized-boolean discard-p aborted) - (type symbol current-event-symbol current-event-discarded-p-symbol)) - (when (and discard-p - (not aborted) - (not (symbol-value current-event-discarded-p-symbol))) - (discard-current-event display)) - (let ((next (reply-next event))) - (declare (type (or null reply-buffer) next)) - (when (symbol-value current-event-discarded-p-symbol) - (setf (symbol-value current-event-discarded-p-symbol) nil) - (setq next (dequeue-event display event)) - (deallocate-event event)) - (setf (symbol-value current-event-symbol) next))) - -(defmacro event-loop ((display event timeout force-output-p discard-p) &body body) - ;; Bind EVENT to the events for DISPLAY. - ;; This is the "GUTS" of process-event and event-case. - `(let ((.display. ,display) - (.timeout. ,timeout) - (.force-output-p. ,force-output-p) - (.discard-p. ,discard-p)) - (declare (type display .display.) - (type (or null number) .timeout.) - (type generalized-boolean .force-output-p. .discard-p.)) - (with-event-queue (.display. ,@(and timeout `(:timeout .timeout.))) - (multiple-value-bind (.progv-vars. .progv-vals. - .current-event-symbol. .current-event-discarded-p-symbol.) - (event-loop-setup .display.) - (declare (type list .progv-vars. .progv-vals.) - (type symbol .current-event-symbol. .current-event-discarded-p-symbol.)) - (progv .progv-vars. .progv-vals. - (loop - (multiple-value-bind (.event. .eof-or-timeout.) - (event-loop-step-before - .display. .timeout. .force-output-p. - .current-event-symbol.) - (declare (type (or null reply-buffer) .event.)) - (when (null .event.) (return (values nil .eof-or-timeout.))) - (let ((.aborted. t)) - (unwind-protect - (progn - (let ((,event .event.)) - (declare (type reply-buffer ,event)) - ,@body) - (setq .aborted. nil)) - (event-loop-step-after - .display. .event. .discard-p. - .current-event-symbol. .current-event-discarded-p-symbol. - .aborted.)))))))))) - -(defun discard-current-event (display) - ;; Discard the current event for DISPLAY. - ;; Returns NIL when the event queue is empty, else T. - ;; To ensure events aren't ignored, application code should only call - ;; this when throwing out of event-case or process-next-event, or from - ;; inside even-case, event-cond or process-event when :peek-p is T and - ;; :discard-p is NIL. - (declare (type display display) - (clx-values generalized-boolean)) - (let* ((symbols (display-current-event-symbol display)) - (event - (let ((current-event-symbol (first symbols))) - (declare (type symbol current-event-symbol)) - (when (boundp current-event-symbol) - (symbol-value current-event-symbol))))) - (declare (type list symbols) - (type (or null reply-buffer) event)) - (unless (null event) - ;; Set the discarded-p flag - (let ((current-event-discarded-p-symbol (second symbols))) - (declare (type symbol current-event-discarded-p-symbol)) - (when (boundp current-event-discarded-p-symbol) - (setf (symbol-value current-event-discarded-p-symbol) t))) - ;; Return whether the event queue is empty - (not (null (reply-next (the reply-buffer event))))))) - -;; -;; PROCESS-EVENT -;; -(defun process-event (display &key handler timeout peek-p discard-p (force-output-p t)) - ;; If force-output-p is true, first invokes display-force-output. Invokes handler - ;; on each queued event until handler returns non-nil, and that returned object is - ;; then returned by process-event. If peek-p is true, then the event is not - ;; removed from the queue. If discard-p is true, then events for which handler - ;; returns nil are removed from the queue, otherwise they are left in place. Hangs - ;; until non-nil is generated for some event, or for the specified timeout (in - ;; seconds, if given); however, it is acceptable for an implementation to wait only - ;; once on network data, and therefore timeout prematurely. Returns nil on - ;; timeout. If handler is a sequence, it is expected to contain handler functions - ;; specific to each event class; the event code is used to index the sequence, - ;; fetching the appropriate handler. Handler is called with raw resource-ids, not - ;; with resource objects. The arguments to the handler are described using declare-event. - ;; - ;; T for peek-p means the event (for which the handler returns non-nil) is not removed - ;; from the queue (it is left in place), NIL means the event is removed. - - (declare (type display display) - (type (or null number) timeout) - (type generalized-boolean peek-p discard-p force-output-p)) - (declare (type t handler) - (dynamic-extent handler)) - (event-loop (display event timeout force-output-p discard-p) - (let* ((event-code (event-code event)) ;; Event decoder defined by DECLARE-EVENT - (event-decoder (and (index< event-code (length *event-handler-vector*)) - (svref *event-handler-vector* event-code)))) - (declare (type array-index event-code) - (type (or null function) event-decoder)) - (if event-decoder - (let ((event-handler (if (functionp handler) - handler - (and (type? handler 'sequence) - (< event-code (length handler)) - (elt handler event-code))))) - (if event-handler - (let ((result (funcall event-decoder display event event-handler))) - (when result - (unless peek-p - (discard-current-event display)) - (return result))) - (cerror "Ignore this event" - "No handler for ~s event" - (svref *event-key-vector* event-code)))) - (cerror "Ignore this event" - "Server Error: event with unknown event code ~d received." - event-code))))) - -(defun make-event-handlers (&key (type 'array) default) - (declare (type t type) ;Sequence type specifier - (type (or null function) default) - (clx-values sequence)) ;Default handler for initial content - ;; Makes a handler sequence suitable for process-event - (make-sequence type +max-events+ :initial-element default)) - -(defun event-handler (handlers event-key) - (declare (type sequence handlers) - (type event-key event-key) - (clx-values function)) - ;; Accessor for a handler sequence - (elt handlers (position event-key *event-key-vector* :test #'eq))) - -(defun set-event-handler (handlers event-key handler) - (declare (type sequence handlers) - (type event-key event-key) - (type function handler) - (clx-values handler)) - (setf (elt handlers (position event-key *event-key-vector* :test #'eq)) handler)) - -(defsetf event-handler set-event-handler) - -;; -;; EVENT-CASE -;; - -(defmacro event-case ((&rest args) &body clauses) - ;; If force-output-p is true, first invokes display-force-output. Executes the - ;; matching clause for each queued event until a clause returns non-nil, and that - ;; returned object is then returned by event-case. If peek-p is true, then the - ;; event is not removed from the queue. If discard-p is true, then events for - ;; which the clause returns nil are removed from the queue, otherwise they are left - ;; in place. Hangs until non-nil is generated for some event, or for the specified - ;; timeout (in seconds, if given); however, it is acceptable for an implementation - ;; to wait only once on network data, and therefore timeout prematurely. Returns - ;; nil on timeout. In each clause, event-or-events is an event-key or a list of - ;; event-keys (but they need not be typed as keywords) or the symbol t or otherwise - ;; (but only in the last clause). The keys are not evaluated, and it is an error - ;; for the same key to appear in more than one clause. Args is the list of event - ;; components of interest; corresponding values (if any) are bound to variables - ;; with these names (i.e., the args are variable names, not keywords, the keywords - ;; are derived from the variable names). An arg can also be a (keyword var) form, - ;; as for keyword args in a lambda lists. If no t/otherwise clause appears, it is - ;; equivalent to having one that returns nil. - (declare (arglist (display &key timeout peek-p discard-p (force-output-p t)) - (event-or-events ((&rest args) |...|) &body body) |...|)) - ;; Event-case is just event-cond with the whole body in the test-form - `(event-cond ,args - ,@(mapcar - #'(lambda (clause) - `(,(car clause) ,(cadr clause) (progn ,@(cddr clause)))) - clauses))) - -;; -;; EVENT-COND -;; - -(defmacro event-cond ((display &key timeout peek-p discard-p (force-output-p t)) - &body clauses) - ;; The clauses of event-cond are of the form: - ;; (event-or-events binding-list test-form . body-forms) - ;; - ;; EVENT-OR-EVENTS event-key or a list of event-keys (but they - ;; need not be typed as keywords) or the symbol t - ;; or otherwise (but only in the last clause). If - ;; no t/otherwise clause appears, it is equivalent - ;; to having one that returns nil. The keys are - ;; not evaluated, and it is an error for the same - ;; key to appear in more than one clause. - ;; - ;; BINDING-LIST The list of event components of interest. - ;; corresponding values (if any) are bound to - ;; variables with these names (i.e., the binding-list - ;; has variable names, not keywords, the keywords are - ;; derived from the variable names). An arg can also - ;; be a (keyword var) form, as for keyword args in a - ;; lambda list. - ;; - ;; The matching TEST-FORM for each queued event is executed until a - ;; clause's test-form returns non-nil. Then the BODY-FORMS are - ;; evaluated, returning the (possibly multiple) values of the last - ;; form from event-cond. If there are no body-forms then, if the - ;; test-form is non-nil, the value of the test-form is returned as a - ;; single value. - ;; - ;; Options: - ;; FORCE-OUTPUT-P When true, first invoke display-force-output if no - ;; input is pending. - ;; - ;; PEEK-P When true, then the event is not removed from the queue. - ;; - ;; DISCARD-P When true, then events for which the clause returns nil - ;; are removed from the queue, otherwise they are left in place. - ;; - ;; TIMEOUT If NIL, hang until non-nil is generated for some event's - ;; test-form. Otherwise return NIL after TIMEOUT seconds have - ;; elapsed. - ;; - (declare (arglist (display &key timeout peek-p discard-p force-output-p) - (event-or-events (&rest args) test-form &body body) |...|)) - (let ((event (gensym)) - (disp (gensym)) - (peek (gensym))) - `(let ((,disp ,display) - (,peek ,peek-p)) - (declare (type display ,disp)) - (event-loop (,disp ,event ,timeout ,force-output-p ,discard-p) - (event-dispatch (,disp ,event ,peek) ,@clauses))))) - -(defun get-event-code (event) - ;; Returns the event code given an event-key - (declare (type event-key event)) - (declare (clx-values card8)) - (or (get event 'event-code) - (x-type-error event 'event-key))) - -(defun universal-event-get-macro (display event-key variable) - (getf - `(:display (the display ,display) :event-key (the keyword ,event-key) :event-code - (the card8 (logand 127 (read-card8 0))) :send-event-p - (logbitp 7 (read-card8 0))) - variable)) - -(defmacro event-dispatch ((display event peek-p) &body clauses) - ;; Helper macro for event-case - ;; CLAUSES are of the form: - ;; (event-or-events binding-list test-form . body-forms) - (let ((event-key (gensym)) - (all-events (make-array +max-events+ :element-type 'bit :initial-element 0))) - `(reading-event (,event) - (let ((,event-key (svref *event-key-vector* (event-code ,event)))) - (case ,event-key - ,@(mapcar - #'(lambda (clause) ; Translate event-cond clause to case clause - (let* ((events (first clause)) - (arglist (second clause)) - (test-form (third clause)) - (body-forms (cdddr clause))) - (flet ((event-clause (display peek-p first-form rest-of-forms) - (if rest-of-forms - `(when ,first-form - (unless ,peek-p (discard-current-event ,display)) - (return (progn ,@rest-of-forms))) - ;; No body forms, return the result of the test form - (let ((result (gensym))) - `(let ((,result ,first-form)) - (when ,result - (unless ,peek-p (discard-current-event ,display)) - (return ,result))))))) - - (if (member events '(otherwise t)) - ;; code for OTHERWISE clause. - ;; Find all events NOT used by other clauses - (let ((keys (do ((i 0 (1+ i)) - (key nil) - (result nil)) - ((>= i +max-events+) result) - (setq key (svref *event-key-vector* i)) - (when (and key (zerop (aref all-events i))) - (push key result))))) - `(otherwise - (binding-event-values - (,display ,event-key ,(or keys :universal) ,@arglist) - ,(event-clause display peek-p test-form body-forms)))) - - ;; Code for normal clauses - (let (true-events) ;; canonicalize event-names - (if (consp events) - (progn - (setq true-events (mapcar #'canonicalize-event-name events)) - (dolist (event true-events) - (setf (aref all-events (get-event-code event)) 1))) - (setf true-events (canonicalize-event-name events) - (aref all-events (get-event-code true-events)) 1)) - `(,true-events - (binding-event-values - (,display ,event-key ,true-events ,@arglist) - ,(event-clause display peek-p test-form body-forms)))))))) - clauses)))))) - -(defmacro binding-event-values ((display event-key event-keys &rest value-list) &body body) - ;; Execute BODY with the variables in VALUE-LIST bound to components of the - ;; EVENT-KEYS events. - (unless (consp event-keys) (setq event-keys (list event-keys))) - (flet ((var-key (var) (kintern (if (consp var) (first var) var))) - (var-symbol (var) (if (consp var) (second var) var))) - ;; VARS is an alist of: - ;; (component-key ((event-key event-key ...) . extraction-code) - ;; ((event-key event-key ...) . extraction-code) ...) - ;; There should probably be accessor macros for this, instead of things like cdadr. - (let ((vars (mapcar #'list value-list)) - (multiple-p nil)) - ;; Fill in the VARS alist with event-keys and extraction-code - (do ((keys event-keys (cdr keys)) - (temp nil)) - ((endp keys)) - (let* ((key (car keys)) - (binder (case key - (:universal #'universal-event-get-macro) - (otherwise (svref *event-macro-vector* (get-event-code key)))))) - (dolist (var vars) - (let ((code (funcall binder display event-key (var-key (car var))))) - (unless code (warn "~a isn't a component of the ~s event" - (var-key (car var)) key)) - (if (setq temp (member code (cdr var) :key #'cdr :test #'equal)) - (push key (caar temp)) - (push `((,key) . ,code) (cdr var))))))) - ;; Bind all the values - `(let ,(mapcar #'(lambda (var) - (if (cddr var) ;; if more than one binding form - (progn (setq multiple-p t) - (var-symbol (car var))) - (list (var-symbol (car var)) (cdadr var)))) - vars) - ;; When some values come from different places, generate code to set them - ,(when multiple-p - `(case ,event-key - ,@(do ((keys event-keys (cdr keys)) - (clauses nil) ;; alist of (event-keys bindings) - (clause nil nil) - (temp)) - ((endp keys) - (dolist (clause clauses) - (unless (cdar clause) ;; Atomize single element lists - (setf (car clause) (caar clause)))) - clauses) - ;; Gather up all the bindings associated with (car keys) - (dolist (var vars) - (when (cddr var) ;; when more than one binding form - (dolist (events (cdr var)) - (when (member (car keys) (car events)) - ;; Optimize for event-window being the same as some other binding - (if (setq temp (member (cdr events) clause - :key #'caddr - :test #'equal)) - (setq clause - (nconc clause `((setq ,(car var) ,(second (car temp)))))) - (push `(setq ,(car var) ,(cdr events)) clause)))))) - ;; Merge bindings for (car keys) with other bindings - (when clause - (if (setq temp (member clause clauses :key #'cdr :test #'equal)) - (push (car keys) (caar temp)) - (push `((,(car keys)) . ,clause) clauses)))))) - ,@body)))) - - -;;;----------------------------------------------------------------------------- -;;; Error Handling -;;;----------------------------------------------------------------------------- - -(eval-when (:execute :compile-toplevel :load-toplevel) -(defparameter - *xerror-vector* - '#(unknown-error - request-error ; 1 bad request code - value-error ; 2 integer parameter out of range - window-error ; 3 parameter not a Window - pixmap-error ; 4 parameter not a Pixmap - atom-error ; 5 parameter not an Atom - cursor-error ; 6 parameter not a Cursor - font-error ; 7 parameter not a Font - match-error ; 8 parameter mismatch - drawable-error ; 9 parameter not a Pixmap or Window - access-error ; 10 attempt to access private resource" - alloc-error ; 11 insufficient resources - colormap-error ; 12 no such colormap - gcontext-error ; 13 parameter not a GContext - id-choice-error ; 14 invalid resource ID for this connection - name-error ; 15 font or color name does not exist - length-error ; 16 request length incorrect; - ; internal Xlib error - implementation-error ; 17 server is defective - )) -) - -(defun make-error (display event asynchronous) - (declare (type display display) - (type reply-buffer event) - (type generalized-boolean asynchronous)) - (reading-event (event) - (let* ((error-code (read-card8 1)) - (error-key (get-error-key display error-code)) - (error-decode-function (get error-key 'error-decode-function)) - (params (funcall error-decode-function display event))) - (list* error-code error-key - :asynchronous asynchronous :current-sequence (display-request-number display) - params)))) - -(defun report-error (display error-code error-key &rest params) - (declare (type display display) - (dynamic-extent params)) - ;; All errors (synchronous and asynchronous) are processed by calling - ;; an error handler in the display. The handler is called with the display - ;; as the first argument and the error-key as its second argument. If handler is - ;; an array it is expected to contain handler functions specific to - ;; each error; the error code is used to index the array, fetching the - ;; appropriate handler. Any results returned by the handler are ignored;; - ;; it is assumed the handler either takes care of the error completely, - ;; or else signals. For all core errors, additional keyword/value argument - ;; pairs are: - ;; :major integer - ;; :minor integer - ;; :sequence integer - ;; :current-sequence integer - ;; :asynchronous (member t nil) - ;; For :colormap, :cursor, :drawable, :font, :GContext, :id-choice, :pixmap, and :window - ;; errors another pair is: - ;; :resource-id integer - ;; For :atom errors, another pair is: - ;; :atom-id integer - ;; For :value errors, another pair is: - ;; :value integer - (let* ((handler (display-error-handler display)) - (handler-function - (if (type? handler 'sequence) - (elt handler error-code) - handler))) - (apply handler-function display error-key params))) - -(defun request-name (code &optional display) - (if (< code (length *request-names*)) - (svref *request-names* code) - (dolist (extension (and display (display-extension-alist display)) "unknown") - (when (= code (second extension)) - (return (first extension)))))) - -(defun report-request-error (condition stream) - (let ((error-key (request-error-error-key condition)) - (asynchronous (request-error-asynchronous condition)) - (major (request-error-major condition)) - (minor (request-error-minor condition)) - (sequence (request-error-sequence condition)) - (current-sequence (request-error-current-sequence condition))) - (format stream "~:[~;Asynchronous ~]~a in ~:[request ~d (last request was ~d) ~;current request~2* ~] Code ~d.~d [~a]" - asynchronous error-key (= sequence current-sequence) - sequence current-sequence major minor - (request-name major (request-error-display condition))))) - -;; Since the :report arg is evaluated as (function report-request-error) the -;; define-condition must come after the function definition. - -(define-condition request-error (x-error) - ((display :reader request-error-display :initarg :display) - (error-key :reader request-error-error-key :initarg :error-key) - (major :reader request-error-major :initarg :major) - (minor :reader request-error-minor :initarg :minor) - (sequence :reader request-error-sequence :initarg :sequence) - (current-sequence :reader request-error-current-sequence :initarg :current-sequence) - (asynchronous :reader request-error-asynchronous :initarg :asynchronous)) - (:report report-request-error)) - -(define-condition resource-error (request-error) - ((resource-id :reader resource-error-resource-id :initarg :resource-id)) - (:report - (lambda (condition stream) - (report-request-error condition stream) - (format stream " ID #x~x" (resource-error-resource-id condition))))) - -(define-condition unknown-error (request-error) - ((error-code :reader unknown-error-error-code :initarg :error-code)) - (:report - (lambda (condition stream) - (report-request-error condition stream) - (format stream " Error Code ~d." (unknown-error-error-code condition))))) - -(define-condition access-error (request-error) ()) - -(define-condition alloc-error (request-error) ()) - -(define-condition atom-error (request-error) - ((atom-id :reader atom-error-atom-id :initarg :atom-id)) - (:report - (lambda (condition stream) - (report-request-error condition stream) - (format stream " Atom-ID #x~x" (atom-error-atom-id condition))))) - -(define-condition colormap-error (resource-error) ()) - -(define-condition cursor-error (resource-error) ()) - -(define-condition drawable-error (resource-error) ()) - -(define-condition font-error (resource-error) ()) - -(define-condition gcontext-error (resource-error) ()) - -(define-condition id-choice-error (resource-error) ()) - -(define-condition illegal-request-error (request-error) ()) - -(define-condition length-error (request-error) ()) - -(define-condition match-error (request-error) ()) - -(define-condition name-error (request-error) ()) - -(define-condition pixmap-error (resource-error) ()) - -(define-condition value-error (request-error) - ((value :reader value-error-value :initarg :value)) - (:report - (lambda (condition stream) - (report-request-error condition stream) - (format stream " Value ~d." (value-error-value condition))))) - -(define-condition window-error (resource-error)()) - -(define-condition implementation-error (request-error) ()) - -;;----------------------------------------------------------------------------- -;; Internal error conditions signaled by CLX - -(define-condition x-type-error (type-error x-error) - ((type-string :reader x-type-error-type-string :initarg :type-string)) - (:report - (lambda (condition stream) - (format stream "~s isn't a ~a" - (type-error-datum condition) - (or (x-type-error-type-string condition) - (type-error-expected-type condition)))))) - -(define-condition closed-display (x-error) - ((display :reader closed-display-display :initarg :display)) - (:report - (lambda (condition stream) - (format stream "Attempt to use closed display ~s" - (closed-display-display condition))))) - -(define-condition lookup-error (x-error) - ((id :reader lookup-error-id :initarg :id) - (display :reader lookup-error-display :initarg :display) - (type :reader lookup-error-type :initarg :type) - (object :reader lookup-error-object :initarg :object)) - (:report - (lambda (condition stream) - (format stream "ID ~d from display ~s should have been a ~s, but was ~s" - (lookup-error-id condition) - (lookup-error-display condition) - (lookup-error-type condition) - (lookup-error-object condition))))) - -(define-condition connection-failure (x-error) - ((major-version :reader connection-failure-major-version :initarg :major-version) - (minor-version :reader connection-failure-minor-version :initarg :minor-version) - (host :reader connection-failure-host :initarg :host) - (display :reader connection-failure-display :initarg :display) - (reason :reader connection-failure-reason :initarg :reason)) - (:report - (lambda (condition stream) - (format stream "Connection failure to X~d.~d server ~a display ~d: ~a" - (connection-failure-major-version condition) - (connection-failure-minor-version condition) - (connection-failure-host condition) - (connection-failure-display condition) - (connection-failure-reason condition))))) - -(define-condition reply-length-error (x-error) - ((reply-length :reader reply-length-error-reply-length :initarg :reply-length) - (expected-length :reader reply-length-error-expected-length :initarg :expected-length) - (display :reader reply-length-error-display :initarg :display)) - (:report - (lambda (condition stream) - (format stream "Reply length was ~d when ~d words were expected for display ~s" - (reply-length-error-reply-length condition) - (reply-length-error-expected-length condition) - (reply-length-error-display condition))))) - -(define-condition reply-timeout (x-error) - ((timeout :reader reply-timeout-timeout :initarg :timeout) - (display :reader reply-timeout-display :initarg :display)) - (:report - (lambda (condition stream) - (format stream "Timeout after waiting ~d seconds for a reply for display ~s" - (reply-timeout-timeout condition) - (reply-timeout-display condition))))) - -(define-condition sequence-error (x-error) - ((display :reader sequence-error-display :initarg :display) - (req-sequence :reader sequence-error-req-sequence :initarg :req-sequence) - (msg-sequence :reader sequence-error-msg-sequence :initarg :msg-sequence)) - (:report - (lambda (condition stream) - (format stream "Reply out of sequence for display ~s.~% Expected ~d, Got ~d" - (sequence-error-display condition) - (sequence-error-req-sequence condition) - (sequence-error-msg-sequence condition))))) - -(define-condition unexpected-reply (x-error) - ((display :reader unexpected-reply-display :initarg :display) - (msg-sequence :reader unexpected-reply-msg-sequence :initarg :msg-sequence) - (req-sequence :reader unexpected-reply-req-sequence :initarg :req-sequence) - (length :reader unexpected-reply-length :initarg :length)) - (:report - (lambda (condition stream) - (format stream "Display ~s received a server reply when none was expected.~@ - Last request sequence ~d Reply Sequence ~d Reply Length ~d bytes." - (unexpected-reply-display condition) - (unexpected-reply-req-sequence condition) - (unexpected-reply-msg-sequence condition) - (unexpected-reply-length condition))))) - -(define-condition missing-parameter (x-error) - ((parameter :reader missing-parameter-parameter :initarg :parameter)) - (:report - (lambda (condition stream) - (let ((parm (missing-parameter-parameter condition))) - (if (consp parm) - (format stream "One or more of the required parameters ~a is missing." - parm) - (format stream "Required parameter ~a is missing or null." parm)))))) - -;; This can be signalled anywhere a pseudo font access fails. -(define-condition invalid-font (x-error) - ((font :reader invalid-font-font :initarg :font)) - (:report - (lambda (condition stream) - (format stream "Can't access font ~s" (invalid-font-font condition))))) - -(define-condition device-busy (x-error) - ((display :reader device-busy-display :initarg :display)) - (:report - (lambda (condition stream) - (format stream "Device busy for display ~s" - (device-busy-display condition))))) - -(define-condition unimplemented-event (x-error) - ((display :reader unimplemented-event-display :initarg :display) - (event-code :reader unimplemented-event-event-code :initarg :event-code)) - (:report - (lambda (condition stream) - (format stream "Event code ~d not implemented for display ~s" - (unimplemented-event-event-code condition) - (unimplemented-event-display condition))))) - -(define-condition undefined-event (x-error) - ((display :reader undefined-event-display :initarg :display) - (event-name :reader undefined-event-event-name :initarg :event-name)) - (:report - (lambda (condition stream) - (format stream "Event code ~d undefined for display ~s" - (undefined-event-event-name condition) - (undefined-event-display condition))))) - -(define-condition absent-extension (x-error) - ((name :reader absent-extension-name :initarg :name) - (display :reader absent-extension-display :initarg :display)) - (:report - (lambda (condition stream) - (format stream "Extension ~a isn't defined for display ~s" - (absent-extension-name condition) - (absent-extension-display condition))))) - -(define-condition inconsistent-parameters (x-error) - ((parameters :reader inconsistent-parameters-parameters :initarg :parameters)) - (:report - (lambda (condition stream) - (format stream "inconsistent-parameters:~{ ~s~}" - (inconsistent-parameters-parameters condition))))) - -(defun get-error-key (display error-code) - (declare (type display display) - (type array-index error-code)) - ;; Return the error-key associated with error-code - (if (< error-code (length *xerror-vector*)) - (svref *xerror-vector* error-code) - ;; Search the extensions for the error - (dolist (entry (display-extension-alist display) 'unknown-error) - (let* ((event-name (first entry)) - (first-error (fourth entry)) - (errors (third (assoc event-name *extensions*)))) - (declare (type keyword event-name) - (type array-index first-error) - (type list errors)) - (when (and errors - (index<= first-error error-code - (index+ first-error (index- (length errors) 1)))) - (return (nth (index- error-code first-error) errors))))))) - -(defmacro define-error (error-key function) - ;; Associate a function with ERROR-KEY which will be called with - ;; parameters DISPLAY and REPLY-BUFFER and - ;; returns a plist of keyword/value pairs which will be passed on - ;; to the error handler. A compiler warning is printed when - ;; ERROR-KEY is not defined in a preceding DEFINE-EXTENSION. - ;; Note: REPLY-BUFFER may used with the READING-EVENT and READ-type - ;; macros for getting error fields. See DECODE-CORE-ERROR for - ;; an example. - (declare (type symbol error-key) - (type (or symbol list) function)) - ;; First ensure the name is for a declared extension - (unless (or (find error-key *xerror-vector*) - (dolist (extension *extensions*) - (when (member error-key (third extension)) - (return t)))) - (x-type-error error-key 'error-key)) - `(setf (get ',error-key 'error-decode-function) (function ,function))) - -;; All core errors use this, so we make it available to extensions. -(defun decode-core-error (display event &optional arg) - ;; All core errors have the following keyword/argument pairs: - ;; :major integer - ;; :minor integer - ;; :sequence integer - ;; In addition, many have an additional argument that comes from the - ;; same place in the event, but is named differently. When the ARG - ;; argument is specified, the keyword ARG with card32 value starting - ;; at byte 4 of the event is returned with the other keyword/argument - ;; pairs. - (declare (type display display) - (type reply-buffer event) - (type (or null keyword) arg)) - (declare (clx-values keyword/arg-plist)) - display - (reading-event (event) - (let* ((sequence (read-card16 2)) - (minor-code (read-card16 8)) - (major-code (read-card8 10)) - (result (list :major major-code - :minor minor-code - :sequence sequence))) - (when arg - (setq result (list* arg (read-card32 4) result))) - result))) - -(defun decode-resource-error (display event) - (decode-core-error display event :resource-id)) - -(define-error unknown-error - (lambda (display event) - (list* :error-code (aref (reply-ibuf8 event) 1) - (decode-core-error display event)))) - -(define-error request-error decode-core-error) ; 1 bad request code - -(define-error value-error ; 2 integer parameter out of range - (lambda (display event) - (decode-core-error display event :value))) - -(define-error window-error decode-resource-error) ; 3 parameter not a Window - -(define-error pixmap-error decode-resource-error) ; 4 parameter not a Pixmap - -(define-error atom-error ; 5 parameter not an Atom - (lambda (display event) - (decode-core-error display event :atom-id))) - -(define-error cursor-error decode-resource-error) ; 6 parameter not a Cursor - -(define-error font-error decode-resource-error) ; 7 parameter not a Font - -(define-error match-error decode-core-error) ; 8 parameter mismatch - -(define-error drawable-error decode-resource-error) ; 9 parameter not a Pixmap or Window - -(define-error access-error decode-core-error) ; 10 attempt to access private resource" - -(define-error alloc-error decode-core-error) ; 11 insufficient resources - -(define-error colormap-error decode-resource-error) ; 12 no such colormap - -(define-error gcontext-error decode-resource-error) ; 13 parameter not a GContext - -(define-error id-choice-error decode-resource-error) ; 14 invalid resource ID for this connection - -(define-error name-error decode-core-error) ; 15 font or color name does not exist - -(define-error length-error decode-core-error) ; 16 request length incorrect; - ; internal Xlib error - -(define-error implementation-error decode-core-error) ; 17 server is defective diff --git a/src/eclx/keysyms.lisp b/src/eclx/keysyms.lisp deleted file mode 100644 index 54756ba22..000000000 --- a/src/eclx/keysyms.lisp +++ /dev/null @@ -1,162 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES -*- - -;;; Define lisp character to keysym mappings - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; -#+cmu -(ext:file-comment - "$Header$") - -(in-package :xlib) - -(define-keysym-set :latin-1 (keysym 0 0) (keysym 0 255)) -(define-keysym-set :latin-2 (keysym 1 0) (keysym 1 255)) -(define-keysym-set :latin-3 (keysym 2 0) (keysym 2 255)) -(define-keysym-set :latin-4 (keysym 3 0) (keysym 3 255)) -(define-keysym-set :kana (keysym 4 0) (keysym 4 255)) -(define-keysym-set :arabic (keysym 5 0) (keysym 5 255)) -(define-keysym-set :cryllic (keysym 6 0) (keysym 6 255)) -(define-keysym-set :greek (keysym 7 0) (keysym 7 255)) -(define-keysym-set :tech (keysym 8 0) (keysym 8 255)) -(define-keysym-set :special (keysym 9 0) (keysym 9 255)) -(define-keysym-set :publish (keysym 10 0) (keysym 10 255)) -(define-keysym-set :apl (keysym 11 0) (keysym 11 255)) -(define-keysym-set :hebrew (keysym 12 0) (keysym 12 255)) -(define-keysym-set :keyboard (keysym 255 0) (keysym 255 255)) - -(define-keysym :character-set-switch character-set-switch-keysym) -(define-keysym :left-shift left-shift-keysym) -(define-keysym :right-shift right-shift-keysym) -(define-keysym :left-control left-control-keysym) -(define-keysym :right-control right-control-keysym) -(define-keysym :caps-lock caps-lock-keysym) -(define-keysym :shift-lock shift-lock-keysym) -(define-keysym :left-meta left-meta-keysym) -(define-keysym :right-meta right-meta-keysym) -(define-keysym :left-alt left-alt-keysym) -(define-keysym :right-alt right-alt-keysym) -(define-keysym :left-super left-super-keysym) -(define-keysym :right-super right-super-keysym) -(define-keysym :left-hyper left-hyper-keysym) -(define-keysym :right-hyper right-hyper-keysym) - -(define-keysym #\space 032) -(define-keysym #\! 033) -(define-keysym #\" 034) -(define-keysym #\# 035) -(define-keysym #\$ 036) -(define-keysym #\% 037) -(define-keysym #\& 038) -(define-keysym #\' 039) -(define-keysym #\( 040) -(define-keysym #\) 041) -(define-keysym #\* 042) -(define-keysym #\+ 043) -(define-keysym #\, 044) -(define-keysym #\- 045) -(define-keysym #\. 046) -(define-keysym #\/ 047) -(define-keysym #\0 048) -(define-keysym #\1 049) -(define-keysym #\2 050) -(define-keysym #\3 051) -(define-keysym #\4 052) -(define-keysym #\5 053) -(define-keysym #\6 054) -(define-keysym #\7 055) -(define-keysym #\8 056) -(define-keysym #\9 057) -(define-keysym #\: 058) -(define-keysym #\; 059) -(define-keysym #\< 060) -(define-keysym #\= 061) -(define-keysym #\> 062) -(define-keysym #\? 063) -(define-keysym #\@ 064) -(define-keysym #\A 065 :lowercase 097) -(define-keysym #\B 066 :lowercase 098) -(define-keysym #\C 067 :lowercase 099) -(define-keysym #\D 068 :lowercase 100) -(define-keysym #\E 069 :lowercase 101) -(define-keysym #\F 070 :lowercase 102) -(define-keysym #\G 071 :lowercase 103) -(define-keysym #\H 072 :lowercase 104) -(define-keysym #\I 073 :lowercase 105) -(define-keysym #\J 074 :lowercase 106) -(define-keysym #\K 075 :lowercase 107) -(define-keysym #\L 076 :lowercase 108) -(define-keysym #\M 077 :lowercase 109) -(define-keysym #\N 078 :lowercase 110) -(define-keysym #\O 079 :lowercase 111) -(define-keysym #\P 080 :lowercase 112) -(define-keysym #\Q 081 :lowercase 113) -(define-keysym #\R 082 :lowercase 114) -(define-keysym #\S 083 :lowercase 115) -(define-keysym #\T 084 :lowercase 116) -(define-keysym #\U 085 :lowercase 117) -(define-keysym #\V 086 :lowercase 118) -(define-keysym #\W 087 :lowercase 119) -(define-keysym #\X 088 :lowercase 120) -(define-keysym #\Y 089 :lowercase 121) -(define-keysym #\Z 090 :lowercase 122) -(define-keysym #\[ 091) -(define-keysym #\\ 092) -(define-keysym #\] 093) -(define-keysym #\^ 094) -(define-keysym #\_ 095) -(define-keysym #\` 096) -(define-keysym #\a 097) -(define-keysym #\b 098) -(define-keysym #\c 099) -(define-keysym #\d 100) -(define-keysym #\e 101) -(define-keysym #\f 102) -(define-keysym #\g 103) -(define-keysym #\h 104) -(define-keysym #\i 105) -(define-keysym #\j 106) -(define-keysym #\k 107) -(define-keysym #\l 108) -(define-keysym #\m 109) -(define-keysym #\n 110) -(define-keysym #\o 111) -(define-keysym #\p 112) -(define-keysym #\q 113) -(define-keysym #\r 114) -(define-keysym #\s 115) -(define-keysym #\t 116) -(define-keysym #\u 117) -(define-keysym #\v 118) -(define-keysym #\w 119) -(define-keysym #\x 120) -(define-keysym #\y 121) -(define-keysym #\z 122) -(define-keysym #\{ 123) -(define-keysym #\| 124) -(define-keysym #\} 125) -(define-keysym #\~ 126) - -(progn ;; Semi-standard characters - (define-keysym #\rubout (keysym 255 255)) ; :tty - (define-keysym #\tab (keysym 255 009)) ; :tty - (define-keysym #\linefeed (keysym 255 010)) ; :tty - (define-keysym #\page (keysym 009 227)) ; :special - (define-keysym #\return (keysym 255 013)) ; :tty - (define-keysym #\backspace (keysym 255 008)) ; :tty - ) - - diff --git a/src/eclx/load.lsp.in b/src/eclx/load.lsp.in deleted file mode 100644 index 78bfdd0ab..000000000 --- a/src/eclx/load.lsp.in +++ /dev/null @@ -1,24 +0,0 @@ -(defconstant +eclx-module-files+ -'("src:eclx;split-sequence.lisp" - "src:eclx;package.lisp" - "src:eclx;depdefs.lisp" - "src:eclx;clx.lisp" - "src:eclx;dependent.lisp" - "src:eclx;macros.lisp" ; these are just macros - "src:eclx;bufmac.lisp" ; these are just macros - "src:eclx;buffer.lisp" - "src:eclx;display.lisp" - "src:eclx;gcontext.lisp" - "src:eclx;input.lisp" - "src:eclx;requests.lisp" - "src:eclx;fonts.lisp" - "src:eclx;graphics.lisp" - "src:eclx;text.lisp" - "src:eclx;attributes.lisp" - "src:eclx;translate.lisp" - "src:eclx;keysyms.lisp" - "src:eclx;manager.lisp" - "src:eclx;image.lisp" - "src:eclx;resource.lisp")) - -(mapc #'(lambda (x) (load x :verbose nil)) +eclx-module-files+) diff --git a/src/eclx/macros.lisp b/src/eclx/macros.lisp deleted file mode 100644 index 59b6543c8..000000000 --- a/src/eclx/macros.lisp +++ /dev/null @@ -1,1086 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; -#+cmu -(ext:file-comment - "$Header$") - -;;; CLX basicly implements a very low overhead remote procedure call -;;; to the server. This file contains macros which generate the code -;;; for both the client AND the server, given a specification of the -;;; interface. This was done to eliminate errors that may occur because -;;; the client and server code get/put bytes in different places, and -;;; it makes it easier to extend the protocol. - -;;; This is built on top of BUFFER - -(in-package :xlib) - -;;; This variable is used by the required-arg macro just to satisfy compilers. -(defvar *required-arg-dummy*) - -;;; An error signalling macro use to specify that keyword arguments are required. -(defmacro required-arg (name) - `(progn (x-error 'missing-parameter :parameter ',name) - *required-arg-dummy*)) - -(defmacro lround (index) - ;; Round up to the next 32 bit boundary - `(the array-index (logand (index+ ,index 3) -4))) - -(defmacro wround (index) - ;; Round up to the next 16 bit boundary - `(the array-index (logand (index+ ,index 1) -2))) - -;; -;; Data-type accessor functions -;; -;; These functions translate between lisp data-types and the byte, -;; half-word or word that gets transmitted across the client/server -;; connection - -(defun index-increment (type) - ;; Given a type, return its field width in bytes - (let* ((name (if (consp type) (car type) type)) - (increment (get name 'byte-width :not-found))) - (when (eq increment :not-found) - ;; Check for TYPE in a different package - (when (not (eq (symbol-package name) *xlib-package*)) - (setq name (xintern name)) - (setq increment (get name 'byte-width :not-found))) - (when (eq increment :not-found) - (error "~s isn't a known field accessor" name))) - increment)) - -(eval-when (:execute :compile-toplevel :load-toplevel) -(defun getify (name) - (xintern name '-get)) - -(defun putify (name &optional predicate-p) - (xintern name '-put (if predicate-p '-predicating ""))) - - ;; Use &body so zmacs indents properly -(defmacro define-accessor (name (width) &body get-put-macros) - ;; The first body form defines the get macro - ;; The second body form defines the put macro - ;; The third body form is optional, and defines a put macro that does - ;; type checking and does a put when ok, else NIL when the type is incorrect. - ;; If no third body form is present, then these macros assume that - ;; (AND (TYPEP ,thing 'type) (PUT-type ,thing)) can be generated. - ;; these predicating puts are used by the OR accessor. - (declare (arglist name (width) get-macro put-macro &optional predicating-put-macro)) - (when (cdddr get-put-macros) - (error "Too many parameters to define-accessor: ~s" (cdddr get-put-macros))) - (let ((get-macro (or (first get-put-macros) (error "No GET macro form for ~s" name))) - (put-macro (or (second get-put-macros) (error "No PUT macro form for ~s" name)))) - `(within-definition (,name define-accessor) - (setf (get ',name 'byte-width) ,(and width (floor width 8))) - (defmacro ,(getify name) ,(car get-macro) - ,@(cdr get-macro)) - (defmacro ,(putify name) ,(car put-macro) - ,@(cdr put-macro)) - ,@(when +type-check?+ - (let ((predicating-put (third get-put-macros))) - (when predicating-put - `((setf (get ',name 'predicating-put) t) - (defmacro ,(putify name t) ,(car predicating-put) - ,@(cdr predicating-put))))))))) -) ;; End eval-when - -(define-accessor card32 (32) - ((index) `(read-card32 ,index)) - ((index thing) `(write-card32 ,index ,thing))) - -(define-accessor card29 (32) - ((index) `(read-card29 ,index)) - ((index thing) `(write-card29 ,index ,thing))) - -(define-accessor card16 (16) - ((index) `(read-card16 ,index)) - ((index thing) `(write-card16 ,index ,thing))) - -(define-accessor card8 (8) - ((index) `(read-card8 ,index)) - ((index thing) `(write-card8 ,index ,thing))) - -(define-accessor integer (32) - ((index) `(read-int32 ,index)) - ((index thing) `(write-int32 ,index ,thing))) - -(define-accessor int16 (16) - ((index) `(read-int16 ,index)) - ((index thing) `(write-int16 ,index ,thing))) - -(define-accessor rgb-val (16) - ;; Used for color's - ((index) `(card16->rgb-val (read-card16 ,index))) - ((index thing) `(write-card16 ,index (rgb-val->card16 ,thing)))) - -(define-accessor angle (16) - ;; Used for drawing arcs - ((index) `(int16->radians (read-int16 ,index))) - ((index thing) `(write-int16 ,index (radians->int16 ,thing)))) - -(define-accessor bit (0) - ;; Like BOOLEAN, but tests bits - ;; only used by declare-event (:enter-notify :leave-notify) - ((index bit) - `(logbitp ,bit (read-card8 ,index))) - ((index thing bit) - (if (zerop bit) - `(write-card8 ,index (if ,thing 1 0)) - `(write-card8 ,index (dpb (if ,thing 1 0) (byte 1 ,bit) (read-card8 ,index)))))) - -(define-accessor boolean (8) - ((index) - `(plusp (read-card8 ,index))) - ((index thing) `(write-card8 ,index (if ,thing 1 0)))) - -(define-accessor drawable (32) - ((index &optional (buffer '%buffer)) - `(lookup-drawable ,buffer (read-card29 ,index))) - ((index thing) `(write-card29 ,index (drawable-id ,thing)))) - -(define-accessor window (32) - ((index &optional (buffer '%buffer)) - `(lookup-window ,buffer (read-card29 ,index))) - ((index thing) `(write-card29 ,index (window-id ,thing)))) - -(define-accessor pixmap (32) - ((index &optional (buffer '%buffer)) - `(lookup-pixmap ,buffer (read-card29 ,index))) - ((index thing) `(write-card29 ,index (pixmap-id ,thing)))) - -(define-accessor gcontext (32) - ((index &optional (buffer '%buffer)) - `(lookup-gcontext ,buffer (read-card29 ,index))) - ((index thing) `(write-card29 ,index (gcontext-id ,thing)))) - -(define-accessor cursor (32) - ((index &optional (buffer '%buffer)) - `(lookup-cursor ,buffer (read-card29 ,index))) - ((index thing) `(write-card29 ,index (cursor-id ,thing)))) - -(define-accessor colormap (32) - ((index &optional (buffer '%buffer)) - `(lookup-colormap ,buffer (read-card29 ,index))) - ((index thing) `(write-card29 ,index (colormap-id ,thing)))) - -(define-accessor font (32) - ((index &optional (buffer '%buffer)) - `(lookup-font ,buffer (read-card29 ,index))) - ;; The FONT-ID accessor may make a OpenFont request. Since we don't support recursive - ;; with-buffer-request, issue a compile time error, rather than barf at run-time. - ((index thing) - (declare (ignore index thing)) - (error "FONT-ID must be called OUTSIDE with-buffer-request. Use RESOURCE-ID instead."))) - -;; Needed to get and put xatom's in events -(define-accessor keyword (32) - ((index &optional (buffer '%buffer)) - `(atom-name ,buffer (read-card29 ,index))) - ((index thing &key (buffer '%buffer)) - `(write-card29 ,index (or (atom-id ,thing ,buffer) - (error "CLX implementation error in KEYWORD-PUT"))))) - -(define-accessor resource-id (32) - ((index) `(read-card29 ,index)) - ((index thing) `(write-card29 ,index ,thing))) - -(define-accessor resource-id-or-nil (32) - ((index) (let ((id (gensym))) - `(let ((,id (read-card29 ,index))) - (and (plusp ,id) ,id)))) - ((index thing) `(write-card29 ,index (or ,thing 0)))) - -(defmacro char-info-get (index) - `(make-char-info - :left-bearing (int16-get ,index) - :right-bearing (int16-get ,(+ index 2)) - :width (int16-get ,(+ index 4)) - :ascent (int16-get ,(+ index 6)) - :descent (int16-get ,(+ index 8)) - :attributes (card16-get ,(+ index 10)))) - -(define-accessor member8 (8) - ((index &rest keywords) - (let ((value (gensym))) - `(let ((,value (read-card8 ,index))) - (declare (type (integer 0 (,(length keywords))) ,value)) - (type-check ,value '(integer 0 (,(length keywords)))) - (svref ',(apply #'vector keywords) ,value)))) - ((index thing &rest keywords) - `(write-card8 ,index (position ,thing - (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - ((index thing &rest keywords) - (let ((value (gensym))) - `(let ((,value (position ,thing - (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - (and ,value (write-card8 ,index ,value)))))) - -(define-accessor member16 (16) - ((index &rest keywords) - (let ((value (gensym))) - `(let ((,value (read-card16 ,index))) - (declare (type (integer 0 (,(length keywords))) ,value)) - (type-check ,value '(integer 0 (,(length keywords)))) - (svref ',(apply #'vector keywords) ,value)))) - ((index thing &rest keywords) - `(write-card16 ,index (position ,thing - (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - ((index thing &rest keywords) - (let ((value (gensym))) - `(let ((,value (position ,thing - (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - (and ,value (write-card16 ,index ,value)))))) - -(define-accessor member (32) - ((index &rest keywords) - (let ((value (gensym))) - `(let ((,value (read-card29 ,index))) - (declare (type (integer 0 (,(length keywords))) ,value)) - (type-check ,value '(integer 0 (,(length keywords)))) - (svref ',(apply #'vector keywords) ,value)))) - ((index thing &rest keywords) - `(write-card29 ,index (position ,thing - (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - ((index thing &rest keywords) - (if (cdr keywords) ;; IF more than one - (let ((value (gensym))) - `(let ((,value (position ,thing - (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - (and ,value (write-card29 ,index ,value)))) - `(and (eq ,thing ,(car keywords)) (write-card29 ,index 0))))) - -(deftype member-vector (vector) `(member ,@(coerce (symbol-value vector) 'list))) - -(define-accessor member-vector (32) - ((index membership-vector) - `(member-get ,index ,@(coerce (eval membership-vector) 'list))) - ((index thing membership-vector) - `(member-put ,index ,thing ,@(coerce (eval membership-vector) 'list))) - ((index thing membership-vector) - `(member-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))) - -(define-accessor member16-vector (16) - ((index membership-vector) - `(member16-get ,index ,@(coerce (eval membership-vector) 'list))) - ((index thing membership-vector) - `(member16-put ,index ,thing ,@(coerce (eval membership-vector) 'list))) - ((index thing membership-vector) - `(member16-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))) - -(define-accessor member8-vector (8) - ((index membership-vector) - `(member8-get ,index ,@(coerce (eval membership-vector) 'list))) - ((index thing membership-vector) - `(member8-put ,index ,thing ,@(coerce (eval membership-vector) 'list))) - ((index thing membership-vector) - `(member8-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))) - -(define-accessor boole-constant (32) - ;; this isn't member-vector because we need eql instead of eq - ((index) - (let ((value (gensym))) - `(let ((,value (read-card29 ,index))) - (declare (type (integer 0 (,(length *boole-vector*))) ,value)) - (type-check ,value '(integer 0 (,(length *boole-vector*)))) - (svref *boole-vector* ,value)))) - ((index thing) - `(write-card29 ,index (position ,thing (the simple-vector *boole-vector*)))) - ((index thing) - (let ((value (gensym))) - `(let ((,value (position ,thing (the simple-vector *boole-vector*)))) - (and ,value (write-card29 ,index ,value)))))) - -(define-accessor null (32) - ((index) `(if (zerop (read-card32 ,index)) nil (read-card32 ,index))) - ((index value) (declare (ignore value)) `(write-card32 ,index 0))) - -(define-accessor pad8 (8) - ((index) (declare (ignore index)) nil) - ((index value) (declare (ignore index value)) nil)) - -(define-accessor pad16 (16) - ((index) (declare (ignore index)) nil) - ((index value) (declare (ignore index value)) nil)) - -(define-accessor bit-vector256 (256) - ;; used for key-maps - ;; REAL-INDEX parameter provided so the default index can be over-ridden. - ;; This is needed for the :keymap-notify event where the keymap overlaps - ;; the window id. - ((index &optional (real-index index) data) - `(read-bitvector256 buffer-bbuf ,real-index ,data)) - ((index map &optional (real-index index) (buffer '%buffer)) - `(write-bitvector256 ,buffer (index+ buffer-boffset ,real-index) ,map))) - -(define-accessor string (nil) - ((length index &key reply-buffer) - `(read-sequence-char - ,(or reply-buffer '%reply-buffer) 'string ,length nil nil 0 ,index)) - ((index string &key buffer (start 0) end header-length appending) - (unless buffer (setq buffer '%buffer)) - (unless header-length (setq header-length (lround index))) - (let* ((real-end (if appending (or end `(length ,string)) (gensym))) - (form `(write-sequence-char ,buffer (index+ buffer-boffset ,header-length) - ,string ,start ,real-end))) - (if appending - form - `(let ((,real-end ,(or end `(length ,string)))) - (write-card16 2 (index-ceiling (index+ (index- ,real-end ,start) ,header-length) 4)) - ,form))))) - -(define-accessor sequence (nil) - ((&key length (format 'card32) result-type transform reply-buffer data index start) - `(,(ecase format - (card8 'read-sequence-card8) - (int8 'read-sequence-int8) - (card16 'read-sequence-card16) - (int16 'read-sequence-int16) - (card32 'read-sequence-card32) - (int32 'read-sequence-int32)) - ,(or reply-buffer '%reply-buffer) - ,result-type ,length ,transform ,data - ,@(when (or start index) `(,(or start 0))) - ,@(when index `(,index)))) - ((index data &key (format 'card32) (start 0) end transform buffer appending) - (unless buffer (setq buffer '%buffer)) - (let* ((real-end (if appending (or end `(length ,data)) (gensym))) - (writer (xintern 'write-sequence- format)) - (form `(,writer ,buffer (index+ buffer-boffset ,(lround index)) - ,data ,start ,real-end ,transform))) - (flet ((maker (size) - (if appending - form - (let ((idx `(index- ,real-end ,start))) - (unless (= size 1) - (setq idx `(index-ceiling ,idx ,size))) - `(let ((,real-end ,(or end `(length ,data)))) - (write-card16 2 (index+ ,idx ,(index-ceiling index 4))) - ,form))))) - (ecase format - ((card8 int8) - (maker 4)) - ((card16 int16 char2b) - (maker 2)) - ((card32 int32) - (maker 1))))))) - -(defmacro client-message-event-get-sequence () - '(let* ((format (read-card8 1)) - (sequence (make-array (ceiling 160 format) - :element-type `(unsigned-byte ,format)))) - (declare (type (member 8 16 32) format)) - (do ((i 12) - (j 0 (index1+ j))) - ((>= i 32)) - (case format - (8 (setf (aref sequence j) (read-card8 i)) - (index-incf i)) - (16 (setf (aref sequence j) (read-card16 i)) - (index-incf i 2)) - (32 (setf (aref sequence j) (read-card32 i)) - (index-incf i 4)))) - sequence)) - -(defmacro client-message-event-put-sequence (format sequence) - `(ecase ,format - (8 (sequence-put 12 ,sequence - :format card8 - :end (min (length ,sequence) 20) - :appending t)) - (16 (sequence-put 12 ,sequence - :format card16 - :end (min (length ,sequence) 10) - :appending t)) - (32 (sequence-put 12 ,sequence - :format card32 - :end (min (length ,sequence) 5) - :appending t)))) - -;; Used only in declare-event -(define-accessor client-message-sequence (160) - ((index format) (declare (ignore index format)) `(client-message-event-get-sequence)) - ((index value format) (declare (ignore index)) - `(client-message-event-put-sequence ,format ,value))) - - -;;; -;;; Compound accessors -;;; Accessors that take other accessors as parameters -;;; -(define-accessor code (0) - ((index) (declare (ignore index)) '(read-card8 0)) - ((index value) (declare (ignore index)) `(write-card8 0 ,value)) - ((index value) (declare (ignore index)) `(write-card8 0 ,value))) - -(define-accessor length (0) - ((index) (declare (ignore index)) '(read-card16 2)) - ((index value) (declare (ignore index)) `(write-card16 2 ,value)) - ((index value) (declare (ignore index)) `(write-card16 2 ,value))) - -(deftype data () 'card8) - -(define-accessor data (0) - ;; Put data in byte 1 of the reqeust - ((index &optional stuff) (declare (ignore index)) - (if stuff - (if (consp stuff) - `(,(getify (car stuff)) 1 ,@(cdr stuff)) - `(,(getify stuff) 1)) - `(read-card8 1))) - ((index thing &optional stuff) - (if stuff - (if (consp stuff) - `(macrolet ((write-card32 (index value) index value)) - (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff)))) - `(,(putify stuff) 1 ,thing)) - `(write-card8 1 ,thing))) - ((index thing &optional stuff) - (if stuff - `(and (type? ,thing ',stuff) - ,(if (consp stuff) - `(macrolet ((write-card32 (index value) index value)) - (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff)))) - `(,(putify stuff) 1 ,thing))) - `(and (type? ,thing 'card8) (write-card8 1 ,thing))))) - -;; Macroexpand the result of OR-GET to allow the macros file to not be loaded -;; when using event-case. This is pretty gross. - -(defmacro or-expand (&rest forms &environment environment) - `(cond ,@(mapcar #'(lambda (forms) - (mapcar #'(lambda (form) - (clx-macroexpand form environment)) - forms)) - forms))) - -;; -;; the OR type -;; -(define-accessor or (32) - ;; Select from among several types (usually NULL and something else) - ((index &rest type-list &environment environment) - (do ((types type-list (cdr types)) - (value (gensym)) - (result)) - ((endp types) - `(let ((,value (read-card32 ,index))) - (macrolet ((read-card32 (index) index ',value) - (read-card29 (index) index ',value)) - ,(clx-macroexpand `(or-expand ,@(nreverse result)) environment)))) - (let ((item (car types)) - (args nil)) - (when (consp item) - (setq args (cdr item) - item (car item))) - (if (eq item 'null) ;; Special case for NULL - (push `((zerop ,value) nil) result) - (push - `((,(getify item) ,index ,@args)) - result))))) - - ((index value &rest type-list) - (do ((types type-list (cdr types)) - (result)) - ((endp types) - `(cond ,@(nreverse result) - ,@(when +type-check?+ - `((t (x-type-error ,value '(or ,@type-list))))))) - (let* ((type (car types)) - (type-name type) - (args nil)) - (when (consp type) - (setq args (cdr type) - type-name (car type))) - (push - `(,@(cond ((get type-name 'predicating-put) nil) - ((or +type-check?+ (cdr types)) `((type? ,value ',type))) - (t '(t))) - (,(putify type-name (get type-name 'predicating-put)) ,index ,value ,@args)) - result))))) - -;; -;; the MASK type... -;; is used to specify a subset of a collection of "optional" arguments. -;; A mask type consists of a 32 bit mask word followed by a word for each one-bit -;; in the mask. The MASK type is ALWAYS the LAST item in a request. -;; -(setf (get 'mask 'byte-width) nil) - -(defun mask-get (index type-values body-function) - (declare (type function body-function) - (dynamic-extent body-function)) - ;; This is a function, because it must return more than one form (called by get-put-items) - ;; Functions that use this must have a binding for %MASK - (let* ((bit 0) - (result - (mapcar - #'(lambda (form) - (if (atom form) - form ;; Hack to allow BODY-FUNCTION to return keyword/value pairs - (prog1 - `(when (logbitp ,bit %mask) - ;; Execute form when bit is set - ,form) - (incf bit)))) - (get-put-items - (+ index 4) type-values nil - #'(lambda (type index item args) - (declare (ignore index)) - (funcall body-function type '(* (incf %index) 4) item args)))))) - ;; First form must load %MASK - `(,@(when (atom (car result)) - (list (pop result))) - (progn (setq %mask (read-card32 ,index)) - (setq %index ,(ceiling index 4)) - ,(car result)) - ,@(cdr result)))) - -;; MASK-PUT - -(defun mask-put (index type-values body-function) - (declare (type function body-function) - (dynamic-extent body-function)) - ;; The MASK type writes a 32 bit mask with 1 bits for each non-nil value in TYPE-VALUES - ;; A 32 bit value follows for each non-nil value. - `((let ((%mask 0) - (%index ,index)) - ,@(let ((bit 1)) - (get-put-items - index type-values t - #'(lambda (type index item args) - (declare (ignore index)) - (if (or (symbolp item) (constantp item)) - `((unless (null ,item) - (setq %mask (logior %mask ,(shiftf bit (ash bit 1)))) - ,@(funcall body-function type - `(index-incf %index 4) item args))) - `((let ((.item. ,item)) - (unless (null .item.) - (setq %mask (logior %mask ,(shiftf bit (ash bit 1)))) - ,@(funcall body-function type - `(index-incf %index 4) '.item. args)))))))) - (write-card32 ,index %mask) - (write-card16 2 (index-ceiling (index-incf %index 4) 4)) - (incf (buffer-boffset %buffer) %index)))) - -(define-accessor progn (nil) - ;; Catch-all for inserting random code - ;; Note that code using this is then responsible for setting the request length - ((index statement) (declare (ignore index)) statement) - ((index statement) (declare (ignore index)) statement)) - - -; -; Wrapper macros, for use around the above -; -(defmacro type-check (value type) - value type - (when +type-check?+ - `(unless (type? ,value ,type) - (x-type-error ,value ,type)))) - -(defmacro check-put (index value type &rest args &environment env) - (let* ((var (if (or (symbolp value) (constantp value)) value '.value.)) - (body - (if (or (null (macroexpand `(type-check ,var ',type) env)) - (member type '(or progn pad8 pad16)) - (constantp value)) - `(,(putify type) ,index ,var ,@args) - ;; Do type checking - (if (get type 'predicating-put) - `(or (,(putify type t) ,index ,var ,@args) - (x-type-error ,var ',(if args `(,type ,@args) type))) - `(if (type? ,var ',type) - (,(putify type) ,index ,var ,@args) - (x-type-error ,var ',(if args `(,type ,@args) type))))))) - (if (eq var value) - body - `(let ((,var ,value)) - ,body)))) - -(defun get-put-items (index type-args putp &optional body-function) - (declare (type (or null function) body-function) - (dynamic-extent body-function)) - ;; Given a lists of the form (type item item ... item) - ;; Calls body-function with four arguments, a function name, - ;; index, item name, and optional arguments. - ;; The results are appended together and retured. - (unless body-function - (setq body-function - #'(lambda (type index item args) - `((check-put ,index ,item ,type ,@args))))) - (do* ((items type-args (cdr items)) - (type (caar items) (caar items)) - (args nil nil) - (result nil) - (sizes nil)) - ((endp items) (values result index sizes)) - (when (consp type) - (setq args (cdr type) - type (car type))) - (cond ((member type '(return buffer))) - ((eq type 'mask) ;; Hack to enable mask-get/put to return multiple values - (setq result - (append result (if putp - (mask-put index (cdar items) body-function) - (mask-get index (cdar items) body-function))) - index nil)) - (t (do* ((item (cdar items) (cdr item)) - (increment (index-increment type))) - ((endp item)) - (when (constantp index) - (case increment ;Round up index when needed - (2 (setq index (wround index))) - (4 (setq index (lround index))))) - (setq result - (append result (funcall body-function type index (car item) args))) - (when (constantp index) - ;; Variable length requests have null length increment. - ;; Variable length requests set the request size - ;; & maintain buffer pointers - (if (null increment) - (setq index nil) - (progn - (incf index increment) - (when (and increment (zerop increment)) (setq increment 1)) - (pushnew (* increment 8) sizes))))))))) - -(defmacro with-buffer-request-internal - ((buffer opcode &key length sizes &allow-other-keys) - &body type-args) - (multiple-value-bind (code index item-sizes) - (get-put-items 4 type-args t) - (let ((length (if length `(index+ ,length +requestsize+) '+requestsize+)) - (sizes (remove-duplicates (append '(8 16) item-sizes sizes)))) - `(with-buffer-output (,buffer :length ,length :sizes ,sizes) - (setf (buffer-last-request ,buffer) buffer-boffset) - (write-card8 0 ,opcode) ;; Stick in the opcode - ,@code - ,@(when index - (setq index (lround index)) - `((write-card16 2 ,(ceiling index 4)) - (setf (buffer-boffset ,buffer) (index+ buffer-boffset ,index)))) - (buffer-new-request-number ,buffer))))) - -(defmacro with-buffer-request - ((buffer opcode &rest options &key inline gc-force &allow-other-keys) - &body type-args &environment env) - (if (and (null inline) (macroexpand '(use-closures) env)) - `(flet ((.request-body. (.display.) - (declare (type display .display.)) - (with-buffer-request-internal (.display. ,opcode ,@options) - ,@type-args))) - (declare (dynamic-extent #'.request-body.)) - (,(if (eq (car (macroexpand '(with-buffer (buffer)) env)) 'progn) - 'with-buffer-request-function-nolock - 'with-buffer-request-function) - ,buffer ,gc-force #'.request-body.)) - `(let ((.display. ,buffer)) - (declare (type display .display.)) - (with-buffer (.display.) - ,@(when gc-force `((force-gcontext-changes-internal ,gc-force))) - (multiple-value-prog1 - (without-aborts - (with-buffer-request-internal (.display. ,opcode ,@options) - ,@type-args)) - (display-invoke-after-function .display.)))))) - -(defmacro with-buffer-request-and-reply - ((buffer opcode reply-size &key sizes multiple-reply inline) - type-args &body reply-forms &environment env) - (declare (indentation 0 4 1 4 2 1)) - (let* ((inner-reply-body - `(with-buffer-input (.reply-buffer. :display .display. - ,@(and sizes (list :sizes sizes))) - nil ,@reply-forms)) - (reply-body - (if (or (not (symbolp reply-size)) (constantp reply-size)) - inner-reply-body - `(let ((,reply-size (reply-data-size (the reply-buffer .reply-buffer.)))) - (declare (type array-index ,reply-size)) - ,inner-reply-body)))) - (if (and (null inline) (macroexpand '(use-closures) env)) - `(flet ((.request-body. (.display.) - (declare (type display .display.)) - (with-buffer-request-internal (.display. ,opcode) - ,@type-args)) - (.reply-body. (.display. .reply-buffer.) - (declare (type display .display.) - (type reply-buffer .reply-buffer.)) - (progn .display. .reply-buffer. nil) - ,reply-body)) - (declare (dynamic-extent #'.request-body. #'.reply-body.)) - (with-buffer-request-and-reply-function - ,buffer ,multiple-reply #'.request-body. #'.reply-body.)) - `(let ((.display. ,buffer) - (.pending-command. nil) - (.reply-buffer. nil)) - (declare (type display .display.) - (type (or null pending-command) .pending-command.) - (type (or null reply-buffer) .reply-buffer.)) - (unwind-protect - (progn - (with-buffer (.display.) - (setq .pending-command. (start-pending-command .display.)) - (without-aborts - (with-buffer-request-internal (.display. ,opcode) - ,@type-args)) - (buffer-force-output .display.) - (display-invoke-after-function .display.)) - ,@(if multiple-reply - `((loop - (setq .reply-buffer. (read-reply .display. .pending-command.)) - (when ,reply-body (return nil)) - (deallocate-reply-buffer (shiftf .reply-buffer. nil)))) - `((setq .reply-buffer. (read-reply .display. .pending-command.)) - ,reply-body))) - (when .reply-buffer. - (deallocate-reply-buffer .reply-buffer.)) - (when .pending-command. - (stop-pending-command .display. .pending-command.))))))) - -(defmacro compare-request ((index) &body body) - `(macrolet ((write-card32 (index item) `(= ,item (read-card32 ,index))) - (write-int32 (index item) `(= ,item (read-int32 ,index))) - (write-card29 (index item) `(= ,item (read-card29 ,index))) - (write-int29 (index item) `(= ,item (read-int29 ,index))) - (write-card16 (index item) `(= ,item (read-card16 ,index))) - (write-int16 (index item) `(= ,item (read-int16 ,index))) - (write-card8 (index item) `(= ,item (read-card8 ,index))) - (write-int8 (index item) `(= ,item (read-int8 ,index)))) - (macrolet ((type-check (value type) value type nil)) - (and ,@(get-put-items index body t))))) - -(defmacro put-items ((index) &body body) - `(progn ,@(get-put-items index body t))) - -(defmacro decode-type (type value) - ;; Given an integer and type, return the value - (let ((args nil)) - (when (consp type) - (setq args (cdr type) - type (car type))) - `(macrolet ((read-card29 (value) value) - (read-card32 (value) value) - (read-int32 (value) `(card32->int32 ,value)) - (read-card16 (value) value) - (read-int16 (value) `(card16->int16 ,value)) - (read-card8 (value) value) - (read-int8 (value) `(int8->card8 ,value))) - (,(getify type) ,value ,@args)))) - -(defmacro encode-type (type value) - ;; Given a value and type, return an integer - ;; When check-p, do type checking on value - (let ((args nil)) - (when (consp type) - (setq args (cdr type) - type (car type))) - `(macrolet ((write-card29 (index value) index value) - (write-card32 (index value) index value) - (write-int32 (index value) index `(int32->card32 ,value)) - (write-card16 (index value) index value) - (write-int16 (index value) index `(int16->card16 ,value)) - (write-card8 (index value) index value) - (write-int8 (index value) index `(int8->card8 ,value))) - (check-put 0 ,value ,type ,@args)))) - -(defmacro set-decode-type (type accessor value) - `(setf ,accessor (encode-type ,type ,value))) -(defsetf decode-type set-decode-type) - - -;;; -;;; Request codes -;;; - -(defconstant +x-createwindow+ 1) -(defconstant +x-changewindowattributes+ 2) -(defconstant +x-getwindowattributes+ 3) -(defconstant +x-destroywindow+ 4) -(defconstant +x-destroysubwindows+ 5) -(defconstant +x-changesaveset+ 6) -(defconstant +x-reparentwindow+ 7) -(defconstant +x-mapwindow+ 8) -(defconstant +x-mapsubwindows+ 9) -(defconstant +x-unmapwindow+ 10) -(defconstant +x-unmapsubwindows+ 11) -(defconstant +x-configurewindow+ 12) -(defconstant +x-circulatewindow+ 13) -(defconstant +x-getgeometry+ 14) -(defconstant +x-querytree+ 15) -(defconstant +x-internatom+ 16) -(defconstant +x-getatomname+ 17) -(defconstant +x-changeproperty+ 18) -(defconstant +x-deleteproperty+ 19) -(defconstant +x-getproperty+ 20) -(defconstant +x-listproperties+ 21) -(defconstant +x-setselectionowner+ 22) -(defconstant +x-getselectionowner+ 23) -(defconstant +x-convertselection+ 24) -(defconstant +x-sendevent+ 25) -(defconstant +x-grabpointer+ 26) -(defconstant +x-ungrabpointer+ 27) -(defconstant +x-grabbutton+ 28) -(defconstant +x-ungrabbutton+ 29) -(defconstant +x-changeactivepointergrab+ 30) -(defconstant +x-grabkeyboard+ 31) -(defconstant +x-ungrabkeyboard+ 32) -(defconstant +x-grabkey+ 33) -(defconstant +x-ungrabkey+ 34) -(defconstant +x-allowevents+ 35) -(defconstant +x-grabserver+ 36) -(defconstant +x-ungrabserver+ 37) -(defconstant +x-querypointer+ 38) -(defconstant +x-getmotionevents+ 39) -(defconstant +x-translatecoords+ 40) -(defconstant +x-warppointer+ 41) -(defconstant +x-setinputfocus+ 42) -(defconstant +x-getinputfocus+ 43) -(defconstant +x-querykeymap+ 44) -(defconstant +x-openfont+ 45) -(defconstant +x-closefont+ 46) -(defconstant +x-queryfont+ 47) -(defconstant +x-querytextextents+ 48) -(defconstant +x-listfonts+ 49) -(defconstant +x-listfontswithinfo+ 50) -(defconstant +x-setfontpath+ 51) -(defconstant +x-getfontpath+ 52) -(defconstant +x-createpixmap+ 53) -(defconstant +x-freepixmap+ 54) -(defconstant +x-creategc+ 55) -(defconstant +x-changegc+ 56) -(defconstant +x-copygc+ 57) -(defconstant +x-setdashes+ 58) -(defconstant +x-setcliprectangles+ 59) -(defconstant +x-freegc+ 60) -(defconstant +x-cleartobackground+ 61) -(defconstant +x-copyarea+ 62) -(defconstant +x-copyplane+ 63) -(defconstant +x-polypoint+ 64) -(defconstant +x-polyline+ 65) -(defconstant +x-polysegment+ 66) -(defconstant +x-polyrectangle+ 67) -(defconstant +x-polyarc+ 68) -(defconstant +x-fillpoly+ 69) -(defconstant +x-polyfillrectangle+ 70) -(defconstant +x-polyfillarc+ 71) -(defconstant +x-putimage+ 72) -(defconstant +x-getimage+ 73) -(defconstant +x-polytext8+ 74) -(defconstant +x-polytext16+ 75) -(defconstant +x-imagetext8+ 76) -(defconstant +x-imagetext16+ 77) -(defconstant +x-createcolormap+ 78) -(defconstant +x-freecolormap+ 79) -(defconstant +x-copycolormapandfree+ 80) -(defconstant +x-installcolormap+ 81) -(defconstant +x-uninstallcolormap+ 82) -(defconstant +x-listinstalledcolormaps+ 83) -(defconstant +x-alloccolor+ 84) -(defconstant +x-allocnamedcolor+ 85) -(defconstant +x-alloccolorcells+ 86) -(defconstant +x-alloccolorplanes+ 87) -(defconstant +x-freecolors+ 88) -(defconstant +x-storecolors+ 89) -(defconstant +x-storenamedcolor+ 90) -(defconstant +x-querycolors+ 91) -(defconstant +x-lookupcolor+ 92) -(defconstant +x-createcursor+ 93) -(defconstant +x-createglyphcursor+ 94) -(defconstant +x-freecursor+ 95) -(defconstant +x-recolorcursor+ 96) -(defconstant +x-querybestsize+ 97) -(defconstant +x-queryextension+ 98) -(defconstant +x-listextensions+ 99) -(defconstant +x-setkeyboardmapping+ 100) -(defconstant +x-getkeyboardmapping+ 101) -(defconstant +x-changekeyboardcontrol+ 102) -(defconstant +x-getkeyboardcontrol+ 103) -(defconstant +x-bell+ 104) -(defconstant +x-changepointercontrol+ 105) -(defconstant +x-getpointercontrol+ 106) -(defconstant +x-setscreensaver+ 107) -(defconstant +x-getscreensaver+ 108) -(defconstant +x-changehosts+ 109) -(defconstant +x-listhosts+ 110) -(defconstant +x-changeaccesscontrol+ 111) -(defconstant +x-changeclosedownmode+ 112) -(defconstant +x-killclient+ 113) -(defconstant +x-rotateproperties+ 114) -(defconstant +x-forcescreensaver+ 115) -(defconstant +x-setpointermapping+ 116) -(defconstant +x-getpointermapping+ 117) -(defconstant +x-setmodifiermapping+ 118) -(defconstant +x-getmodifiermapping+ 119) -(defconstant +x-nooperation+ 127) - -;;; Some macros for threaded lists - -(defmacro threaded-atomic-push (item list next type) - (let ((x (gensym)) - (y (gensym))) - `(let ((,x ,item)) - (declare (type ,type ,x)) - (loop - (let ((,y ,list)) - (declare (type (or null ,type) ,y) - #-clx-debugging - (optimize (speed 3) (safety 0))) - (setf (,next ,x) ,y) - (when (conditional-store ,list ,y ,x) - (return ,x))))))) - -(defmacro threaded-atomic-pop (list next type) - (let ((y (gensym))) - `(loop - (let ((,y ,list)) - (declare (type (or null ,type) ,y) - #-clx-debugging - (optimize (speed 3) (safety 0))) - (if (null ,y) - (return nil) - (when (conditional-store ,list ,y (,next (the ,type ,y))) - (setf (,next (the ,type ,y)) nil) - (return ,y))))))) - -(defmacro threaded-nconc (item list next type) - (let ((first (gensym)) - (x (gensym)) - (y (gensym)) - (z (gensym))) - `(let ((,z ,item) - (,first ,list)) - (declare (type ,type ,z) - (type (or null ,type) ,first) - #-clx-debugging - (optimize (speed 3) (safety 0))) - (if (null ,first) - (setf ,list ,z) - (do* ((,x ,first ,y) - (,y (,next ,x) (,next ,x))) - ((null ,y) - (setf (,next ,x) ,z) - ,first) - (declare (type ,type ,x) - (type (or null ,type) ,y))))))) - -(defmacro threaded-push (item list next type) - (let ((x (gensym))) - `(let ((,x ,item)) - (declare (type ,type ,x) - #-clx-debugging - (optimize (speed 3) (safety 0))) - (shiftf (,next ,x) ,list ,x) - ,x))) - -(defmacro threaded-pop (list next type) - (let ((x (gensym))) - `(let ((,x ,list)) - (declare (type (or null ,type) ,x) - #-clx-debugging - (optimize (speed 3) (safety 0))) - (when ,x - (shiftf ,list (,next (the ,type ,x)) nil)) - ,x))) - -(defmacro threaded-enqueue (item head tail next type) - (let ((x (gensym))) - `(let ((,x ,item)) - (declare (type ,type ,x) - #-clx-debugging - (optimize (speed 3) (safety 0))) - (if (null ,tail) - (threaded-nconc ,x ,head ,next ,type) - (threaded-nconc ,x (,next (the ,type ,tail)) ,next ,type)) - (setf ,tail ,x)))) - -(defmacro threaded-dequeue (head tail next type) - (let ((x (gensym))) - `(let ((,x ,head)) - (declare (type (or null ,type) ,x) - #-clx-debugging - (optimize (speed 3) (safety 0))) - (when ,x - (when (eq ,x ,tail) - (setf ,tail (,next (the ,type ,x)))) - (setf ,head (,next (the ,type ,x)))) - ,x))) - -(defmacro threaded-requeue (item head tail next type) - (let ((x (gensym))) - `(let ((,x ,item)) - (declare (type ,type ,x) - #-clx-debugging - (optimize (speed 3) (safety 0))) - (if (null ,tail) - (setf ,tail (setf ,head ,x)) - (shiftf (,next ,x) ,head ,x)) - ,x))) - -(defmacro threaded-dolist ((variable list next type) &body body) - `(block nil - (do* ((,variable ,list (,next (the ,type ,variable)))) - ((null ,variable)) - (declare (type (or null ,type) ,variable)) - ,@body))) - -(defmacro threaded-delete (item list next type) - (let ((x (gensym)) - (y (gensym)) - (z (gensym)) - (first (gensym))) - `(let ((,x ,item) - (,first ,list)) - (declare (type ,type ,x) - (type (or null ,type) ,first) - #-clx-debugging - (optimize (speed 3) (safety 0))) - (when ,first - (if (eq ,first ,x) - (setf ,first (setf ,list (,next ,x))) - (do* ((,y ,first ,z) - (,z (,next ,y) (,next ,y))) - ((or (null ,z) (eq ,z ,x)) - (when (eq ,z ,x) - (setf (,next ,y) (,next ,x)))) - (declare (type ,type ,y)) - (declare (type (or null ,type) ,z))))) - (setf (,next ,x) nil) - ,first))) - -(defmacro threaded-length (list next type) - (let ((x (gensym)) - (count (gensym))) - `(do ((,x ,list (,next (the ,type ,x))) - (,count 0 (index1+ ,count))) - ((null ,x) - ,count) - (declare (type (or null ,type) ,x) - (type array-index ,count) - #-clx-debugging - (optimize (speed 3) (safety 0)))))) - diff --git a/src/eclx/manager.lisp b/src/eclx/manager.lisp deleted file mode 100644 index cd9a28833..000000000 --- a/src/eclx/manager.lisp +++ /dev/null @@ -1,763 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;;; Window Manager Property functions - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; -#+cmu -(ext:file-comment - "$Header$") - -(in-package :xlib) - -(defun wm-name (window) - (declare (type window window)) - (declare (clx-values string)) - (get-property window :WM_NAME :type :STRING :result-type 'string :transform #'card8->char)) - -(defsetf wm-name (window) (name) - `(set-string-property ,window :WM_NAME ,name)) - -(defun set-string-property (window property string) - (declare (type window window) - (type keyword property) - (type stringable string)) - (change-property window property (string string) :STRING 8 :transform #'char->card8) - string) - -(defun wm-icon-name (window) - (declare (type window window)) - (declare (clx-values string)) - (get-property window :WM_ICON_NAME :type :STRING - :result-type 'string :transform #'card8->char)) - -(defsetf wm-icon-name (window) (name) - `(set-string-property ,window :WM_ICON_NAME ,name)) - -(defun wm-client-machine (window) - (declare (type window window)) - (declare (clx-values string)) - (get-property window :WM_CLIENT_MACHINE :type :STRING - :result-type 'string :transform #'card8->char)) - -(defsetf wm-client-machine (window) (name) - `(set-string-property ,window :WM_CLIENT_MACHINE ,name)) - -(defun get-wm-class (window) - (declare (type window window)) - (declare (clx-values (or null name-string) (or null class-string))) - (let ((value (get-property window :WM_CLASS :type :STRING :result-type '(vector card8)))) - (declare (type (or null (vector card8)) value)) - (when value - (let* ((name-len (position 0 (the (vector card8) value))) - (name (subseq (the (vector card8) value) 0 name-len)) - (class (subseq (the (vector card8) value) (1+ name-len) (1- (length value))))) - (values (and (plusp (length name)) (map 'string #'card8->char name)) - (and (plusp (length class)) (map 'string #'card8->char class))))))) - -(defun set-wm-class (window resource-name resource-class) - (declare (type window window) - (type (or null stringable) resource-name resource-class)) - (change-property window :WM_CLASS - (concatenate '(vector card8) - (map '(vector card8) #'char->card8 - (string (or resource-name ""))) - #(0) - (map '(vector card8) #'char->card8 - (string (or resource-class ""))) - #(0)) - :string 8) - (values)) - -(defun wm-command (window) - ;; Returns a list whose car is the command and - ;; whose cdr is the list of arguments - (declare (type window window)) - (declare (clx-values list)) - (do* ((command-string (get-property window :WM_COMMAND :type :STRING - :result-type '(vector card8))) - (command nil) - (start 0 (1+ end)) - (end 0) - (len (length command-string))) - ((>= start len) (nreverse command)) - (setq end (position 0 command-string :start start)) - (push (map 'string #'card8->char (subseq command-string start end)) - command))) - -(defsetf wm-command set-wm-command) -(defun set-wm-command (window command) - ;; Uses PRIN1 inside the ANSI common lisp form WITH-STANDARD-IO-SYNTAX (or - ;; equivalent), with elements of command separated by NULL characters. This - ;; enables - ;; (with-standard-io-syntax (mapcar #'read-from-string (wm-command window))) - ;; to recover a lisp command. - (declare (type window window) - (type list command)) - (change-property window :WM_COMMAND - (apply #'concatenate '(vector card8) - (mapcan #'(lambda (c) - (list (map '(vector card8) #'char->card8 - (with-output-to-string (stream) - (with-standard-io-syntax - (prin1 c stream)))) - #(0))) - command)) - :string 8) - command) - -;;----------------------------------------------------------------------------- -;; WM_HINTS - -(def-clx-class (wm-hints) - (input nil :type (or null (member :off :on))) - (initial-state nil :type (or null (member :dont-care :normal :zoom :iconic :inactive))) - (icon-pixmap nil :type (or null pixmap)) - (icon-window nil :type (or null window)) - (icon-x nil :type (or null card16)) - (icon-y nil :type (or null card16)) - (icon-mask nil :type (or null pixmap)) - (window-group nil :type (or null resource-id)) - (flags 0 :type card32) ;; Extension-hook. Exclusive-Or'ed with the FLAGS field - ;; may be extended in the future - ) - -(defun wm-hints (window) - (declare (type window window)) - (declare (clx-values wm-hints)) - (let ((prop (get-property window :WM_HINTS :type :WM_HINTS :result-type 'vector))) - (when prop - (decode-wm-hints prop (window-display window))))) - -(defsetf wm-hints set-wm-hints) -(defun set-wm-hints (window wm-hints) - (declare (type window window) - (type wm-hints wm-hints)) - (declare (clx-values wm-hints)) - (change-property window :WM_HINTS (encode-wm-hints wm-hints) :WM_HINTS 32) - wm-hints) - -(defun decode-wm-hints (vector display) - (declare (type (simple-vector 9) vector) - (type display display)) - (declare (clx-values wm-hints)) - (let ((input-hint 0) - (state-hint 1) - (icon-pixmap-hint 2) - (icon-window-hint 3) - (icon-position-hint 4) - (icon-mask-hint 5) - (window-group-hint 6)) - (let ((flags (aref vector 0)) - (hints (make-wm-hints)) - (%buffer display)) - (declare (type card32 flags) - (type wm-hints hints) - (type display %buffer)) - (setf (wm-hints-flags hints) flags) - (when (logbitp input-hint flags) - (setf (wm-hints-input hints) (decode-type (member :off :on) (aref vector 1)))) - (when (logbitp state-hint flags) - (setf (wm-hints-initial-state hints) - (decode-type (member :dont-care :normal :zoom :iconic :inactive) - (aref vector 2)))) - (when (logbitp icon-pixmap-hint flags) - (setf (wm-hints-icon-pixmap hints) (decode-type pixmap (aref vector 3)))) - (when (logbitp icon-window-hint flags) - (setf (wm-hints-icon-window hints) (decode-type window (aref vector 4)))) - (when (logbitp icon-position-hint flags) - (setf (wm-hints-icon-x hints) (aref vector 5) - (wm-hints-icon-y hints) (aref vector 6))) - (when (logbitp icon-mask-hint flags) - (setf (wm-hints-icon-mask hints) (decode-type pixmap (aref vector 7)))) - (when (and (logbitp window-group-hint flags) (> (length vector) 7)) - (setf (wm-hints-window-group hints) (aref vector 8))) - hints))) - - -(defun encode-wm-hints (wm-hints) - (declare (type wm-hints wm-hints)) - (declare (clx-values simple-vector)) - (let ((input-hint #b1) - (state-hint #b10) - (icon-pixmap-hint #b100) - (icon-window-hint #b1000) - (icon-position-hint #b10000) - (icon-mask-hint #b100000) - (window-group-hint #b1000000) - (mask #b1111111) - ) - (let ((vector (make-array 9 :initial-element 0)) - (flags 0)) - (declare (type (simple-vector 9) vector) - (type card16 flags)) - (when (wm-hints-input wm-hints) - (setf flags input-hint - (aref vector 1) (encode-type (member :off :on) (wm-hints-input wm-hints)))) - (when (wm-hints-initial-state wm-hints) - (setf flags (logior flags state-hint) - (aref vector 2) (encode-type (member :dont-care :normal :zoom :iconic :inactive) - (wm-hints-initial-state wm-hints)))) - (when (wm-hints-icon-pixmap wm-hints) - (setf flags (logior flags icon-pixmap-hint) - (aref vector 3) (encode-type pixmap (wm-hints-icon-pixmap wm-hints)))) - (when (wm-hints-icon-window wm-hints) - (setf flags (logior flags icon-window-hint) - (aref vector 4) (encode-type window (wm-hints-icon-window wm-hints)))) - (when (and (wm-hints-icon-x wm-hints) (wm-hints-icon-y wm-hints)) - (setf flags (logior flags icon-position-hint) - (aref vector 5) (encode-type card16 (wm-hints-icon-x wm-hints)) - (aref vector 6) (encode-type card16 (wm-hints-icon-y wm-hints)))) - (when (wm-hints-icon-mask wm-hints) - (setf flags (logior flags icon-mask-hint) - (aref vector 7) (encode-type pixmap (wm-hints-icon-mask wm-hints)))) - (when (wm-hints-window-group wm-hints) - (setf flags (logior flags window-group-hint) - (aref vector 8) (wm-hints-window-group wm-hints))) - (setf (aref vector 0) (logior flags (logandc2 (wm-hints-flags wm-hints) mask))) - vector))) - -;;----------------------------------------------------------------------------- -;; WM_SIZE_HINTS - -(def-clx-class (wm-size-hints) - (user-specified-position-p nil :type generalized-boolean) ;; True when user specified x y - (user-specified-size-p nil :type generalized-boolean) ;; True when user specified width height - (x nil :type (or null int16)) ;; Obsolete - (y nil :type (or null int16)) ;; Obsolete - (width nil :type (or null card16)) ;; Obsolete - (height nil :type (or null card16)) ;; Obsolete - (min-width nil :type (or null card16)) - (min-height nil :type (or null card16)) - (max-width nil :type (or null card16)) - (max-height nil :type (or null card16)) - (width-inc nil :type (or null card16)) - (height-inc nil :type (or null card16)) - (min-aspect nil :type (or null number)) - (max-aspect nil :type (or null number)) - (base-width nil :type (or null card16)) - (base-height nil :type (or null card16)) - (win-gravity nil :type (or null win-gravity)) - (program-specified-position-p nil :type generalized-boolean) ;; True when program specified x y - (program-specified-size-p nil :type generalized-boolean) ;; True when program specified width height - ) - - -(defun wm-normal-hints (window) - (declare (type window window)) - (declare (clx-values wm-size-hints)) - (decode-wm-size-hints (get-property window :WM_NORMAL_HINTS :type :WM_SIZE_HINTS :result-type 'vector))) - -(defsetf wm-normal-hints set-wm-normal-hints) -(defun set-wm-normal-hints (window hints) - (declare (type window window) - (type wm-size-hints hints)) - (declare (clx-values wm-size-hints)) - (change-property window :WM_NORMAL_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32) - hints) - -;;; OBSOLETE -(defun wm-zoom-hints (window) - (declare (type window window)) - (declare (clx-values wm-size-hints)) - (decode-wm-size-hints (get-property window :WM_ZOOM_HINTS :type :WM_SIZE_HINTS :result-type 'vector))) - -;;; OBSOLETE -(defsetf wm-zoom-hints set-wm-zoom-hints) -;;; OBSOLETE -(defun set-wm-zoom-hints (window hints) - (declare (type window window) - (type wm-size-hints hints)) - (declare (clx-values wm-size-hints)) - (change-property window :WM_ZOOM_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32) - hints) - -(defun decode-wm-size-hints (vector) - (declare (type (or null (simple-vector *)) vector)) - (declare (clx-values (or null wm-size-hints))) - (when vector - (let ((flags (aref vector 0)) - (hints (make-wm-size-hints))) - (declare (type card16 flags) - (type wm-size-hints hints)) - (setf (wm-size-hints-user-specified-position-p hints) (logbitp 0 flags)) - (setf (wm-size-hints-user-specified-size-p hints) (logbitp 1 flags)) - (setf (wm-size-hints-program-specified-position-p hints) (logbitp 2 flags)) - (setf (wm-size-hints-program-specified-size-p hints) (logbitp 3 flags)) - (when (logbitp 4 flags) - (setf (wm-size-hints-min-width hints) (aref vector 5) - (wm-size-hints-min-height hints) (aref vector 6))) - (when (logbitp 5 flags) - (setf (wm-size-hints-max-width hints) (aref vector 7) - (wm-size-hints-max-height hints) (aref vector 8))) - (when (logbitp 6 flags) - (setf (wm-size-hints-width-inc hints) (aref vector 9) - (wm-size-hints-height-inc hints) (aref vector 10))) - (when (logbitp 7 flags) - (setf (wm-size-hints-min-aspect hints) (/ (aref vector 11) (aref vector 12)) - (wm-size-hints-max-aspect hints) (/ (aref vector 13) (aref vector 14)))) - (when (> (length vector) 15) - ;; This test is for backwards compatibility since old Xlib programs - ;; can set a size-hints structure that is too small. See ICCCM. - (when (logbitp 8 flags) - (setf (wm-size-hints-base-width hints) (aref vector 15) - (wm-size-hints-base-height hints) (aref vector 16))) - (when (logbitp 9 flags) - (setf (wm-size-hints-win-gravity hints) - (decode-type (member-vector *win-gravity-vector*) (aref vector 17))))) - ;; Obsolete fields - (when (or (logbitp 0 flags) (logbitp 2 flags)) - (setf (wm-size-hints-x hints) (card32->int32 (aref vector 1)) - (wm-size-hints-y hints) (card32->int32 (aref vector 2)))) - (when (or (logbitp 1 flags) (logbitp 3 flags)) - (setf (wm-size-hints-width hints) (aref vector 3) - (wm-size-hints-height hints) (aref vector 4))) - hints))) - -(defun encode-wm-size-hints (hints) - (declare (type wm-size-hints hints)) - (declare (clx-values simple-vector)) - (let ((vector (make-array 18 :initial-element 0)) - (flags 0)) - (declare (type (simple-vector 18) vector) - (type card16 flags)) - (when (wm-size-hints-user-specified-position-p hints) - (setf (ldb (byte 1 0) flags) 1)) - (when (wm-size-hints-user-specified-size-p hints) - (setf (ldb (byte 1 1) flags) 1)) - (when (wm-size-hints-program-specified-position-p hints) - (setf (ldb (byte 1 2) flags) 1)) - (when (wm-size-hints-program-specified-size-p hints) - (setf (ldb (byte 1 3) flags) 1)) - (when (and (wm-size-hints-min-width hints) (wm-size-hints-min-height hints)) - (setf (ldb (byte 1 4) flags) 1 - (aref vector 5) (wm-size-hints-min-width hints) - (aref vector 6) (wm-size-hints-min-height hints))) - (when (and (wm-size-hints-max-width hints) (wm-size-hints-max-height hints)) - (setf (ldb (byte 1 5) flags) 1 - (aref vector 7) (wm-size-hints-max-width hints) - (aref vector 8) (wm-size-hints-max-height hints))) - (when (and (wm-size-hints-width-inc hints) (wm-size-hints-height-inc hints)) - (setf (ldb (byte 1 6) flags) 1 - (aref vector 9) (wm-size-hints-width-inc hints) - (aref vector 10) (wm-size-hints-height-inc hints))) - (let ((min-aspect (wm-size-hints-min-aspect hints)) - (max-aspect (wm-size-hints-max-aspect hints))) - (when (and min-aspect max-aspect) - (setf (ldb (byte 1 7) flags) 1 - min-aspect (rationalize min-aspect) - max-aspect (rationalize max-aspect) - (aref vector 11) (numerator min-aspect) - (aref vector 12) (denominator min-aspect) - (aref vector 13) (numerator max-aspect) - (aref vector 14) (denominator max-aspect)))) - (when (and (wm-size-hints-base-width hints) - (wm-size-hints-base-height hints)) - (setf (ldb (byte 1 8) flags) 1 - (aref vector 15) (wm-size-hints-base-width hints) - (aref vector 16) (wm-size-hints-base-height hints))) - (when (wm-size-hints-win-gravity hints) - (setf (ldb (byte 1 9) flags) 1 - (aref vector 17) (encode-type - (member-vector *win-gravity-vector*) - (wm-size-hints-win-gravity hints)))) - ;; Obsolete fields - (when (and (wm-size-hints-x hints) (wm-size-hints-y hints)) - (unless (wm-size-hints-user-specified-position-p hints) - (setf (ldb (byte 1 2) flags) 1)) - (setf (aref vector 1) (wm-size-hints-x hints) - (aref vector 2) (wm-size-hints-y hints))) - (when (and (wm-size-hints-width hints) (wm-size-hints-height hints)) - (unless (wm-size-hints-user-specified-size-p hints) - (setf (ldb (byte 1 3) flags) 1)) - (setf (aref vector 3) (wm-size-hints-width hints) - (aref vector 4) (wm-size-hints-height hints))) - (setf (aref vector 0) flags) - vector)) - -;;----------------------------------------------------------------------------- -;; Icon_Size - -;; Use the same intermediate structure as WM_SIZE_HINTS - -(defun icon-sizes (window) - (declare (type window window)) - (declare (clx-values wm-size-hints)) - (let ((vector (get-property window :WM_ICON_SIZE :type :WM_ICON_SIZE :result-type 'vector))) - (declare (type (or null (simple-vector 6)) vector)) - (when vector - (make-wm-size-hints - :min-width (aref vector 0) - :min-height (aref vector 1) - :max-width (aref vector 2) - :max-height (aref vector 3) - :width-inc (aref vector 4) - :height-inc (aref vector 5))))) - -(defsetf icon-sizes set-icon-sizes) -(defun set-icon-sizes (window wm-size-hints) - (declare (type window window) - (type wm-size-hints wm-size-hints)) - (let ((vector (vector (wm-size-hints-min-width wm-size-hints) - (wm-size-hints-min-height wm-size-hints) - (wm-size-hints-max-width wm-size-hints) - (wm-size-hints-max-height wm-size-hints) - (wm-size-hints-width-inc wm-size-hints) - (wm-size-hints-height-inc wm-size-hints)))) - (change-property window :WM_ICON_SIZE vector :WM_ICON_SIZE 32) - wm-size-hints)) - -;;----------------------------------------------------------------------------- -;; WM-Protocols - -(defun wm-protocols (window) - (map 'list #'(lambda (id) (atom-name (window-display window) id)) - (get-property window :WM_PROTOCOLS :type :ATOM))) - -(defsetf wm-protocols set-wm-protocols) -(defun set-wm-protocols (window protocols) - (change-property window :WM_PROTOCOLS - (map 'list #'(lambda (atom) (intern-atom (window-display window) atom)) - protocols) - :ATOM 32) - protocols) - -;;----------------------------------------------------------------------------- -;; WM-Colormap-windows - -(defun wm-colormap-windows (window) - (values (get-property window :WM_COLORMAP_WINDOWS :type :WINDOW - :transform #'(lambda (id) - (lookup-window (window-display window) id))))) - -(defsetf wm-colormap-windows set-wm-colormap-windows) -(defun set-wm-colormap-windows (window colormap-windows) - (change-property window :WM_COLORMAP_WINDOWS colormap-windows :WINDOW 32 - :transform #'window-id) - colormap-windows) - -;;----------------------------------------------------------------------------- -;; Transient-For - -(defun transient-for (window) - (let ((prop (get-property window :WM_TRANSIENT_FOR :type :WINDOW :result-type 'list))) - (and prop (lookup-window (window-display window) (car prop))))) - -(defsetf transient-for set-transient-for) -(defun set-transient-for (window transient) - (declare (type window window transient)) - (change-property window :WM_TRANSIENT_FOR (list (window-id transient)) :WINDOW 32) - transient) - -;;----------------------------------------------------------------------------- -;; Set-WM-Properties - -(defun set-wm-properties (window &rest options &key - name icon-name resource-name resource-class command - client-machine hints normal-hints zoom-hints - ;; the following are used for wm-normal-hints - (user-specified-position-p nil usppp) - (user-specified-size-p nil usspp) - (program-specified-position-p nil psppp) - (program-specified-size-p nil psspp) - x y width height min-width min-height max-width max-height - width-inc height-inc min-aspect max-aspect - base-width base-height win-gravity - ;; the following are used for wm-hints - input initial-state icon-pixmap icon-window - icon-x icon-y icon-mask window-group) - ;; Set properties for WINDOW. - (declare (arglist window &rest options &key - name icon-name resource-name resource-class command - client-machine hints normal-hints - ;; the following are used for wm-normal-hints - user-specified-position-p user-specified-size-p - program-specified-position-p program-specified-size-p - min-width min-height max-width max-height - width-inc height-inc min-aspect max-aspect - base-width base-height win-gravity - ;; the following are used for wm-hints - input initial-state icon-pixmap icon-window - icon-x icon-y icon-mask window-group)) - (declare (type window window) - (type (or null stringable) name icon-name resource-name resource-class client-machine) - (type (or null list) command) - (type (or null wm-hints) hints) - (type (or null wm-size-hints) normal-hints zoom-hints) - (type generalized-boolean user-specified-position-p user-specified-size-p) - (type generalized-boolean program-specified-position-p program-specified-size-p) - (type (or null int16) x y) - (type (or null card16) width height min-width min-height max-width max-height width-inc height-inc base-width base-height) - (type (or null win-gravity) win-gravity) - (type (or null number) min-aspect max-aspect) - (type (or null (member :off :on)) input) - (type (or null (member :dont-care :normal :zoom :iconic :inactive)) initial-state) - (type (or null pixmap) icon-pixmap icon-mask) - (type (or null window) icon-window) - (type (or null card16) icon-x icon-y) - (type (or null resource-id) window-group) - (dynamic-extent options)) - (when name (setf (wm-name window) name)) - (when icon-name (setf (wm-icon-name window) icon-name)) - (when client-machine (setf (wm-client-machine window) client-machine)) - (when (or resource-name resource-class) - (set-wm-class window resource-name resource-class)) - (when command (setf (wm-command window) command)) - ;; WM-HINTS - (if (dolist (arg '(:input :initial-state :icon-pixmap :icon-window - :icon-x :icon-y :icon-mask :window-group)) - (when (getf options arg) (return t))) - (let ((wm-hints (if hints (copy-wm-hints hints) (make-wm-hints)))) - (when input (setf (wm-hints-input wm-hints) input)) - (when initial-state (setf (wm-hints-initial-state wm-hints) initial-state)) - (when icon-pixmap (setf (wm-hints-icon-pixmap wm-hints) icon-pixmap)) - (when icon-window (setf (wm-hints-icon-window wm-hints) icon-window)) - (when icon-x (setf (wm-hints-icon-x wm-hints) icon-x)) - (when icon-y (setf (wm-hints-icon-y wm-hints) icon-y)) - (when icon-mask (setf (wm-hints-icon-mask wm-hints) icon-mask)) - (when window-group (setf (wm-hints-window-group wm-hints) window-group)) - (setf (wm-hints window) wm-hints)) - (when hints (setf (wm-hints window) hints))) - ;; WM-NORMAL-HINTS - (if (dolist (arg '(:x :y :width :height :min-width :min-height :max-width :max-height - :width-inc :height-inc :min-aspect :max-aspect - :user-specified-position-p :user-specified-size-p - :program-specified-position-p :program-specified-size-p - :base-width :base-height :win-gravity)) - (when (getf options arg) (return t))) - (let ((size (if normal-hints (copy-wm-size-hints normal-hints) (make-wm-size-hints)))) - (when x (setf (wm-size-hints-x size) x)) - (when y (setf (wm-size-hints-y size) y)) - (when width (setf (wm-size-hints-width size) width)) - (when height (setf (wm-size-hints-height size) height)) - (when min-width (setf (wm-size-hints-min-width size) min-width)) - (when min-height (setf (wm-size-hints-min-height size) min-height)) - (when max-width (setf (wm-size-hints-max-width size) max-width)) - (when max-height (setf (wm-size-hints-max-height size) max-height)) - (when width-inc (setf (wm-size-hints-width-inc size) width-inc)) - (when height-inc (setf (wm-size-hints-height-inc size) height-inc)) - (when min-aspect (setf (wm-size-hints-min-aspect size) min-aspect)) - (when max-aspect (setf (wm-size-hints-max-aspect size) max-aspect)) - (when base-width (setf (wm-size-hints-base-width size) base-width)) - (when base-height (setf (wm-size-hints-base-height size) base-height)) - (when win-gravity (setf (wm-size-hints-win-gravity size) win-gravity)) - (when usppp - (setf (wm-size-hints-user-specified-position-p size) user-specified-position-p)) - (when usspp - (setf (wm-size-hints-user-specified-size-p size) user-specified-size-p)) - (when psppp - (setf (wm-size-hints-program-specified-position-p size) program-specified-position-p)) - (when psspp - (setf (wm-size-hints-program-specified-size-p size) program-specified-size-p)) - (setf (wm-normal-hints window) size)) - (when normal-hints (setf (wm-normal-hints window) normal-hints))) - (when zoom-hints (setf (wm-zoom-hints window) zoom-hints)) - ) - -;;; OBSOLETE -(defun set-standard-properties (window &rest options) - (declare (dynamic-extent options)) - (apply #'set-wm-properties window options)) - -;;----------------------------------------------------------------------------- -;; WM Control - -(defun iconify-window (window screen) - (declare (type window window) - (type screen screen)) - (let ((root (screen-root screen))) - (declare (type window root)) - (send-event root :client-message '(:substructure-redirect :substructure-notify) - :window window :format 32 :type :WM_CHANGE_STATE :data (list 3)))) - -(defun withdraw-window (window screen) - (declare (type window window) - (type screen screen)) - (unmap-window window) - (let ((root (screen-root screen))) - (declare (type window root)) - (send-event root :unmap-notify '(:substructure-redirect :substructure-notify) - :window window :event-window root :configure-p nil))) - - -;;----------------------------------------------------------------------------- -;; Colormaps - -(def-clx-class (standard-colormap (:copier nil) (:predicate nil)) - (colormap nil :type (or null colormap)) - (base-pixel 0 :type pixel) - (max-color nil :type (or null color)) - (mult-color nil :type (or null color)) - (visual nil :type (or null visual-info)) - (kill nil :type (or (member nil :release-by-freeing-colormap) - drawable gcontext cursor colormap font))) - -(defun rgb-colormaps (window property) - (declare (type window window) - (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP - :RGB_GREEN_MAP :RGB_BLUE_MAP) property)) - (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector))) - (declare (type (or null simple-vector) prop)) - (when prop - (list (make-standard-colormap - :colormap (lookup-colormap (window-display window) (aref prop 0)) - :base-pixel (aref prop 7) - :max-color (make-color :red (card16->rgb-val (aref prop 1)) - :green (card16->rgb-val (aref prop 3)) - :blue (card16->rgb-val (aref prop 5))) - :mult-color (make-color :red (card16->rgb-val (aref prop 2)) - :green (card16->rgb-val (aref prop 4)) - :blue (card16->rgb-val (aref prop 6))) - :visual (and (<= 9 (length prop)) - (visual-info (window-display window) (aref prop 8))) - :kill (and (<= 10 (length prop)) - (let ((killid (aref prop 9))) - (if (= killid 1) - :release-by-freeing-colormap - (lookup-resource-id (window-display window) killid))))))))) - -(defsetf rgb-colormaps set-rgb-colormaps) -(defun set-rgb-colormaps (window property maps) - (declare (type window window) - (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP - :RGB_GREEN_MAP :RGB_BLUE_MAP) property) - (type list maps)) - (let ((prop (make-array (* 10 (length maps)) :element-type 'card32)) - (index -1)) - (dolist (map maps) - (setf (aref prop (incf index)) - (encode-type colormap (standard-colormap-colormap map))) - (setf (aref prop (incf index)) - (encode-type rgb-val (color-red (standard-colormap-max-color map)))) - (setf (aref prop (incf index)) - (encode-type rgb-val (color-red (standard-colormap-mult-color map)))) - (setf (aref prop (incf index)) - (encode-type rgb-val (color-green (standard-colormap-max-color map)))) - (setf (aref prop (incf index)) - (encode-type rgb-val (color-green (standard-colormap-mult-color map)))) - (setf (aref prop (incf index)) - (encode-type rgb-val (color-blue (standard-colormap-max-color map)))) - (setf (aref prop (incf index)) - (encode-type rgb-val (color-blue (standard-colormap-mult-color map)))) - (setf (aref prop (incf index)) - (standard-colormap-base-pixel map)) - (setf (aref prop (incf index)) - (visual-info-id (standard-colormap-visual map))) - (setf (aref prop (incf index)) - (let ((kill (standard-colormap-kill map))) - (etypecase kill - (symbol - (ecase kill - ((nil) 0) - ((:release-by-freeing-colormap) 1))) - (drawable (drawable-id kill)) - (gcontext (gcontext-id kill)) - (cursor (cursor-id kill)) - (colormap (colormap-id kill)) - (font (font-id kill)))))) - (change-property window property prop :RGB_COLOR_MAP 32))) - -;;; OBSOLETE -(defun get-standard-colormap (window property) - (declare (type window window) - (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP - :RGB_GREEN_MAP :RGB_BLUE_MAP) property)) - (declare (clx-values colormap base-pixel max-color mult-color)) - (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector))) - (declare (type (or null simple-vector) prop)) - (when prop - (values (lookup-colormap (window-display window) (aref prop 0)) - (aref prop 7) ;Base Pixel - (make-color :red (card16->rgb-val (aref prop 1)) ;Max Color - :green (card16->rgb-val (aref prop 3)) - :blue (card16->rgb-val (aref prop 5))) - (make-color :red (card16->rgb-val (aref prop 2)) ;Mult color - :green (card16->rgb-val (aref prop 4)) - :blue (card16->rgb-val (aref prop 6))))))) - -;;; OBSOLETE -(defun set-standard-colormap (window property colormap base-pixel max-color mult-color) - (declare (type window window) - (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP - :RGB_GREEN_MAP :RGB_BLUE_MAP) property) - (type colormap colormap) - (type pixel base-pixel) - (type color max-color mult-color)) - (let ((prop (vector (encode-type colormap colormap) - (encode-type rgb-val (color-red max-color)) - (encode-type rgb-val (color-red mult-color)) - (encode-type rgb-val (color-green max-color)) - (encode-type rgb-val (color-green mult-color)) - (encode-type rgb-val (color-blue max-color)) - (encode-type rgb-val (color-blue mult-color)) - base-pixel))) - (change-property window property prop :RGB_COLOR_MAP 32))) - -;;----------------------------------------------------------------------------- -;; Cut-Buffers - -(defun cut-buffer (display &key (buffer 0) (type :STRING) (result-type 'string) - (transform #'card8->char) (start 0) end) - ;; Return the contents of cut-buffer BUFFER - (declare (type display display) - (type (integer 0 7) buffer) - (type xatom type) - (type array-index start) - (type (or null array-index) end) - (type t result-type) ;a sequence type - (type (or null (function (integer) t)) transform)) - (declare (clx-values sequence type format bytes-after)) - (let* ((root (screen-root (first (display-roots display)))) - (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 - :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7) - buffer))) - (get-property root property :type type :result-type result-type - :start start :end end :transform transform))) - -(defun (setf cut-buffer) - (data display &key (buffer 0) (type :STRING) (format 8) - (start 0) end (transform #'char->card8)) - (declare (type sequence data) - (type display display) - (type (integer 0 7) buffer) - (type xatom type) - (type (member 8 16 32) format) - (type array-index start) - (type (or null array-index) end) - (type (or null (function (integer) t)) transform)) - (let* ((root (screen-root (first (display-roots display)))) - (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 - :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7) - buffer))) - (change-property root property data type format :transform transform :start start :end end) - data)) - -(defun rotate-cut-buffers (display &optional (delta 1) (careful-p t)) - ;; Positive rotates left, negative rotates right (opposite of actual protocol request). - ;; When careful-p, ensure all cut-buffer properties are defined, to prevent errors. - (declare (type display display) - (type int16 delta) - (type generalized-boolean careful-p)) - (let* ((root (screen-root (first (display-roots display)))) - (buffers '#(:cut_buffer0 :cut_buffer1 :cut_buffer2 :cut_buffer3 - :cut_buffer4 :cut_buffer5 :cut_buffer6 :cut_buffer7))) - (when careful-p - (let ((props (list-properties root))) - (dotimes (i 8) - (unless (member (aref buffers i) props) - (setf (cut-buffer display :buffer i) ""))))) - (rotate-properties root buffers delta))) - diff --git a/src/eclx/package.lisp b/src/eclx/package.lisp deleted file mode 100644 index dffa2e01e..000000000 --- a/src/eclx/package.lisp +++ /dev/null @@ -1,168 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: Yes; -*- - -;;; Copyright 1990 Massachusetts Institute of Technology, Cambridge, -;;; Massachusetts. All Rights Reserved. -;;; -;;; Permission to use, copy, modify, and distribute this software and its -;;; documentation for any purpose and without fee is hereby granted, provided -;;; that the above copyright notice appear in all copies and that both that -;;; copyright notice and this permission notice appear in supporting -;;; documentation, and that the name MIT not be used in advertising or -;;; publicity pertaining to distribution of the software without specific, -;;; written prior permission. -#+cmu -(ext:file-comment - "$Header$") - -;;; The ANSI Common Lisp way - -(common-lisp:in-package :common-lisp-user) - -(defpackage xlib - (:use common-lisp) - (:size 3000) - (:export - *version* access-control access-error access-hosts - activate-screen-saver add-access-host add-resource add-to-save-set - alist alloc-color alloc-color-cells alloc-color-planes alloc-error - allow-events angle arc-seq array-index atom-error atom-name - bell bit-gravity bitmap bitmap-format bitmap-format-lsb-first-p - bitmap-format-p bitmap-format-pad bitmap-format-unit bitmap-image - boole-constant boolean card16 card29 card32 card8 - card8->char change-active-pointer-grab change-keyboard-control - change-keyboard-mapping change-pointer-control change-property - char->card8 char-ascent char-attributes char-descent - char-left-bearing char-right-bearing char-width character->keysyms - character-in-map-p circulate-window-down circulate-window-up clear-area - close-display close-down-mode close-font closed-display color - color-blue color-green color-p color-red color-rgb colormap - colormap-display colormap-equal colormap-error colormap-id colormap-p - colormap-plist colormap-visual-info connection-failure convert-selection - copy-area copy-colormap-and-free copy-gcontext copy-gcontext-components - copy-image copy-plane create-colormap create-cursor - create-gcontext create-glyph-cursor create-image create-pixmap - create-window cursor cursor-display cursor-equal cursor-error - cursor-id cursor-p cursor-plist cut-buffer declare-event decode-core-error - default-error-handler default-keysym-index default-keysym-translate - define-error define-extension define-gcontext-accessor - define-keysym define-keysym-set delete-property delete-resource - destroy-subwindows destroy-window device-busy device-event-mask - device-event-mask-class discard-current-event discard-font-info display - display-after-function display-authorization-data display-authorization-name - display-bitmap-format display-byte-order display-default-screen - display-display display-error-handler display-finish-output - display-force-output display-host display-image-lsb-first-p - display-invoke-after-function display-keycode-range display-max-keycode - display-max-request-length display-min-keycode display-motion-buffer-size - display-nscreens display-p display-pixmap-formats display-plist - display-protocol-major-version display-protocol-minor-version - display-protocol-version display-release-number - display-report-asynchronous-errors display-resource-id-base - display-resource-id-mask display-roots display-vendor - display-vendor-name display-xdefaults display-xid draw-arc - draw-arcs draw-direction draw-glyph draw-glyphs draw-image-glyph - draw-image-glyphs draw-line draw-lines draw-point draw-points - draw-rectangle draw-rectangles draw-segments drawable - drawable-border-width drawable-depth drawable-display drawable-equal - drawable-error drawable-height drawable-id drawable-p - drawable-plist drawable-root drawable-width drawable-x drawable-y - error-key event-case event-cond event-handler event-key - event-listen event-mask event-mask-class extension-opcode - find-atom font font-all-chars-exist-p font-ascent - font-default-char font-descent font-direction font-display - font-equal font-error font-id font-max-byte1 font-max-byte2 - font-max-char font-min-byte1 font-min-byte2 font-min-char - font-name font-p font-path font-plist font-properties - font-property fontable force-gcontext-changes free-colormap - free-colors free-cursor free-gcontext free-pixmap gcontext - gcontext-arc-mode gcontext-background - gcontext-cache-p gcontext-cap-style - gcontext-clip-mask gcontext-clip-ordering gcontext-clip-x - gcontext-clip-y gcontext-dash-offset gcontext-dashes gcontext-display - gcontext-equal gcontext-error gcontext-exposures gcontext-fill-rule - gcontext-fill-style gcontext-font gcontext-foreground gcontext-function - gcontext-id gcontext-join-style gcontext-key gcontext-line-style - gcontext-line-width gcontext-p gcontext-plane-mask gcontext-plist - gcontext-stipple gcontext-subwindow-mode gcontext-tile gcontext-ts-x - gcontext-ts-y generalized-boolean get-external-event-code get-image get-property - get-raw-image get-resource get-search-resource get-search-table - get-standard-colormap get-wm-class global-pointer-position grab-button - grab-key grab-keyboard grab-pointer grab-server grab-status - icon-sizes iconify-window id-choice-error illegal-request-error - image image-blue-mask image-depth image-green-mask image-height - image-name image-pixmap image-plist image-red-mask image-width - image-x image-x-hot image-x-p image-xy image-xy-bitmap-list - image-xy-p image-y-hot image-z image-z-bits-per-pixel image-z-p - image-z-pixarray implementation-error input-focus install-colormap - installed-colormaps int16 int32 int8 intern-atom invalid-font - keyboard-control keyboard-mapping keycode->character keycode->keysym - keysym keysym->character keysym->keycodes keysym-in-map-p - keysym-set kill-client kill-temporary-clients length-error - list-extensions list-font-names list-fonts list-properties - lookup-color lookup-error make-color make-event-handlers - make-event-keys make-event-mask make-resource-database make-state-keys - make-state-mask make-wm-hints make-wm-size-hints map-resource - map-subwindows map-window mapping-notify mask16 mask32 - match-error max-char-ascent max-char-attributes max-char-descent - max-char-left-bearing max-char-right-bearing max-char-width - merge-resources min-char-ascent min-char-attributes min-char-descent - min-char-left-bearing min-char-right-bearing min-char-width - missing-parameter modifier-key modifier-mapping modifier-mask - motion-events name-error no-operation guess-display open-default-display open-display open-font - pixarray pixel pixmap pixmap-display pixmap-equal - pixmap-error pixmap-format pixmap-format-bits-per-pixel - pixmap-format-depth pixmap-format-p pixmap-format-scanline-pad - pixmap-id pixmap-p pixmap-plist point-seq pointer-control - pointer-event-mask pointer-event-mask-class pointer-mapping - pointer-position process-event put-image put-raw-image - query-best-cursor query-best-stipple query-best-tile query-colors - query-extension query-keymap query-pointer query-tree queue-event - read-bitmap-file read-resources recolor-cursor rect-seq - remove-access-host remove-from-save-set reparent-window repeat-seq - reply-length-error reply-timeout request-error reset-screen-saver - resource-database resource-database-timestamp resource-error - resource-id resource-key rgb-colormaps rgb-val root-resources - rotate-cut-buffers rotate-properties screen screen-backing-stores - screen-black-pixel screen-default-colormap screen-depths - screen-event-mask-at-open screen-height screen-height-in-millimeters - screen-max-installed-maps screen-min-installed-maps screen-p - screen-plist screen-root screen-root-depth screen-root-visual - screen-root-visual-info screen-save-unders-p screen-saver - screen-white-pixel screen-width screen-width-in-millimeters seg-seq - selection-owner send-event sequence-error set-access-control - set-close-down-mode set-input-focus set-modifier-mapping - set-pointer-mapping set-screen-saver set-selection-owner - set-standard-colormap set-standard-properties set-wm-class - set-wm-properties set-wm-resources state-keysym-p state-mask-key - store-color store-colors stringable text-extents text-width - timestamp transient-for translate-coordinates translate-default - translation-function undefine-keysym unexpected-reply - ungrab-button ungrab-key ungrab-keyboard ungrab-pointer - ungrab-server uninstall-colormap unknown-error unmap-subwindows - unmap-window value-error visual-info visual-info-bits-per-rgb - visual-info-blue-mask visual-info-class visual-info-colormap-entries - visual-info-display visual-info-green-mask visual-info-id visual-info-p - visual-info-plist visual-info-red-mask warp-pointer - warp-pointer-if-inside warp-pointer-relative warp-pointer-relative-if-inside - win-gravity window window-all-event-masks window-background - window-backing-pixel window-backing-planes window-backing-store - window-bit-gravity window-border window-class window-colormap - window-colormap-installed-p window-cursor window-display - window-do-not-propagate-mask window-equal window-error - window-event-mask window-gravity window-id window-map-state - window-override-redirect window-p window-plist window-priority - window-save-under window-visual window-visual-info with-display - with-event-queue with-gcontext with-server-grabbed with-state - withdraw-window wm-client-machine wm-colormap-windows wm-command - wm-hints wm-hints-flags wm-hints-icon-mask wm-hints-icon-pixmap - wm-hints-icon-window wm-hints-icon-x wm-hints-icon-y - wm-hints-initial-state wm-hints-input wm-hints-p wm-hints-window-group - wm-icon-name wm-name wm-normal-hints wm-protocols wm-resources - wm-size-hints wm-size-hints-base-height wm-size-hints-base-width - wm-size-hints-height wm-size-hints-height-inc wm-size-hints-max-aspect - wm-size-hints-max-height wm-size-hints-max-width wm-size-hints-min-aspect - wm-size-hints-min-height wm-size-hints-min-width wm-size-hints-p - wm-size-hints-user-specified-position-p wm-size-hints-user-specified-size-p - wm-size-hints-width wm-size-hints-width-inc wm-size-hints-win-gravity - wm-size-hints-x wm-size-hints-y wm-zoom-hints write-bitmap-file - write-resources xatom)) diff --git a/src/eclx/requests.lisp b/src/eclx/requests.lisp deleted file mode 100644 index 9f81cea1f..000000000 --- a/src/eclx/requests.lisp +++ /dev/null @@ -1,1494 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; -#+cmu -(ext:file-comment - "$Header$") - -(in-package :xlib) - -(defun create-window (&key - window - (parent (required-arg parent)) - (x (required-arg x)) - (y (required-arg y)) - (width (required-arg width)) - (height (required-arg height)) - (depth 0) (border-width 0) - (class :copy) (visual :copy) - background border - bit-gravity gravity - backing-store backing-planes backing-pixel save-under - event-mask do-not-propagate-mask override-redirect - colormap cursor) - ;; Display is obtained from parent. Only non-nil attributes are passed on in - ;; the request: the function makes no assumptions about what the actual protocol - ;; defaults are. Width and height are the inside size, excluding border. - (declare (type (or null window) window) - (type window parent) ; required - (type int16 x y) ;required - (type card16 width height) ;required - (type card16 depth border-width) - (type (member :copy :input-output :input-only) class) - (type (or (member :copy) visual-info resource-id) visual) - (type (or null (member :none :parent-relative) pixel pixmap) background) - (type (or null (member :copy) pixel pixmap) border) - (type (or null bit-gravity) bit-gravity) - (type (or null win-gravity) gravity) - (type (or null (member :not-useful :when-mapped :always)) backing-store) - (type (or null pixel) backing-planes backing-pixel) - (type (or null event-mask) event-mask) - (type (or null device-event-mask) do-not-propagate-mask) - (type (or null (member :on :off)) save-under override-redirect) - (type (or null (member :copy) colormap) colormap) - (type (or null (member :none) cursor) cursor)) - (declare (clx-values window)) - (let* ((display (window-display parent)) - (window (or window (make-window :display display))) - (wid (allocate-resource-id display window 'window)) - back-pixmap back-pixel - border-pixmap border-pixel) - (declare (type display display) - (type window window) - (type resource-id wid) - (type (or null resource-id) back-pixmap border-pixmap) - (type (or null pixel) back-pixel border-pixel)) - (setf (window-id window) wid) - (case background - ((nil) nil) - (:none (setq back-pixmap 0)) - (:parent-relative (setq back-pixmap 1)) - (otherwise - (if (type? background 'pixmap) - (setq back-pixmap (pixmap-id background)) - (if (integerp background) - (setq back-pixel background) - (x-type-error background - '(or null (member :none :parent-relative) integer pixmap)))))) - (case border - ((nil) nil) - (:copy (setq border-pixmap 0)) - (otherwise - (if (type? border 'pixmap) - (setq border-pixmap (pixmap-id border)) - (if (integerp border) - (setq border-pixel border) - (x-type-error border '(or null (member :copy) integer pixmap)))))) - (when event-mask - (setq event-mask (encode-event-mask event-mask))) - (when do-not-propagate-mask - (setq do-not-propagate-mask (encode-device-event-mask do-not-propagate-mask))) - - ;Make the request - (with-buffer-request (display +x-createwindow+) - (data depth) - (resource-id wid) - (window parent) - (int16 x y) - (card16 width height border-width) - ((member16 :copy :input-output :input-only) class) - (resource-id (cond ((eq visual :copy) - 0) - ((typep visual 'resource-id) - visual) - (t - (visual-info-id visual)))) - (mask (card32 back-pixmap back-pixel border-pixmap border-pixel) - ((member-vector *bit-gravity-vector*) bit-gravity) - ((member-vector *win-gravity-vector*) gravity) - ((member :not-useful :when-mapped :always) backing-store) - (card32 backing-planes backing-pixel) - ((member :off :on) override-redirect save-under) - (card32 event-mask do-not-propagate-mask) - ((or (member :copy) colormap) colormap) - ((or (member :none) cursor) cursor))) - window)) - -(defun destroy-window (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-destroywindow+) - (window window))) - -(defun destroy-subwindows (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-destroysubwindows+) - (window window))) - -(defun add-to-save-set (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-changesaveset+) - (data 0) - (window window))) - -(defun remove-from-save-set (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-changesaveset+) - (data 1) - (window window))) - -(defun reparent-window (window parent x y) - (declare (type window window parent) - (type int16 x y)) - (with-buffer-request ((window-display window) +x-reparentwindow+) - (window window parent) - (int16 x y))) - -(defun map-window (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-mapwindow+) - (window window))) - -(defun map-subwindows (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-mapsubwindows+) - (window window))) - -(defun unmap-window (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-unmapwindow+) - (window window))) - -(defun unmap-subwindows (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-unmapsubwindows+) - (window window))) - -(defun circulate-window-up (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-circulatewindow+) - (data 0) - (window window))) - -(defun circulate-window-down (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-circulatewindow+) - (data 1) - (window window))) - -(defun query-tree (window &key (result-type 'list)) - (declare (type window window) - (type t result-type)) ;;type specifier - (declare (clx-values (clx-sequence window) parent root)) - (let ((display (window-display window))) - (multiple-value-bind (root parent sequence) - (with-buffer-request-and-reply (display +x-querytree+ nil :sizes (8 16 32)) - ((window window)) - (values - (window-get 8) - (resource-id-get 12) - (sequence-get :length (card16-get 16) :result-type result-type - :index +replysize+))) - ;; Parent is NIL for root window - (setq parent (and (plusp parent) (lookup-window display parent))) - (dotimes (i (length sequence)) ; Convert ID's to window's - (setf (elt sequence i) (lookup-window display (elt sequence i)))) - (values sequence parent root)))) - -;; Although atom-ids are not visible in the normal user interface, atom-ids might -;; appear in window properties and other user data, so conversion hooks are needed. - -(defun intern-atom (display name) - (declare (type display display) - (type xatom name)) - (declare (clx-values resource-id)) - (let ((name (if (or (null name) (keywordp name)) - name - (kintern (string name))))) - (declare (type symbol name)) - (or (atom-id name display) - (let ((string (symbol-name name))) - (declare (type string string)) - (multiple-value-bind (id) - (with-buffer-request-and-reply (display +x-internatom+ 12 :sizes 32) - ((data 0) - (card16 (length string)) - (pad16 nil) - (string string)) - (values - (resource-id-get 8))) - (declare (type resource-id id)) - (setf (atom-id name display) id) - id))))) - -(defun find-atom (display name) - ;; Same as INTERN-ATOM, but with the ONLY-IF-EXISTS flag True - (declare (type display display) - (type xatom name)) - (declare (clx-values (or null resource-id))) - (let ((name (if (or (null name) (keywordp name)) - name - (kintern (string name))))) - (declare (type symbol name)) - (or (atom-id name display) - (let ((string (symbol-name name))) - (declare (type string string)) - (multiple-value-bind (id) - (with-buffer-request-and-reply (display +x-internatom+ 12 :sizes 32) - ((data 1) - (card16 (length string)) - (pad16 nil) - (string string)) - (values - (or-get 8 null resource-id))) - (declare (type (or null resource-id) id)) - (when id - (setf (atom-id name display) id)) - id))))) - -(defun atom-name (display atom-id) - (declare (type display display) - (type resource-id atom-id)) - (declare (clx-values keyword)) - (if (zerop atom-id) - nil - (or (id-atom atom-id display) - (let ((keyword - (kintern - (with-buffer-request-and-reply - (display +x-getatomname+ nil :sizes (16)) - ((resource-id atom-id)) - (values - (string-get (card16-get 8) +replysize+)))))) - (declare (type keyword keyword)) - (setf (atom-id keyword display) atom-id) - keyword)))) - -;;; For binary compatibility with older code -(defun lookup-xatom (display atom-id) - (declare (type display display) - (type resource-id atom-id)) - (atom-name display atom-id)) - -(defun change-property (window property data type format - &key (mode :replace) (start 0) end transform) - ; Start and end affect sub-sequence extracted from data. - ; Transform is applied to each extracted element. - (declare (type window window) - (type xatom property type) - (type (member 8 16 32) format) - (type sequence data) - (type (member :replace :prepend :append) mode) - (type array-index start) - (type (or null array-index) end) - (type (or null (function (t) integer)) transform)) - (unless end (setq end (length data))) - (let* ((display (window-display window)) - (length (index- end start)) - (property-id (intern-atom display property)) - (type-id (intern-atom display type))) - (declare (type display display) - (type array-index length) - (type resource-id property-id type-id)) - (with-buffer-request (display +x-changeproperty+) - ((data (member :replace :prepend :append)) mode) - (window window) - (resource-id property-id type-id) - (card8 format) - (card32 length) - (progn - (ecase format - (8 (sequence-put 24 data :format card8 - :start start :end end :transform transform)) - (16 (sequence-put 24 data :format card16 - :start start :end end :transform transform)) - (32 (sequence-put 24 data :format card32 - :start start :end end :transform transform))))))) - -(defun delete-property (window property) - (declare (type window window) - (type xatom property)) - (let* ((display (window-display window)) - (property-id (intern-atom display property))) - (declare (type display display) - (type resource-id property-id)) - (with-buffer-request (display +x-deleteproperty+) - (window window) - (resource-id property-id)))) - -(defun get-property (window property - &key type (start 0) end delete-p (result-type 'list) transform) - ;; Transform is applied to each integer retrieved. - (declare (type window window) - (type xatom property) - (type (or null xatom) type) - (type array-index start) - (type (or null array-index) end) - (type generalized-boolean delete-p) - (type t result-type) ;a sequence type - (type (or null (function (integer) t)) transform)) - (declare (clx-values data (or null type) format bytes-after)) - (let* ((display (window-display window)) - (property-id (intern-atom display property)) - (type-id (and type (intern-atom display type)))) - (declare (type display display) - (type resource-id property-id) - (type (or null resource-id) type-id)) - (multiple-value-bind (reply-format reply-type bytes-after data) - (with-buffer-request-and-reply (display +x-getproperty+ nil :sizes (8 32)) - (((data boolean) delete-p) - (window window) - (resource-id property-id) - ((or null resource-id) type-id) - (card32 start) - (card32 (index- (or end 64000) start))) - (let ((reply-format (card8-get 1)) - (reply-type (card32-get 8)) - (bytes-after (card32-get 12)) - (nitems (card32-get 16))) - (values - reply-format - reply-type - bytes-after - (and (plusp nitems) - (ecase reply-format - (0 nil) ;; (make-sequence result-type 0) ;; Property not found. - (8 (sequence-get :result-type result-type :format card8 - :length nitems :transform transform - :index +replysize+)) - (16 (sequence-get :result-type result-type :format card16 - :length nitems :transform transform - :index +replysize+)) - (32 (sequence-get :result-type result-type :format card32 - :length nitems :transform transform - :index +replysize+))))))) - (values data - (and (plusp reply-type) (atom-name display reply-type)) - reply-format - bytes-after)))) - -(defun rotate-properties (window properties &optional (delta 1)) - ;; Positive rotates left, negative rotates right (opposite of actual protocol request). - (declare (type window window) - (type sequence properties) ;; sequence of xatom - (type int16 delta)) - (let* ((display (window-display window)) - (length (length properties)) - (sequence (make-array length))) - (declare (type display display) - (type array-index length)) - (with-vector (sequence vector) - ;; Atoms must be interned before the RotateProperties request - ;; is started to allow InternAtom requests to be made. - (dotimes (i length) - (setf (aref sequence i) (intern-atom display (elt properties i)))) - (with-buffer-request (display +x-rotateproperties+) - (window window) - (card16 length) - (int16 (- delta)) - ((sequence :end length) sequence)))) - nil) - -(defun list-properties (window &key (result-type 'list)) - (declare (type window window) - (type t result-type)) ;; a sequence type - (declare (clx-values (clx-sequence keyword))) - (let ((display (window-display window))) - (multiple-value-bind (seq) - (with-buffer-request-and-reply (display +x-listproperties+ nil :sizes 16) - ((window window)) - (values - (sequence-get :result-type result-type :length (card16-get 8) - :index +replysize+))) - ;; lookup the atoms in the sequence - (if (listp seq) - (do ((elt seq (cdr elt))) - ((endp elt) seq) - (setf (car elt) (atom-name display (car elt)))) - (dotimes (i (length seq) seq) - (setf (aref seq i) (atom-name display (aref seq i)))))))) - -(defun selection-owner (display selection) - (declare (type display display) - (type xatom selection)) - (declare (clx-values (or null window))) - (let ((selection-id (intern-atom display selection))) - (declare (type resource-id selection-id)) - (multiple-value-bind (window) - (with-buffer-request-and-reply (display +x-getselectionowner+ 12 :sizes 32) - ((resource-id selection-id)) - (values - (resource-id-or-nil-get 8))) - (and window (lookup-window display window))))) - -(defun set-selection-owner (display selection owner &optional time) - (declare (type display display) - (type xatom selection) - (type (or null window) owner) - (type timestamp time)) - (let ((selection-id (intern-atom display selection))) - (declare (type resource-id selection-id)) - (with-buffer-request (display +x-setselectionowner+) - ((or null window) owner) - (resource-id selection-id) - ((or null card32) time)) - owner)) - -(defsetf selection-owner (display selection &optional time) (owner) - ;; A bit strange, but retains setf form. - `(set-selection-owner ,display ,selection ,owner ,time)) - -(defun convert-selection (selection type requestor &optional property time) - (declare (type xatom selection type) - (type window requestor) - (type (or null xatom) property) - (type timestamp time)) - (let* ((display (window-display requestor)) - (selection-id (intern-atom display selection)) - (type-id (intern-atom display type)) - (property-id (and property (intern-atom display property)))) - (declare (type display display) - (type resource-id selection-id type-id) - (type (or null resource-id) property-id)) - (with-buffer-request (display +x-convertselection+) - (window requestor) - (resource-id selection-id type-id) - ((or null resource-id) property-id) - ((or null card32) time)))) - -(defun send-event (window event-key event-mask &rest args - &key propagate-p display &allow-other-keys) - ;; Additional arguments depend on event-key, and are as specified further below - ;; with declare-event, except that both resource-ids and resource objects are - ;; accepted in the event components. The display argument is only required if the - ;; window is :pointer-window or :input-focus. - (declare (type (or window (member :pointer-window :input-focus)) window) - (type event-key event-key) - (type (or null event-mask) event-mask) - (type generalized-boolean propagate-p) - (type (or null display) display) - (dynamic-extent args)) - (unless event-mask (setq event-mask 0)) - (unless display (setq display (window-display window))) - (let ((internal-event-code (get-event-code event-key)) - (external-event-code (get-external-event-code display event-key))) - (declare (type card8 internal-event-code external-event-code)) - ;; Ensure keyword atom-id's are cached - (dolist (arg (cdr (assoc event-key '((:property-notify :atom) - (:selection-clear :selection) - (:selection-request :selection :target :property) - (:selection-notify :selection :target :property) - (:client-message :type)) - :test #'eq))) - (let ((keyword (getf args arg))) - (intern-atom display keyword))) - ;; Make the sendevent request - (with-buffer-request (display +x-sendevent+) - ((data boolean) propagate-p) - (length 11) ;; 3 word request + 8 words for event = 11 - ((or (member :pointer-window :input-focus) window) window) - (card32 (encode-event-mask event-mask)) - (card8 external-event-code) - (progn - (apply (svref *event-send-vector* internal-event-code) display args) - (setf (buffer-boffset display) (index+ buffer-boffset 44)))))) - -(defun grab-pointer (window event-mask - &key owner-p sync-pointer-p sync-keyboard-p confine-to cursor time) - (declare (type window window) - (type pointer-event-mask event-mask) - (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) - (type (or null window) confine-to) - (type (or null cursor) cursor) - (type timestamp time)) - (declare (clx-values grab-status)) - (let ((display (window-display window))) - (with-buffer-request-and-reply (display +x-grabpointer+ nil :sizes 8) - (((data boolean) owner-p) - (window window) - (card16 (encode-pointer-event-mask event-mask)) - (boolean (not sync-pointer-p) (not sync-keyboard-p)) - ((or null window) confine-to) - ((or null cursor) cursor) - ((or null card32) time)) - (values - (member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen))))) - -(defun ungrab-pointer (display &key time) - (declare (type timestamp time)) - (with-buffer-request (display +x-ungrabpointer+) - ((or null card32) time))) - -(defun grab-button (window button event-mask - &key (modifiers :any) - owner-p sync-pointer-p sync-keyboard-p confine-to cursor) - (declare (type window window) - (type (or (member :any) card8) button) - (type modifier-mask modifiers) - (type pointer-event-mask event-mask) - (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) - (type (or null window) confine-to) - (type (or null cursor) cursor)) - (with-buffer-request ((window-display window) +x-grabbutton+) - ((data boolean) owner-p) - (window window) - (card16 (encode-pointer-event-mask event-mask)) - (boolean (not sync-pointer-p) (not sync-keyboard-p)) - ((or null window) confine-to) - ((or null cursor) cursor) - (card8 (if (eq button :any) 0 button)) - (pad8 1) - (card16 (encode-modifier-mask modifiers)))) - -(defun ungrab-button (window button &key (modifiers :any)) - (declare (type window window) - (type (or (member :any) card8) button) - (type modifier-mask modifiers)) - (with-buffer-request ((window-display window) +x-ungrabbutton+) - (data (if (eq button :any) 0 button)) - (window window) - (card16 (encode-modifier-mask modifiers)))) - -(defun change-active-pointer-grab (display event-mask &optional cursor time) - (declare (type display display) - (type pointer-event-mask event-mask) - (type (or null cursor) cursor) - (type timestamp time)) - (with-buffer-request (display +x-changeactivepointergrab+) - ((or null cursor) cursor) - ((or null card32) time) - (card16 (encode-pointer-event-mask event-mask)))) - -(defun grab-keyboard (window &key owner-p sync-pointer-p sync-keyboard-p time) - (declare (type window window) - (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) - (type timestamp time)) - (declare (clx-values grab-status)) - (let ((display (window-display window))) - (with-buffer-request-and-reply (display +x-grabkeyboard+ nil :sizes 8) - (((data boolean) owner-p) - (window window) - ((or null card32) time) - (boolean (not sync-pointer-p) (not sync-keyboard-p))) - (values - (member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen))))) - -(defun ungrab-keyboard (display &key time) - (declare (type display display) - (type timestamp time)) - (with-buffer-request (display +x-ungrabkeyboard+) - ((or null card32) time))) - -(defun grab-key (window key &key (modifiers 0) owner-p sync-pointer-p sync-keyboard-p) - (declare (type window window) - (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) - (type (or (member :any) card8) key) - (type modifier-mask modifiers)) - (with-buffer-request ((window-display window) +x-grabkey+) - ((data boolean) owner-p) - (window window) - (card16 (encode-modifier-mask modifiers)) - (card8 (if (eq key :any) 0 key)) - (boolean (not sync-pointer-p) (not sync-keyboard-p)))) - -(defun ungrab-key (window key &key (modifiers 0)) - (declare (type window window) - (type (or (member :any) card8) key) - (type modifier-mask modifiers)) - (with-buffer-request ((window-display window) +x-ungrabkey+) - (data (if (eq key :any) 0 key)) - (window window) - (card16 (encode-modifier-mask modifiers)))) - -(defun allow-events (display mode &optional time) - (declare (type display display) - (type (member :async-pointer :sync-pointer :replay-pointer - :async-keyboard :sync-keyboard :replay-keyboard - :async-both :sync-both) - mode) - (type timestamp time)) - (with-buffer-request (display +x-allowevents+) - ((data (member :async-pointer :sync-pointer :replay-pointer - :async-keyboard :sync-keyboard :replay-keyboard - :async-both :sync-both)) - mode) - ((or null card32) time))) - -(defun grab-server (display) - (declare (type display display)) - (with-buffer-request (display +x-grabserver+))) - -(defun ungrab-server (display) - (with-buffer-request (display +x-ungrabserver+))) - -(defmacro with-server-grabbed ((display) &body body) - ;; The body is not surrounded by a with-display. - (let ((disp (if (symbolp display) display (gensym)))) - `(let ((,disp ,display)) - (declare (type display ,disp)) - (unwind-protect - (progn - (grab-server ,disp) - ,@body) - (ungrab-server ,disp))))) - -(defun query-pointer (window) - (declare (type window window)) - (declare (clx-values x y same-screen-p child mask root-x root-y root)) - (let ((display (window-display window))) - (with-buffer-request-and-reply (display +x-querypointer+ 26 :sizes (8 16 32)) - ((window window)) - (values - (int16-get 20) - (int16-get 22) - (boolean-get 1) - (or-get 12 null window) - (card16-get 24) - (int16-get 16) - (int16-get 18) - (window-get 8))))) - -(defun pointer-position (window) - (declare (type window window)) - (declare (clx-values x y same-screen-p)) - (let ((display (window-display window))) - (with-buffer-request-and-reply (display +x-querypointer+ 24 :sizes (8 16)) - ((window window)) - (values - (int16-get 20) - (int16-get 22) - (boolean-get 1))))) - -(defun global-pointer-position (display) - (declare (type display display)) - (declare (clx-values root-x root-y root)) - (with-buffer-request-and-reply (display +x-querypointer+ 20 :sizes (16 32)) - ((window (screen-root (first (display-roots display))))) - (values - (int16-get 16) - (int16-get 18) - (window-get 8)))) - -(defun motion-events (window &key start stop (result-type 'list)) - (declare (type window window) - (type timestamp start stop) - (type t result-type)) ;; a type specifier - (declare (clx-values (repeat-seq (integer x) (integer y) (timestamp time)))) - (let ((display (window-display window))) - (with-buffer-request-and-reply (display +x-getmotionevents+ nil :sizes 32) - ((window window) - ((or null card32) start stop)) - (values - (sequence-get :result-type result-type :length (index* (card32-get 8) 3) - :index +replysize+))))) - -(defun translate-coordinates (src src-x src-y dst) - ;; Returns NIL when not on the same screen - (declare (type window src) - (type int16 src-x src-y) - (type window dst)) - (declare (clx-values dst-x dst-y child)) - (let ((display (window-display src))) - (with-buffer-request-and-reply (display +x-translatecoords+ 16 :sizes (8 16 32)) - ((window src dst) - (int16 src-x src-y)) - (and (boolean-get 1) - (values - (int16-get 12) - (int16-get 14) - (or-get 8 null window)))))) - -(defun warp-pointer (dst dst-x dst-y) - (declare (type window dst) - (type int16 dst-x dst-y)) - (with-buffer-request ((window-display dst) +x-warppointer+) - (resource-id 0) ;; None - (window dst) - (int16 0 0) - (card16 0 0) - (int16 dst-x dst-y))) - -(defun warp-pointer-relative (display x-off y-off) - (declare (type display display) - (type int16 x-off y-off)) - (with-buffer-request (display +x-warppointer+) - (resource-id 0) ;; None - (resource-id 0) ;; None - (int16 0 0) - (card16 0 0) - (int16 x-off y-off))) - -(defun warp-pointer-if-inside (dst dst-x dst-y src src-x src-y - &optional src-width src-height) - ;; Passing in a zero src-width or src-height is a no-op. - ;; A null src-width or src-height translates into a zero value in the protocol request. - (declare (type window dst src) - (type int16 dst-x dst-y src-x src-y) - (type (or null card16) src-width src-height)) - (unless (or (eql src-width 0) (eql src-height 0)) - (with-buffer-request ((window-display dst) +x-warppointer+) - (window src dst) - (int16 src-x src-y) - (card16 (or src-width 0) (or src-height 0)) - (int16 dst-x dst-y)))) - -(defun warp-pointer-relative-if-inside (x-off y-off src src-x src-y - &optional src-width src-height) - ;; Passing in a zero src-width or src-height is a no-op. - ;; A null src-width or src-height translates into a zero value in the protocol request. - (declare (type window src) - (type int16 x-off y-off src-x src-y) - (type (or null card16) src-width src-height)) - (unless (or (eql src-width 0) (eql src-height 0)) - (with-buffer-request ((window-display src) +x-warppointer+) - (window src) - (resource-id 0) ;; None - (int16 src-x src-y) - (card16 (or src-width 0) (or src-height 0)) - (int16 x-off y-off)))) - -(defun set-input-focus (display focus revert-to &optional time) - (declare (type display display) - (type (or (member :none :pointer-root) window) focus) - (type (member :none :pointer-root :parent) revert-to) - (type timestamp time)) - (with-buffer-request (display +x-setinputfocus+) - ((data (member :none :pointer-root :parent)) revert-to) - ((or window (member :none :pointer-root)) focus) - ((or null card32) time))) - -(defun input-focus (display) - (declare (type display display)) - (declare (clx-values focus revert-to)) - (with-buffer-request-and-reply (display +x-getinputfocus+ 16 :sizes (8 32)) - () - (values - (or-get 8 window (member :none :pointer-root)) - (member8-get 1 :none :pointer-root :parent)))) - -(defun query-keymap (display &optional bit-vector) - (declare (type display display) - (type (or null (bit-vector 256)) bit-vector)) - (declare (clx-values (bit-vector 256))) - (with-buffer-request-and-reply (display +x-querykeymap+ 40 :sizes 8) - () - (values - (bit-vector256-get 8 8 bit-vector)))) - -(defun create-pixmap (&key - pixmap - (width (required-arg width)) - (height (required-arg height)) - (depth (required-arg depth)) - (drawable (required-arg drawable))) - (declare (type (or null pixmap) pixmap) - (type card8 depth) ;; required - (type card16 width height) ;; required - (type drawable drawable)) ;; required - (declare (clx-values pixmap)) - (let* ((display (drawable-display drawable)) - (pixmap (or pixmap (make-pixmap :display display))) - (pid (allocate-resource-id display pixmap 'pixmap))) - (setf (pixmap-id pixmap) pid) - (with-buffer-request (display +x-createpixmap+) - (data depth) - (resource-id pid) - (drawable drawable) - (card16 width height)) - pixmap)) - -(defun free-pixmap (pixmap) - (declare (type pixmap pixmap)) - (let ((display (pixmap-display pixmap))) - (with-buffer-request (display +x-freepixmap+) - (pixmap pixmap)) - (deallocate-resource-id display (pixmap-id pixmap) 'pixmap))) - -(defun clear-area (window &key (x 0) (y 0) width height exposures-p) - ;; Passing in a zero width or height is a no-op. - ;; A null width or height translates into a zero value in the protocol request. - (declare (type window window) - (type int16 x y) - (type (or null card16) width height) - (type generalized-boolean exposures-p)) - (unless (or (eql width 0) (eql height 0)) - (with-buffer-request ((window-display window) +x-cleartobackground+) - ((data boolean) exposures-p) - (window window) - (int16 x y) - (card16 (or width 0) (or height 0))))) - -(defun copy-area (src gcontext src-x src-y width height dst dst-x dst-y) - (declare (type drawable src dst) - (type gcontext gcontext) - (type int16 src-x src-y dst-x dst-y) - (type card16 width height)) - (with-buffer-request ((drawable-display src) +x-copyarea+ :gc-force gcontext) - (drawable src dst) - (gcontext gcontext) - (int16 src-x src-y dst-x dst-y) - (card16 width height))) - -(defun copy-plane (src gcontext plane src-x src-y width height dst dst-x dst-y) - (declare (type drawable src dst) - (type gcontext gcontext) - (type pixel plane) - (type int16 src-x src-y dst-x dst-y) - (type card16 width height)) - (with-buffer-request ((drawable-display src) +x-copyplane+ :gc-force gcontext) - (drawable src dst) - (gcontext gcontext) - (int16 src-x src-y dst-x dst-y) - (card16 width height) - (card32 plane))) - -(defun create-colormap (visual-info window &optional alloc-p) - (declare (type (or visual-info resource-id) visual-info) - (type window window) - (type generalized-boolean alloc-p)) - (declare (clx-values colormap)) - (let ((display (window-display window))) - (when (typep visual-info 'resource-id) - (setf visual-info (visual-info display visual-info))) - (let* ((colormap (make-colormap :display display :visual-info visual-info)) - (id (allocate-resource-id display colormap 'colormap))) - (setf (colormap-id colormap) id) - (with-buffer-request (display +x-createcolormap+) - ((data boolean) alloc-p) - (card29 id) - (window window) - (card29 (visual-info-id visual-info))) - colormap))) - -(defun free-colormap (colormap) - (declare (type colormap colormap)) - (let ((display (colormap-display colormap))) - (with-buffer-request (display +x-freecolormap+) - (colormap colormap)) - (deallocate-resource-id display (colormap-id colormap) 'colormap))) - -(defun copy-colormap-and-free (colormap) - (declare (type colormap colormap)) - (declare (clx-values colormap)) - (let* ((display (colormap-display colormap)) - (new-colormap (make-colormap :display display - :visual-info (colormap-visual-info colormap))) - (id (allocate-resource-id display new-colormap 'colormap))) - (setf (colormap-id new-colormap) id) - (with-buffer-request (display +x-copycolormapandfree+) - (resource-id id) - (colormap colormap)) - new-colormap)) - -(defun install-colormap (colormap) - (declare (type colormap colormap)) - (with-buffer-request ((colormap-display colormap) +x-installcolormap+) - (colormap colormap))) - -(defun uninstall-colormap (colormap) - (declare (type colormap colormap)) - (with-buffer-request ((colormap-display colormap) +x-uninstallcolormap+) - (colormap colormap))) - -(defun installed-colormaps (window &key (result-type 'list)) - (declare (type window window) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence colormap))) - (let ((display (window-display window))) - (flet ((get-colormap (id) - (lookup-colormap display id))) - (with-buffer-request-and-reply (display +x-listinstalledcolormaps+ nil :sizes 16) - ((window window)) - (values - (sequence-get :result-type result-type :length (card16-get 8) - :transform #'get-colormap :index +replysize+)))))) - -(defun alloc-color (colormap color) - (declare (type colormap colormap) - (type (or stringable color) color)) - (declare (clx-values pixel screen-color exact-color)) - (let ((display (colormap-display colormap))) - (etypecase color - (color - (with-buffer-request-and-reply (display +x-alloccolor+ 20 :sizes (16 32)) - ((colormap colormap) - (rgb-val (color-red color) - (color-green color) - (color-blue color)) - (pad16 nil)) - (values - (card32-get 16) - (make-color :red (rgb-val-get 8) - :green (rgb-val-get 10) - :blue (rgb-val-get 12)) - color))) - (stringable - (let* ((string (string color)) - (length (length string))) - (with-buffer-request-and-reply (display +x-allocnamedcolor+ 24 :sizes (16 32)) - ((colormap colormap) - (card16 length) - (pad16 nil) - (string string)) - (values - (card32-get 8) - (make-color :red (rgb-val-get 18) - :green (rgb-val-get 20) - :blue (rgb-val-get 22)) - (make-color :red (rgb-val-get 12) - :green (rgb-val-get 14) - :blue (rgb-val-get 16))))))))) - -(defun alloc-color-cells (colormap colors &key (planes 0) contiguous-p (result-type 'list)) - (declare (type colormap colormap) - (type card16 colors planes) - (type generalized-boolean contiguous-p) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence pixel) (clx-sequence mask))) - (let ((display (colormap-display colormap))) - (with-buffer-request-and-reply (display +x-alloccolorcells+ nil :sizes 16) - (((data boolean) contiguous-p) - (colormap colormap) - (card16 colors planes)) - (let ((pixel-length (card16-get 8)) - (mask-length (card16-get 10))) - (values - (sequence-get :result-type result-type :length pixel-length :index +replysize+) - (sequence-get :result-type result-type :length mask-length - :index (index+ +replysize+ (index* pixel-length 4)))))))) - -(defun alloc-color-planes (colormap colors - &key (reds 0) (greens 0) (blues 0) - contiguous-p (result-type 'list)) - (declare (type colormap colormap) - (type card16 colors reds greens blues) - (type generalized-boolean contiguous-p) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence pixel) red-mask green-mask blue-mask)) - (let ((display (colormap-display colormap))) - (with-buffer-request-and-reply (display +x-alloccolorplanes+ nil :sizes (16 32)) - (((data boolean) contiguous-p) - (colormap colormap) - (card16 colors reds greens blues)) - (let ((red-mask (card32-get 12)) - (green-mask (card32-get 16)) - (blue-mask (card32-get 20))) - (values - (sequence-get :result-type result-type :length (card16-get 8) :index +replysize+) - red-mask green-mask blue-mask))))) - -(defun free-colors (colormap pixels &optional (plane-mask 0)) - (declare (type colormap colormap) - (type sequence pixels) ;; Sequence of integers - (type pixel plane-mask)) - (with-buffer-request ((colormap-display colormap) +x-freecolors+) - (colormap colormap) - (card32 plane-mask) - (sequence pixels))) - -(defun store-color (colormap pixel spec &key (red-p t) (green-p t) (blue-p t)) - (declare (type colormap colormap) - (type pixel pixel) - (type (or stringable color) spec) - (type generalized-boolean red-p green-p blue-p)) - (let ((display (colormap-display colormap)) - (flags 0)) - (declare (type display display) - (type card8 flags)) - (when red-p (setq flags 1)) - (when green-p (incf flags 2)) - (when blue-p (incf flags 4)) - (etypecase spec - (color - (with-buffer-request (display +x-storecolors+) - (colormap colormap) - (card32 pixel) - (rgb-val (color-red spec) - (color-green spec) - (color-blue spec)) - (card8 flags) - (pad8 nil))) - (stringable - (let* ((string (string spec)) - (length (length string))) - (with-buffer-request (display +x-storenamedcolor+) - ((data card8) flags) - (colormap colormap) - (card32 pixel) - (card16 length) - (pad16 nil) - (string string))))))) - -(defun store-colors (colormap specs &key (red-p t) (green-p t) (blue-p t)) - ;; If stringables are specified for colors, it is unspecified whether all - ;; stringables are first resolved and then a single StoreColors protocol request is - ;; issued, or whether multiple StoreColors protocol requests are issued. - (declare (type colormap colormap) - (type sequence specs) - (type generalized-boolean red-p green-p blue-p)) - (etypecase specs - (list - (do ((spec specs (cddr spec))) - ((endp spec)) - (store-color colormap (car spec) (cadr spec) :red-p red-p :green-p green-p :blue-p blue-p))) - (vector - (do ((i 0 (+ i 2)) - (len (length specs))) - ((>= i len)) - (store-color colormap (aref specs i) (aref specs (1+ i)) :red-p red-p :green-p green-p :blue-p blue-p))))) - -(defun query-colors (colormap pixels &key (result-type 'list)) - (declare (type colormap colormap) - (type sequence pixels) ;; sequence of integer - (type t result-type)) ;; a type specifier - (declare (clx-values (clx-sequence color))) - (let ((display (colormap-display colormap))) - (with-buffer-request-and-reply (display +x-querycolors+ nil :sizes (8 16)) - ((colormap colormap) - (sequence pixels)) - (let ((sequence (make-sequence result-type (card16-get 8)))) - (advance-buffer-offset +replysize+) - (dotimes (i (length sequence) sequence) - (setf (elt sequence i) - (make-color :red (rgb-val-get 0) - :green (rgb-val-get 2) - :blue (rgb-val-get 4))) - (advance-buffer-offset 8)))))) - -(defun lookup-color (colormap name) - (declare (type colormap colormap) - (type stringable name)) - (declare (clx-values screen-color true-color)) - (let* ((display (colormap-display colormap)) - (string (string name)) - (length (length string))) - (with-buffer-request-and-reply (display +x-lookupcolor+ 20 :sizes 16) - ((colormap colormap) - (card16 length) - (pad16 nil) - (string string)) - (values - (make-color :red (rgb-val-get 14) - :green (rgb-val-get 16) - :blue (rgb-val-get 18)) - (make-color :red (rgb-val-get 8) - :green (rgb-val-get 10) - :blue (rgb-val-get 12)))))) - -(defun create-cursor (&key - (source (required-arg source)) - mask - (x (required-arg x)) - (y (required-arg y)) - (foreground (required-arg foreground)) - (background (required-arg background))) - (declare (type pixmap source) ;; required - (type (or null pixmap) mask) - (type card16 x y) ;; required - (type (or null color) foreground background)) ;; required - (declare (clx-values cursor)) - (let* ((display (pixmap-display source)) - (cursor (make-cursor :display display)) - (cid (allocate-resource-id display cursor 'cursor))) - (setf (cursor-id cursor) cid) - (with-buffer-request (display +x-createcursor+) - (resource-id cid) - (pixmap source) - ((or null pixmap) mask) - (rgb-val (color-red foreground) - (color-green foreground) - (color-blue foreground)) - (rgb-val (color-red background) - (color-green background) - (color-blue background)) - (card16 x y)) - cursor)) - -(defun create-glyph-cursor (&key - (source-font (required-arg source-font)) - (source-char (required-arg source-char)) - mask-font - mask-char - (foreground (required-arg foreground)) - (background (required-arg background))) - (declare (type font source-font) ;; Required - (type card16 source-char) ;; Required - (type (or null font) mask-font) - (type (or null card16) mask-char) - (type color foreground background)) ;; required - (declare (clx-values cursor)) - (let* ((display (font-display source-font)) - (cursor (make-cursor :display display)) - (cid (allocate-resource-id display cursor 'cursor)) - (source-font-id (font-id source-font)) - (mask-font-id (if mask-font (font-id mask-font) 0))) - (setf (cursor-id cursor) cid) - (unless mask-char (setq mask-char 0)) - (with-buffer-request (display +x-createglyphcursor+) - (resource-id cid source-font-id mask-font-id) - (card16 source-char) - (card16 mask-char) - (rgb-val (color-red foreground) - (color-green foreground) - (color-blue foreground)) - (rgb-val (color-red background) - (color-green background) - (color-blue background))) - cursor)) - -(defun free-cursor (cursor) - (declare (type cursor cursor)) - (let ((display (cursor-display cursor))) - (with-buffer-request (display +x-freecursor+) - (cursor cursor)) - (deallocate-resource-id display (cursor-id cursor) 'cursor))) - -(defun recolor-cursor (cursor foreground background) - (declare (type cursor cursor) - (type color foreground background)) - (with-buffer-request ((cursor-display cursor) +x-recolorcursor+) - (cursor cursor) - (rgb-val (color-red foreground) - (color-green foreground) - (color-blue foreground)) - (rgb-val (color-red background) - (color-green background) - (color-blue background)) - )) - -(defun query-best-cursor (width height drawable) - (declare (type card16 width height) - (type (or drawable display) drawable)) - (declare (clx-values width height)) - ;; Drawable can be a display for compatibility. - (multiple-value-bind (display drawable) - (if (type? drawable 'drawable) - (values (drawable-display drawable) drawable) - (values drawable (screen-root (display-default-screen drawable)))) - (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16) - ((data 0) - (window drawable) - (card16 width height)) - (values - (card16-get 8) - (card16-get 10))))) - -(defun query-best-tile (width height drawable) - (declare (type card16 width height) - (type drawable drawable)) - (declare (clx-values width height)) - (let ((display (drawable-display drawable))) - (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16) - ((data 1) - (drawable drawable) - (card16 width height)) - (values - (card16-get 8) - (card16-get 10))))) - -(defun query-best-stipple (width height drawable) - (declare (type card16 width height) - (type drawable drawable)) - (declare (clx-values width height)) - (let ((display (drawable-display drawable))) - (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16) - ((data 2) - (drawable drawable) - (card16 width height)) - (values - (card16-get 8) - (card16-get 10))))) - -(defun query-extension (display name) - (declare (type display display) - (type stringable name)) - (declare (clx-values major-opcode first-event first-error)) - (let ((string (string name))) - (with-buffer-request-and-reply (display +x-queryextension+ 12 :sizes 8) - ((card16 (length string)) - (pad16 nil) - (string string)) - (and (boolean-get 8) ;; If present - (values - (card8-get 9) - (card8-get 10) - (card8-get 11)))))) - -(defun list-extensions (display &key (result-type 'list)) - (declare (type display display) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence string))) - (with-buffer-request-and-reply (display +x-listextensions+ size :sizes 8) - () - (values - (read-sequence-string - buffer-bbuf (index- size +replysize+) (card8-get 1) result-type +replysize+)))) - -(defun change-keyboard-control (display &key key-click-percent - bell-percent bell-pitch bell-duration - led led-mode key auto-repeat-mode) - (declare (type display display) - (type (or null (member :default) int16) key-click-percent - bell-percent bell-pitch bell-duration) - (type (or null card8) led key) - (type (or null (member :on :off)) led-mode) - (type (or null (member :on :off :default)) auto-repeat-mode)) - (when (eq key-click-percent :default) (setq key-click-percent -1)) - (when (eq bell-percent :default) (setq bell-percent -1)) - (when (eq bell-pitch :default) (setq bell-pitch -1)) - (when (eq bell-duration :default) (setq bell-duration -1)) - (with-buffer-request (display +x-changekeyboardcontrol+ :sizes (32)) - (mask - (integer key-click-percent bell-percent bell-pitch bell-duration) - (card32 led) - ((member :off :on) led-mode) - (card32 key) - ((member :off :on :default) auto-repeat-mode)))) - -(defun keyboard-control (display) - (declare (type display display)) - (declare (clx-values key-click-percent bell-percent bell-pitch bell-duration - led-mask global-auto-repeat auto-repeats)) - (with-buffer-request-and-reply (display +x-getkeyboardcontrol+ 32 :sizes (8 16 32)) - () - (values - (card8-get 12) - (card8-get 13) - (card16-get 14) - (card16-get 16) - (card32-get 8) - (member8-get 1 :off :on) - (bit-vector256-get 32)))) - -;; The base volume should -;; be considered to be the "desired" volume in the normal case; that is, a -;; typical application should call XBell with 0 as the percent. Rather -;; than using a simple sum, the percent argument is instead used as the -;; percentage of the remaining range to alter the base volume by. That is, -;; the actual volume is: -;; if percent>=0: base - [(base * percent) / 100] + percent -;; if percent<0: base + [(base * percent) / 100] - -(defun bell (display &optional (percent-from-normal 0)) - ;; It is assumed that an eventual audio extension to X will provide more complete control. - (declare (type display display) - (type int8 percent-from-normal)) - (with-buffer-request (display +x-bell+) - (data (int8->card8 percent-from-normal)))) - -(defun pointer-mapping (display &key (result-type 'list)) - (declare (type display display) - (type t result-type)) ;; CL type - (declare (clx-values sequence)) ;; Sequence of card - (with-buffer-request-and-reply (display +x-getpointermapping+ nil :sizes 8) - () - (values - (sequence-get :length (card8-get 1) :result-type result-type :format card8 - :index +replysize+)))) - -(defun set-pointer-mapping (display map) - ;; Can signal device-busy. - (declare (type display display) - (type sequence map)) ;; Sequence of card8 - (when (with-buffer-request-and-reply (display +x-setpointermapping+ 2 :sizes 8) - ((data (length map)) - ((sequence :format card8) map)) - (values - (boolean-get 1))) - (x-error 'device-busy :display display)) - map) - -(defsetf pointer-mapping set-pointer-mapping) - -(defun change-pointer-control (display &key acceleration threshold) - ;; Acceleration is rationalized if necessary. - (declare (type display display) - (type (or null (member :default) number) acceleration) - (type (or null (member :default) integer) threshold)) - (flet ((rationalize16 (number) - ;; Rationalize NUMBER into the ratio of two signed 16 bit numbers - (declare (type number number)) - (declare (clx-values numerator denominator)) - (do* ((rational (rationalize number)) - (numerator (numerator rational) (ash numerator -1)) - (denominator (denominator rational) (ash denominator -1))) - ((or (= numerator 1) - (and (< (abs numerator) #x8000) - (< denominator #x8000))) - (values - numerator (min denominator #x7fff)))))) - (declare (inline rationalize16)) - (let ((acceleration-p 1) - (threshold-p 1) - (numerator 0) - (denominator 1)) - (declare (type card8 acceleration-p threshold-p) - (type int16 numerator denominator)) - (cond ((eq acceleration :default) (setq numerator -1)) - (acceleration (multiple-value-setq (numerator denominator) - (rationalize16 acceleration))) - (t (setq acceleration-p 0))) - (cond ((eq threshold :default) (setq threshold -1)) - ((null threshold) (setq threshold -1 - threshold-p 0))) - (with-buffer-request (display +x-changepointercontrol+) - (int16 numerator denominator threshold) - (card8 acceleration-p threshold-p))))) - -(defun pointer-control (display) - (declare (type display display)) - (declare (clx-values acceleration threshold)) - (with-buffer-request-and-reply (display +x-getpointercontrol+ 16 :sizes 16) - () - (values - (/ (card16-get 8) (card16-get 10)) ; Should we float this? - (card16-get 12)))) - -(defun set-screen-saver (display timeout interval blanking exposures) - ;; Timeout and interval are in seconds, will be rounded to minutes. - (declare (type display display) - (type (or (member :default) int16) timeout interval) - (type (member :on :off :default :yes :no) blanking exposures)) - (case blanking (:yes (setq blanking :on)) (:no (setq blanking :off))) - (case exposures (:yes (setq exposures :on)) (:no (setq exposures :off))) - (when (eq timeout :default) (setq timeout -1)) - (when (eq interval :default) (setq interval -1)) - (with-buffer-request (display +x-setscreensaver+) - (int16 timeout interval) - ((member8 :on :off :default) blanking exposures))) - -(defun screen-saver (display) - ;; Returns timeout and interval in seconds. - (declare (type display display)) - (declare (clx-values timeout interval blanking exposures)) - (with-buffer-request-and-reply (display +x-getscreensaver+ 14 :sizes (8 16)) - () - (values - (card16-get 8) - (card16-get 10) - (member8-get 12 :on :off :default) - (member8-get 13 :on :off :default)))) - -(defun activate-screen-saver (display) - (declare (type display display)) - (with-buffer-request (display +x-forcescreensaver+) - (data 1))) - -(defun reset-screen-saver (display) - (declare (type display display)) - (with-buffer-request (display +x-forcescreensaver+) - (data 0))) - -(defun add-access-host (display host &optional (family :internet)) - ;; A string must be acceptable as a host, but otherwise the possible types for - ;; host are not constrained, and will likely be very system dependent. - ;; This implementation uses a list whose car is the family keyword - ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes. - (declare (type display display) - (type (or stringable list) host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (change-access-host display host family nil)) - -(defun remove-access-host (display host &optional (family :internet)) - ;; A string must be acceptable as a host, but otherwise the possible types for - ;; host are not constrained, and will likely be very system dependent. - ;; This implementation uses a list whose car is the family keyword - ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes. - (declare (type display display) - (type (or stringable list) host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (change-access-host display host family t)) - -(defun change-access-host (display host family remove-p) - (declare (type display display) - (type (or stringable list) host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (unless (consp host) - (setq host (host-address host family))) - (let ((family (car host)) - (address (cdr host))) - (with-buffer-request (display +x-changehosts+) - ((data boolean) remove-p) - (card8 (encode-type (or null (member :internet :decnet :chaos) card32) family)) - (card16 (length address)) - ((sequence :format card8) address)))) - -(defun access-hosts (display &optional (result-type 'list)) - ;; The type of host objects returned is not constrained, except that the hosts must - ;; be acceptable to add-access-host and remove-access-host. - ;; This implementation uses a list whose car is the family keyword - ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes. - (declare (type display display) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence host) enabled-p)) - (with-buffer-request-and-reply (display +x-listhosts+ nil :sizes (8 16)) - () - (let* ((enabled-p (boolean-get 1)) - (nhosts (card16-get 8)) - (sequence (make-sequence result-type nhosts))) - (advance-buffer-offset +replysize+) - (dotimes (i nhosts) - (let ((family (card8-get 0)) - (len (card16-get 2))) - (setf (elt sequence i) - (cons (if (< family 3) - (svref '#(:internet :decnet :chaos) family) - family) - (sequence-get :length len :format card8 :result-type 'list - :index (+ buffer-boffset 4)))) - (advance-buffer-offset (+ 4 (* 4 (ceiling len 4)))))) - (values - sequence - enabled-p)))) - -(defun access-control (display) - (declare (type display display)) - (declare (clx-values generalized-boolean)) ;; True when access-control is ENABLED - (with-buffer-request-and-reply (display +x-listhosts+ 2 :sizes 8) - () - (boolean-get 1))) - -(defun set-access-control (display enabled-p) - (declare (type display display) - (type generalized-boolean enabled-p)) - (with-buffer-request (display +x-changeaccesscontrol+) - ((data boolean) enabled-p)) - enabled-p) - -(defsetf access-control set-access-control) - -(defun close-down-mode (display) - ;; setf'able - ;; Cached locally in display object. - (declare (type display display)) - (declare (clx-values (member :destroy :retain-permanent :retain-temporary nil))) - (display-close-down-mode display)) - -(defun set-close-down-mode (display mode) - ;; Cached locally in display object. - (declare (type display display) - (type (member :destroy :retain-permanent :retain-temporary) mode)) - (setf (display-close-down-mode display) mode) - (with-buffer-request (display +x-changeclosedownmode+ :sizes (32)) - ((data (member :destroy :retain-permanent :retain-temporary)) mode)) - mode) - -(defsetf close-down-mode set-close-down-mode) - -(defun kill-client (display resource-id) - (declare (type display display) - (type resource-id resource-id)) - (with-buffer-request (display +x-killclient+) - (resource-id resource-id))) - -(defun kill-temporary-clients (display) - (declare (type display display)) - (with-buffer-request (display +x-killclient+) - (resource-id 0))) - -(defun no-operation (display) - (declare (type display display)) - (with-buffer-request (display +x-nooperation+))) diff --git a/src/eclx/resource.lisp b/src/eclx/resource.lisp deleted file mode 100644 index db9a244b3..000000000 --- a/src/eclx/resource.lisp +++ /dev/null @@ -1,697 +0,0 @@ -;;; -*- Mode: LISP; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;; RESOURCE - Lisp version of XLIB's Xrm resource manager - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; -#+cmu -(ext:file-comment - "$Header$") - -(in-package :xlib) - -;; The C version of this uses a 64 entry hash table at each entry. -;; Small hash tables lose in Lisp, so we do linear searches on lists. - -(defstruct (resource-database (:copier nil) (:predicate nil) - (:print-function print-resource-database) - (:constructor make-resource-database-internal) - ) - (name nil :type stringable :read-only t) - (value nil) - (tight nil :type list) ;; List of resource-database - (loose nil :type list) ;; List of resource-database - ) - -(defun print-resource-database (database stream depth) - (declare (type resource-database database) - (ignore depth)) - (print-unreadable-object (database stream :type t) - (write-string (string (resource-database-name database)) stream) - (when (resource-database-value database) - (write-string " " stream) - (prin1 (resource-database-value database) stream)))) - -;; The value slot of the top-level resource-database structure is used for a -;; time-stamp. - -(defun make-resource-database () - ;; Make a resource-database with initial timestamp of 0 - (make-resource-database-internal :name "Top-Level" :value 0)) - -(defun resource-database-timestamp (database) - (declare (type resource-database database)) - (resource-database-value database)) - -(defun incf-resource-database-timestamp (database) - ;; Increment the timestamp - (declare (type resource-database database)) - (let ((timestamp (resource-database-value database))) - (setf (resource-database-value database) - (if (= timestamp most-positive-fixnum) - most-negative-fixnum - (1+ timestamp))))) - -;; DEBUG FUNCTION (not exported) -(defun print-db (entry &optional (level 0) type) - ;; Debug function to print a resource database - (format t "~%~v@t~s~:[~; *~]~@[ Value ~s~]" - level - (resource-database-name entry) - (eq type 'loose) - (resource-database-value entry)) - (when (resource-database-tight entry) - (dolist (tight (resource-database-tight entry)) - (print-db tight (+ 2 level) 'tight))) - (when (resource-database-loose entry) - (dolist (loose (resource-database-loose entry)) - (print-db loose (+ 2 level) 'loose)))) - -;; DEBUG FUNCTION -#+comment -(defun print-search-table (table) - (terpri) - (dolist (dbase-list table) - (format t "~%~s" dbase-list) - (dolist (db dbase-list) - (print-db db) - (dolist (dblist table) - (unless (eq dblist dbase-list) - (when (member db dblist) - (format t " duplicate at ~s" db)))) - ))) - -;; -;; If this is true, resource symbols will be compared in a case-insensitive -;; manner, and converting a resource string to a keyword will uppercaseify it. -;; -(defparameter *uppercase-resource-symbols* nil) - -(defun resource-key (stringable) - ;; Ensure STRINGABLE is a keyword. - (declare (type stringable stringable)) - (etypecase stringable - (symbol - (if (keywordp (the symbol stringable)) - stringable - (kintern (symbol-name (the symbol stringable))))) - (string - (if *uppercase-resource-symbols* - (setq stringable (string-upcase - (the string stringable)))) - (kintern (the string stringable))))) - -(defun stringable-equal (a b) - ;; Compare two stringables. - ;; Ignore case when comparing to a symbol. - (declare (type stringable a b)) - (declare (clx-values generalized-boolean)) - (etypecase a - (string - (etypecase b - (string - (string= (the string a) (the string b))) - (symbol - (if *uppercase-resource-symbols* - (string-equal (the string a) - (the string (symbol-name (the symbol b)))) - (string= (the string a) - (the string (symbol-name (the symbol b)))))))) - (symbol - (etypecase b - (string - (if *uppercase-resource-symbols* - (string-equal (the string (symbol-name (the symbol a))) - (the string b)) - (string= (the string (symbol-name (the symbol a))) - (the string b)))) - (symbol - (string= (the string (symbol-name (the symbol a))) - (the string (symbol-name (the symbol b))))))))) - - -;;;----------------------------------------------------------------------------- -;;; Add/delete resource - -(defun add-resource (database name-list value) - ;; name-list is a list of either strings or symbols. If a symbol, - ;; case-insensitive comparisons will be used, if a string, - ;; case-sensitive comparisons will be used. The symbol '* or - ;; string "*" are used as wildcards, matching anything or nothing. - (declare (type resource-database database) - (type (clx-list stringable) name-list) - (type t value)) - (unless value (error "Null resource values are ignored")) - (incf-resource-database-timestamp database) - (do* ((list name-list (cdr list)) - (name (car list) (car list)) - (node database) - (loose-p nil)) - ((endp list) - (setf (resource-database-value node) value)) - ;; Key is the first name that isn't * - (if (stringable-equal name "*") - (setq loose-p t) - ;; find the entry associated with name - (progn - (do ((entry (if loose-p - (resource-database-loose node) - (resource-database-tight node)) - (cdr entry))) - ((endp entry) - ;; Entry not found - create a new one - (setq entry (make-resource-database-internal :name name)) - (if loose-p - (push entry (resource-database-loose node)) - (push entry (resource-database-tight node))) - (setq node entry)) - (when (stringable-equal name (resource-database-name (car entry))) - ;; Found entry - use it - (return (setq node (car entry))))) - (setq loose-p nil))))) - - -(defun delete-resource (database name-list) - (declare (type resource-database database) - (type list name-list)) - (incf-resource-database-timestamp database) - (delete-resource-internal database name-list)) - -(defun delete-resource-internal (database name-list) - (declare (type resource-database database) - (type (clx-list stringable) name-list)) - (do* ((list name-list (cdr list)) - (string (car list) (car list)) - (node database) - (loose-p nil)) - ((endp list) nil) - ;; Key is the first name that isn't * - (if (stringable-equal string "*") - (setq loose-p t) - ;; find the entry associated with name - (progn - (do* ((first-entry (if loose-p - (resource-database-loose node) - (resource-database-tight node))) - (entry-list first-entry (cdr entry-list)) - (entry (car entry-list) (car entry-list))) - ((endp entry-list) - ;; Entry not found - exit - (return-from delete-resource-internal nil)) - (when (stringable-equal string (resource-database-name entry)) - (when (cdr list) (delete-resource-internal entry (cdr list))) - (when (and (null (resource-database-loose entry)) - (null (resource-database-tight entry))) - (if loose-p - (setf (resource-database-loose node) - (delete entry (resource-database-loose node) - :test #'eq :count 1)) - (setf (resource-database-tight node) - (delete entry (resource-database-tight node) - :test #'eq :count 1)))) - (return-from delete-resource-internal t))) - (setq loose-p nil))))) - -;;;----------------------------------------------------------------------------- -;;; Get Resource - -(defun get-resource (database value-name value-class full-name full-class) - ;; Return the value of the resource in DATABASE whose partial name - ;; most closely matches (append full-name (list value-name)) and - ;; (append full-class (list value-class)). - (declare (type resource-database database) - (type stringable value-name value-class) - (type (clx-list stringable) full-name full-class)) - (declare (clx-values value)) - (let ((names (append full-name (list value-name))) - (classes (append full-class (list value-class)))) - (let* ((result (get-entry (resource-database-tight database) - (resource-database-loose database) - names classes))) - (when result - (resource-database-value result))))) - -(defun get-entry-lookup (table name names classes) - (declare (type list table names classes) - (type stringable name)) - (dolist (entry table) - (declare (type resource-database entry)) - (when (stringable-equal name (resource-database-name entry)) - (if (null (cdr names)) - (return entry) - (let ((result (get-entry (resource-database-tight entry) - (resource-database-loose entry) - (cdr names) (cdr classes)))) - (declare (type (or null resource-database) result)) - (when result - (return result) - )))))) - -(defun get-entry (tight loose names classes &aux result) - (declare (type list tight loose names classes)) - (let ((name (car names)) - (class (car classes))) - (declare (type stringable name class)) - (cond ((and tight - (get-entry-lookup tight name names classes))) - ((and loose - (get-entry-lookup loose name names classes))) - ((and tight - (not (stringable-equal name class)) - (get-entry-lookup tight class names classes))) - ((and loose - (not (stringable-equal name class)) - (get-entry-lookup loose class names classes))) - (loose - (loop - (pop names) (pop classes) - (unless (and names classes) (return nil)) - (setq name (car names) - class (car classes)) - (when (setq result (get-entry-lookup loose name names classes)) - (return result)) - (when (and (not (stringable-equal name class)) - (setq result - (get-entry-lookup loose class names classes))) - (return result)) - ))))) - - -;;;----------------------------------------------------------------------------- -;;; Get-resource with search-table - -(defun get-search-resource (table name class) - ;; (get-search-resource (get-search-table database full-name full-class) - ;; value-name value-class) - ;; is equivalent to - ;; (get-resource database value-name value-class full-name full-class) - ;; But since most of the work is done by get-search-table, - ;; get-search-resource is MUCH faster when getting several resources with - ;; the same full-name/full-class - (declare (type list table) - (type stringable name class)) - (let ((do-class (and class (not (stringable-equal name class))))) - (dolist (dbase-list table) - (declare (type list dbase-list)) - (dolist (dbase dbase-list) - (declare (type resource-database dbase)) - (when (stringable-equal name (resource-database-name dbase)) - (return-from get-search-resource - (resource-database-value dbase)))) - (when do-class - (dolist (dbase dbase-list) - (declare (type resource-database dbase)) - (when (stringable-equal class (resource-database-name dbase)) - (return-from get-search-resource - (resource-database-value dbase)))))))) - -(defvar *get-table-result*) - -(defun get-search-table (database full-name full-class) - ;; Return a search table for use with get-search-resource. - (declare (type resource-database database) - (type (clx-list stringable) full-name full-class)) - (declare (clx-values value)) - (let* ((tight (resource-database-tight database)) - (loose (resource-database-loose database)) - (result (cons nil nil)) - (*get-table-result* result)) - (declare (type list tight loose) - (type cons result)) - (when (or tight loose) - (when full-name - (get-tables tight loose full-name full-class)) - - ;; Pick up bindings of the form (* name). These are the elements of - ;; top-level loose without further tight/loose databases. - ;; - ;; (Hack: these bindings belong in ANY search table, so recomputing them - ;; is a drag. True fix involves redesigning entire lookup - ;; data-structure/algorithm.) - ;; - (let ((universal-bindings - (remove nil loose :test-not #'eq - :key #'(lambda (database) - (or (resource-database-tight database) - (resource-database-loose database)))))) - (when universal-bindings - (setf (cdr *get-table-result*) (list universal-bindings))))) - (cdr result))) - -(defun get-tables-lookup (dbase name names classes) - (declare (type list dbase names classes) - (type stringable name)) - #-clx-debugging - (declare (optimize speed)) - (dolist (entry dbase) - (declare (type resource-database entry)) - (when (stringable-equal name (resource-database-name entry)) - (let ((tight (resource-database-tight entry)) - (loose (resource-database-loose entry))) - (declare (type list tight loose)) - (when (or tight loose) - (if (cdr names) - (get-tables tight loose (cdr names) (cdr classes)) - (when tight - (let ((result *get-table-result*)) - ;; Put tight at end of *get-table-result* - (setf (cdr result) - (setq *get-table-result* (cons tight nil)))))) - (when loose - (let ((result *get-table-result*)) - ;; Put loose at end of *get-table-result* - (setf (cdr result) - (setq *get-table-result* (cons loose nil)))))))))) - -(defun get-tables (tight loose names classes) - (declare (type list tight loose names classes)) - (let ((name (car names)) - (class (car classes))) - (declare (type stringable name class)) - (when tight - (get-tables-lookup tight name names classes)) - (when loose - (get-tables-lookup loose name names classes)) - (when (and tight (not (stringable-equal name class))) - (get-tables-lookup tight class names classes)) - (when (and loose (not (stringable-equal name class))) - (get-tables-lookup loose class names classes)) - (when loose - (loop - (pop names) (pop classes) - (unless (and names classes) (return nil)) - (setq name (car names) - class (car classes)) - (get-tables-lookup loose name names classes) - (unless (stringable-equal name class) - (get-tables-lookup loose class names classes)) - )))) - - -;;;----------------------------------------------------------------------------- -;;; Utility functions - -(defun map-resource (database function &rest args) - ;; Call FUNCTION on each resource in DATABASE. - ;; FUNCTION is called with arguments (name-list value . args) - (declare (type resource-database database) - (type (function (list t &rest t) t) function) - (dynamic-extent function) - (dynamic-extent args)) - (declare (clx-values nil)) - (labels ((map-resource-internal (database function args name) - (declare (type resource-database database) - (type (function (list t &rest t) t) function) - (type list name) - (dynamic-extent function)) - (let ((tight (resource-database-tight database)) - (loose (resource-database-loose database))) - (declare (type list tight loose)) - (dolist (resource tight) - (declare (type resource-database resource)) - (let ((value (resource-database-value resource)) - (name (append - name - (list (resource-database-name resource))))) - (if value - (apply function name value args) - (map-resource-internal resource function args name)))) - (dolist (resource loose) - (declare (type resource-database resource)) - (let ((value (resource-database-value resource)) - (name (append - name - (list "*" (resource-database-name resource))))) - (if value - (apply function name value args) - (map-resource-internal resource function args name))))))) - (map-resource-internal database function args nil))) - -(defun merge-resources (database with-database) - (declare (type resource-database database with-database)) - (declare (clx-values resource-database)) - (map-resource - database - #'(lambda (name value database) - (add-resource database name value)) - with-database) - with-database) - -(defun char-memq (key char) - ;; Used as a test function for POSITION - (declare (type base-char char)) - (member char key)) - -(defmacro resource-with-open-file ((stream pathname &rest options) &body body) - ;; Private WITH-OPEN-FILE, which, when pathname is a stream, uses it as the - ;; stream - (let ((abortp (gensym)) - (streamp (gensym))) - `(let* ((,abortp t) - (,streamp (streamp pathname)) - (,stream (if ,streamp pathname (open ,pathname ,@options)))) - (unwind-protect - (multiple-value-prog1 - (progn ,@body) - (setq ,abortp nil)) - (unless ,streamp - (close stream :abort ,abortp)))))) - -(defun read-resources (database pathname &key key test test-not) - ;; Merges resources from a file in standard X11 format with DATABASE. - ;; KEY is a function used for converting value-strings, the default is - ;; identity. TEST and TEST-NOT are predicates used for filtering - ;; which resources to include in the database. They are called with - ;; the name and results of the KEY function. - (declare (type resource-database database) - (type (or pathname string stream) pathname) - (type (or null (function (string) t)) key) - (type (or null (function (list t) generalized-boolean)) - test test-not)) - (declare (clx-values resource-database)) - (resource-with-open-file (stream pathname) - (loop - (let ((string (read-line stream nil :eof))) - (declare (type (or string keyword) string)) - (when (eq string :eof) (return database)) - (let* ((end (length string)) - (i (position '(#\tab #\space) string - :test-not #'char-memq :end end)) - (term nil)) - (declare (type array-index end) - (type (or null array-index) i term)) - (when i ;; else blank line - (case (char string i) - (#\! nil) ;; Comment - skip - ;;(#.(card8->char 0) nil) ;; terminator for C strings - skip - (#\# ;; Include - (setq term (position '(#\tab #\space) string :test #'char-memq - :start i :end end)) - (when (string-equal string "#INCLUDE" :start1 i :end1 term) - (let ((path (merge-pathnames - (string-trim '(#\tab #\space #\") - (subseq string (1+ term))) - (truename stream)))) - (read-resources database path - :key key :test test :test-not test-not)))) - (otherwise - (multiple-value-bind (name-list value) - (parse-resource string i end) - (when name-list - (when key (setq value (funcall key value))) - (when - (cond (test (funcall test name-list value)) - (test-not (not (funcall test-not name-list value))) - (t t)) - (add-resource database name-list value)))))))))))) - -(defun parse-resource (string &optional (start 0) end) - ;; Parse a resource specfication string into a list of names and a value - ;; string - (declare (type string string) - (type array-index start) - (type (or null array-index) end)) - (declare (clx-values name-list value)) - (do ((i start) - (end (or end (length string))) - (term) - (name-list)) - ((>= i end)) - (declare (type array-index end) - (type (or null array-index) i term)) - (setq term (position '(#\. #\* #\:) string - :test #'char-memq :start i :end end)) - (case (and term (char string term)) - ;; Name seperator - (#\. (when (> term i) - (push (subseq string i term) name-list))) - ;; Wildcard seperator - (#\* (when (> term i) - (push (subseq string i term) name-list)) - (push '* name-list)) - ;; Value separator - (#\: - (push (subseq string i term) name-list) - (return - (values - (nreverse name-list) - (string-trim '(#\tab #\space) (subseq string (1+ term)))))) - (otherwise - (return - (values - (nreverse name-list) - (subseq string i term))))) - (setq i (1+ term)))) - -(defun write-resources (database pathname &key write test test-not) - ;; Write resources to PATHNAME in the standard X11 format. - ;; WRITE is a function used for writing values, the default is #'princ - ;; TEST and TEST-NOT are predicates used for filtering which resources - ;; to include in the database. They are called with the name and value. - (declare (type resource-database database) - (type (or pathname string stream) pathname) - (type (or null (function (string stream) t)) write) - (type (or null (function (list t) generalized-boolean)) - test test-not)) - (resource-with-open-file (stream pathname :direction :output) - (map-resource - database - #'(lambda (name-list value stream write test test-not) - (when - (cond (test (funcall test name-list value)) - (test-not (not (funcall test-not name-list value))) - (t t)) - (let ((previous (car name-list))) - (princ previous stream) - (dolist (name (cdr name-list)) - (unless (or (stringable-equal name "*") - (stringable-equal previous "*")) - (write-char #\. stream)) - (setq previous name) - (princ name stream))) - (write-string ": " stream) - (funcall write value stream) - (terpri stream))) - stream (or write #'princ) test test-not)) - database) - -(defun wm-resources (database window &key key test test-not) - ;; Takes the resources associated with the RESOURCE_MANAGER property - ;; of WINDOW (if any) and merges them with DATABASE. - ;; KEY is a function used for converting value-strings, the default is - ;; identity. TEST and TEST-NOT are predicates used for filtering - ;; which resources to include in the database. They are called with - ;; the name and results of the KEY function. - (declare (type resource-database database) - (type window window) - (type (or null (function (string) t)) key) - (type (or null (function (list t) generalized-boolean)) - test test-not)) - (declare (clx-values resource-database)) - (let ((string (get-property window :RESOURCE_MANAGER :type :STRING - :result-type 'string - :transform #'xlib::card8->char))) - (when string - (with-input-from-string (stream string) - (read-resources database stream - :key key :test test :test-not test-not))))) - -(defun set-wm-resources (database window &key write test test-not) - ;; Sets the resources associated with the RESOURCE_MANAGER property - ;; of WINDOW. - ;; WRITE is a function used for writing values, the default is #'princ - ;; TEST and TEST-NOT are predicates used for filtering which resources - ;; to include in the database. They are called with the name and value. - (declare (type resource-database database) - (type window window) - (type (or null (function (string stream) t)) write) - (type (or null (function (list t) generalized-boolean)) - test test-not)) - (xlib::set-string-property - window :RESOURCE_MANAGER - (with-output-to-string (stream) - (write-resources database stream :write write - :test test :test-not test-not)))) - -(defun root-resources (screen &key database key test test-not) - "Returns a resource database containing the contents of the root window - RESOURCE_MANAGER property for the given SCREEN. If SCREEN is a display, - then its default screen is used. If an existing DATABASE is given, then - resource values are merged with the DATABASE and the modified DATABASE is - returned. - - TEST and TEST-NOT are predicates for selecting which resources are - read. Arguments are a resource name list and a resource value. The KEY - function, if given, is called to convert a resource value string to the - value given to TEST or TEST-NOT." - - (declare (type (or screen display) screen) - (type (or null resource-database) database) - (type (or null (function (string) t)) key) - (type (or null (function (list t) generalized-boolean)) test test-not) - (clx-values resource-database)) - (let* ((screen (if (type? screen 'display) - (display-default-screen screen) - screen)) - (window (screen-root screen)) - (database (or database (make-resource-database)))) - (wm-resources database window :key key :test test :test-not test-not) - database)) - -(defun set-root-resources (screen &key test test-not (write #'princ) database) - "Changes the contents of the root window RESOURCE_MANAGER property for the - given SCREEN. If SCREEN is a display, then its default screen is used. - - TEST and TEST-NOT are predicates for selecting which resources from the - DATABASE are written. Arguments are a resource name list and a resource - value. The WRITE function is used to convert a resource value into a - string stored in the property." - - (declare (type (or screen display) screen) - (type (or null resource-database) database) - (type (or null (function (list t) generalized-boolean)) test test-not) - (type (or null (function (string stream) t)) write) - (clx-values resource-database)) - (let* ((screen (if (type? screen 'display) - (display-default-screen screen) - screen)) - (window (screen-root screen))) - (set-wm-resources database window - :write write :test test :test-not test-not) - database)) - -(defsetf root-resources (screen &key test test-not (write #'princ))(database) - `(set-root-resources - ,screen :test ,test :test-not ,test-not :write ,write :database ,database)) - -(defun initialize-resource-database (display) - ;; This function is (supposed to be) equivalent to the Xlib initialization - ;; code. - (declare (type display display)) - (let ((rdb (make-resource-database)) - (rootwin (screen-root (car (display-roots display))))) - ;; First read the server defaults if present, otherwise from the default - ;; resource file - (if (get-property rootwin :RESOURCE_MANAGER) - (xlib:wm-resources rdb rootwin) - (let ((path (default-resources-pathname))) - (when (and path (probe-file path)) - (read-resources rdb path)))) - ;; Next read from the resources file - (let ((path (resources-pathname))) - (when (and path (probe-file path)) - (read-resources rdb path))) - (setf (display-xdefaults display) rdb))) diff --git a/src/eclx/shape.lisp b/src/eclx/shape.lisp deleted file mode 100644 index 6171c67ca..000000000 --- a/src/eclx/shape.lisp +++ /dev/null @@ -1,192 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- -;;; --------------------------------------------------------------------------- -;;; Title: X11 Shape extension -;;; Created: 1999-05-14 11:31 -;;; Author: Gilbert Baumann -;;; --------------------------------------------------------------------------- -;;; (c) copyright 1999 by Gilbert Baumann - -;;; -;;; Permission is granted to any individual or institution to use, -;;; copy, modify, and distribute this software, provided that this -;;; complete copyright and permission notice is maintained, intact, in -;;; all copies and supporting documentation. -;;; -;;; This program 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. -;;; - -;;; Use xc/doc/hardcopy/Xext/shape.PS.gz obtainable from e.g. -;; ftp://ftp.xfree86.org/pub/XFree86/current/untarred/xc/hardcopy/Xext/shape.PS.gz - -(in-package :xlib) - -(export '(shape-query-version - shape-rectangles - shape-mask - shape-combine - shape-offset - shape-query-extents - shape-select-input - shape-input-selected-p - shape-get-rectangles) - :xlib) - -(define-extension "SHAPE" - :events (:shape-notify)) - -(declare-event :shape-notify - ((data (member8 :bounding :clip)) kind) ;shape kind - (card16 sequence) - (window (window event-window)) ;affected window - (int16 x) ;extents - (int16 y) - (card16 width) - (card16 height) - ((or null card32) time) ;timestamp - (boolean shaped-p)) - -(defun encode-shape-kind (kind) - (ecase kind - (:bounding 0) - (:clip 1))) - -(defun encode-shape-operation (operation) - (ecase operation - (:set 0) - (:union 1) - (:interset 2) - (:subtract 3) - (:invert 4))) - -(defun encode-shape-rectangle-ordering (ordering) - (ecase ordering - ((:unsorted :un-sorted nil) 0) - ((:y-sorted) 1) - ((:yx-sorted) 2) - ((:yx-banded) 3))) - -(defun shape-query-version (display) - (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") - nil :sizes 16) - ((data 0)) - (values - (card16-get 8) - (card16-get 10)))) - -(defun shape-rectangles (window rectangles - &key (kind :bounding) - (x-offset 0) - (y-offset 0) - (operation :set) - (ordering :unsorted)) - (let* ((display (xlib:window-display window))) - (with-buffer-request (display (extension-opcode display "SHAPE")) - (data 1) - (card8 (encode-shape-operation operation)) - (card8 (encode-shape-kind kind)) - (card8 (encode-shape-rectangle-ordering ordering)) - (card8 0) ;unused - (window window) - (int16 x-offset) - (int16 y-offset) - ((sequence :format int16) rectangles)))) - -(defun shape-mask (window pixmap - &key (kind :bounding) - (x-offset 0) - (y-offset 0) - (operation :set)) - (let* ((display (xlib:window-display window))) - (with-buffer-request (display (extension-opcode display "SHAPE")) - (data 2) - (card8 (encode-shape-operation operation)) - (card8 (encode-shape-kind kind)) - (card16 0) ;unused - (window window) - (int16 x-offset) - (int16 y-offset) - ((or pixmap (member :none)) pixmap)))) - -(defun shape-combine (window source-window - &key (kind :bounding) - (source-kind :bounding) - (x-offset 0) - (y-offset 0) - (operation :set)) - (let* ((display (xlib:window-display window))) - (with-buffer-request (display (extension-opcode display "SHAPE")) - (data 3) - (card8 (encode-shape-operation operation)) - (card8 (encode-shape-kind kind)) - (card8 (encode-shape-kind source-kind)) - (card8 0) ;unused - (window window) - (int16 x-offset) - (int16 y-offset) - (window source-window)))) - -(defun shape-offset (window &key (kind :bounding) (x-offset 0) (y-offset 0)) - (let* ((display (xlib:window-display window))) - (with-buffer-request (display (extension-opcode display "SHAPE")) - (data 4) - (card8 (encode-shape-kind kind)) - (card8 0) (card8 0) (card8 0) ;unused - (window window) - (int16 x-offset) - (int16 y-offset)))) - -(defun shape-query-extents (window) - (let* ((display (xlib:window-display window))) - (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") - nil :sizes (8 16 32)) - ((data 5) - (window window)) - (values - (boolean-get 8) ;bounding shaped - (boolean-get 9) ;clip shaped - (int16-get 12) ;bounding shape extents x - (int16-get 14) ;bounding shape extents y - (card16-get 16) ;bounding shape extents width - (card16-get 18) ;bounding shape extents height - (int16-get 20) ;clip shape extents x - (int16-get 22) ;clip shape extents y - (card16-get 24) ;clip shape extents width - (card16-get 26))))) ;clip shape extents height - -(defun shape-select-input (window selected-p) - (let* ((display (window-display window))) - (with-buffer-request (display (extension-opcode display "SHAPE")) - (data 6) - (window window) - (boolean selected-p)) )) - -(defun shape-input-selected-p (window) - (let* ((display (window-display window))) - (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") - nil :sizes (8)) - ((data 7) ;also wrong in documentation - (window window)) - (boolean-get 1)))) - -(defun shape-get-rectangles (window &optional (kind :bounding) - (result-type 'list)) - (let* ((display (window-display window))) - (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") - nil :sizes (8 16 32)) - ((data 8) ;this was wrong in the specification - (window window) - (card8 (ecase kind - (:bounding 0) - (:clip 1)))) - (values - (sequence-get :length (print (* 4 (card32-get 8))) - :result-type result-type - :format int16 - :index +replysize+) - (ecase (card8-get 1) - (0 :unsorted) - (1 :y-sorted) - (2 :yx-sorted) - (3 :yx-banded) ))))) diff --git a/src/eclx/split-sequence.lisp b/src/eclx/split-sequence.lisp deleted file mode 100644 index 05ff15521..000000000 --- a/src/eclx/split-sequence.lisp +++ /dev/null @@ -1,243 +0,0 @@ -;;;; SPLIT-SEQUENCE -;;; -;;; This code was based on Arthur Lemmens' in -;;; ; -;;; -;;; changes include: -;;; -;;; * altering the behaviour of the :from-end keyword argument to -;;; return the subsequences in original order, for consistency with -;;; CL:REMOVE, CL:SUBSTITUTE et al. (:from-end being non-NIL only -;;; affects the answer if :count is less than the number of -;;; subsequences, by analogy with the above-referenced functions). -;;; -;;; * changing the :maximum keyword argument to :count, by analogy -;;; with CL:REMOVE, CL:SUBSTITUTE, and so on. -;;; -;;; * naming the function SPLIT-SEQUENCE rather than PARTITION rather -;;; than SPLIT. -;;; -;;; * adding SPLIT-SEQUENCE-IF and SPLIT-SEQUENCE-IF-NOT. -;;; -;;; * The second return value is now an index rather than a copy of a -;;; portion of the sequence; this index is the `right' one to feed to -;;; CL:SUBSEQ for continued processing. - -;;; There's a certain amount of code duplication here, which is kept -;;; to illustrate the relationship between the SPLIT-SEQUENCE -;;; functions and the CL:POSITION functions. - -;;; Examples: -;;; -;;; * (split-sequence #\; "a;;b;c") -;;; -> ("a" "" "b" "c"), 6 -;;; -;;; * (split-sequence #\; "a;;b;c" :from-end t) -;;; -> ("a" "" "b" "c"), 0 -;;; -;;; * (split-sequence #\; "a;;b;c" :from-end t :count 1) -;;; -> ("c"), 4 -;;; -;;; * (split-sequence #\; "a;;b;c" :remove-empty-subseqs t) -;;; -> ("a" "b" "c"), 6 -;;; -;;; * (split-sequence-if (lambda (x) (member x '(#\a #\b))) "abracadabra") -;;; -> ("" "" "r" "c" "d" "" "r" ""), 11 -;;; -;;; * (split-sequence-if-not (lambda (x) (member x '(#\a #\b))) "abracadabra") -;;; -> ("ab" "a" "a" "ab" "a"), 11 -;;; -;;; * (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9) -;;; -> ("oo" "bar" "b"), 9 - -(defpackage "SPLIT-SEQUENCE" - (:use "CL") - (:nicknames "PARTITION") - (:export "SPLIT-SEQUENCE" "SPLIT-SEQUENCE-IF" "SPLIT-SEQUENCE-IF-NOT" - "PARTITION" "PARTITION-IF" "PARTITION-IF-NOT")) - -(in-package "SPLIT-SEQUENCE") - -(defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied)) - "Return a list of subsequences in seq delimited by delimiter. - -If :remove-empty-subseqs is NIL, empty subsequences will be included -in the result; otherwise they will be discarded. All other keywords -work analogously to those for CL:SUBSTITUTE. In particular, the -behaviour of :from-end is possibly different from other versions of -this function; :from-end values of NIL and T are equivalent unless -:count is supplied. The second return value is an index suitable as an -argument to CL:SUBSEQ into the sequence indicating where processing -stopped." - (let ((len (length seq)) - (other-keys (nconc (when test-supplied - (list :test test)) - (when test-not-supplied - (list :test-not test-not)) - (when key-supplied - (list :key key))))) - (unless end (setq end len)) - (if from-end - (loop for right = end then left - for left = (max (or (apply #'position delimiter seq - :end right - :from-end t - other-keys) - -1) - (1- start)) - unless (and (= right (1+ left)) - remove-empty-subseqs) ; empty subseq we don't want - if (and count (>= nr-elts count)) - ;; We can't take any more. Return now. - return (values (nreverse subseqs) right) - else - collect (subseq seq (1+ left) right) into subseqs - and sum 1 into nr-elts - until (< left start) - finally (return (values (nreverse subseqs) (1+ left)))) - (loop for left = start then (+ right 1) - for right = (min (or (apply #'position delimiter seq - :start left - other-keys) - len) - end) - unless (and (= right left) - remove-empty-subseqs) ; empty subseq we don't want - if (and count (>= nr-elts count)) - ;; We can't take any more. Return now. - return (values subseqs left) - else - collect (subseq seq left right) into subseqs - and sum 1 into nr-elts - until (>= right end) - finally (return (values subseqs right)))))) - -(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) - "Return a list of subsequences in seq delimited by items satisfying -predicate. - -If :remove-empty-subseqs is NIL, empty subsequences will be included -in the result; otherwise they will be discarded. All other keywords -work analogously to those for CL:SUBSTITUTE-IF. In particular, the -behaviour of :from-end is possibly different from other versions of -this function; :from-end values of NIL and T are equivalent unless -:count is supplied. The second return value is an index suitable as an -argument to CL:SUBSEQ into the sequence indicating where processing -stopped." - (let ((len (length seq)) - (other-keys (when key-supplied - (list :key key)))) - (unless end (setq end len)) - (if from-end - (loop for right = end then left - for left = (max (or (apply #'position-if predicate seq - :end right - :from-end t - other-keys) - -1) - (1- start)) - unless (and (= right (1+ left)) - remove-empty-subseqs) ; empty subseq we don't want - if (and count (>= nr-elts count)) - ;; We can't take any more. Return now. - return (values (nreverse subseqs) right) - else - collect (subseq seq (1+ left) right) into subseqs - and sum 1 into nr-elts - until (< left start) - finally (return (values (nreverse subseqs) (1+ left)))) - (loop for left = start then (+ right 1) - for right = (min (or (apply #'position-if predicate seq - :start left - other-keys) - len) - end) - unless (and (= right left) - remove-empty-subseqs) ; empty subseq we don't want - if (and count (>= nr-elts count)) - ;; We can't take any more. Return now. - return (values subseqs left) - else - collect (subseq seq left right) into subseqs - and sum 1 into nr-elts - until (>= right end) - finally (return (values subseqs right)))))) - -(defun split-sequence-if-not (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) - "Return a list of subsequences in seq delimited by items satisfying -(CL:COMPLEMENT predicate). - -If :remove-empty-subseqs is NIL, empty subsequences will be included -in the result; otherwise they will be discarded. All other keywords -work analogously to those for CL:SUBSTITUTE-IF-NOT. In particular, -the behaviour of :from-end is possibly different from other versions -of this function; :from-end values of NIL and T are equivalent unless -:count is supplied. The second return value is an index suitable as an -argument to CL:SUBSEQ into the sequence indicating where processing -stopped." - (let ((len (length seq)) - (other-keys (when key-supplied - (list :key key)))) - (unless end (setq end len)) - (if from-end - (loop for right = end then left - for left = (max (or (apply #'position-if-not predicate seq - :end right - :from-end t - other-keys) - -1) - (1- start)) - unless (and (= right (1+ left)) - remove-empty-subseqs) ; empty subseq we don't want - if (and count (>= nr-elts count)) - ;; We can't take any more. Return now. - return (values (nreverse subseqs) right) - else - collect (subseq seq (1+ left) right) into subseqs - and sum 1 into nr-elts - until (< left start) - finally (return (values (nreverse subseqs) (1+ left)))) - (loop for left = start then (+ right 1) - for right = (min (or (apply #'position-if-not predicate seq - :start left - other-keys) - len) - end) - unless (and (= right left) - remove-empty-subseqs) ; empty subseq we don't want - if (and count (>= nr-elts count)) - ;; We can't take any more. Return now. - return (values subseqs left) - else - collect (subseq seq left right) into subseqs - and sum 1 into nr-elts - until (>= right end) - finally (return (values subseqs right)))))) - -;;; clean deprecation - -(defun partition (&rest args) - (apply #'split-sequence args)) - -(defun partition-if (&rest args) - (apply #'split-sequence-if args)) - -(defun partition-if-not (&rest args) - (apply #'split-sequence-if-not args)) - -(define-compiler-macro partition (&whole form &rest args) - (declare (ignore args)) - (warn "PARTITION is deprecated; use SPLIT-SEQUENCE instead.") - form) - -(define-compiler-macro partition-if (&whole form &rest args) - (declare (ignore args)) - (warn "PARTITION-IF is deprecated; use SPLIT-SEQUENCE-IF instead.") - form) - -(define-compiler-macro partition-if-not (&whole form &rest args) - (declare (ignore args)) - (warn "PARTITION-IF-NOT is deprecated; use SPLIT-SEQUENCE-IF-NOT instead") - form) - -(pushnew :split-sequence *features*) diff --git a/src/eclx/test/image.lisp b/src/eclx/test/image.lisp deleted file mode 100644 index 17160d69f..000000000 --- a/src/eclx/test/image.lisp +++ /dev/null @@ -1,155 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;;; Tests image code by randomly reading, copying and then writing images to -;;; the exact same place on the screen. If everything works, just the borders -;;; of the image windows appear. If one of these image windows is garbled, -;;; then somewhere something is broken. Entry point is the function -;;; IMAGE-TEST - -(in-package :xlib) - -(export '(image-test)) - -(defvar *image-test-host* "") - -(defvar *image-test-nimages* 25) - -(defvar *image-test-copy* t) - -(defvar *image-test-copy-random-subimage* t) - -(defvar *image-test-put-random-subimage* t) - -(defvar *image-test-get-image-result-type-choices* - '(image-x image-x image-xy image-z)) - -(defvar *image-test-get-image-image-x-format-choices* - '(:xy-pixmap :z-pixmap)) - -(defun image-test - (&key - (host *image-test-host*) - (nimages *image-test-nimages*) - (copy *image-test-copy*) - (copy-random-subimage *image-test-copy-random-subimage*) - (put-random-subimage *image-test-put-random-subimage*) - (get-image-result-type-choices - *image-test-get-image-result-type-choices*) - (get-image-image-x-format-choices - *image-test-get-image-image-x-format-choices*)) - (let* ((display nil) - (abort t) - (images nil)) - (loop - (setq images nil) - (unwind-protect - (progn - (setq display (open-display host)) - (let* ((screen (display-default-screen display)) - (window (screen-root screen)) - (gcontext (create-gcontext - :drawable window - :font (open-font display "fixed")))) - (dotimes (i nimages) - (let ((image (image-test-get-image - window - get-image-result-type-choices - get-image-image-x-format-choices))) - (format t "~&Image=~S~%" image) - (let ((copy (if copy - (image-test-copy-image - image - copy-random-subimage) - image))) - (format t "~&Copy=~S~%" copy) - (push (list image copy) images) - (image-test-put-image - screen gcontext copy - (concatenate - 'string (image-info image) (image-info copy)) - put-random-subimage)))) - (unless (y-or-n-p "More ") (return)) - (setq abort nil))) - (close-display (shiftf display nil) :abort abort)) - (sleep 10)) - (reverse images))) - -(defun image-test-choose (list) - (nth (random (length list)) list)) - -(defun image-test-get-image (window result-type-choices image-x-format-choices) - (let* ((x (random (floor (drawable-width window) 3))) - (y (random (floor (drawable-height window) 3))) - (hw (floor (- (drawable-width window) x) 3)) - (hh (floor (- (drawable-height window) y) 3)) - (width (+ hw hw (random hw))) - (height (+ hh hh (random hh))) - (result-type (image-test-choose result-type-choices)) - (format - (ecase result-type - (image-x (image-test-choose image-x-format-choices)) - (image-xy :xy-pixmap) - (image-z :z-pixmap))) - (image (get-image window :x x :y y :width width :height height - :format format :result-type result-type))) - ;; XCreatePixmapCursor(3X11) says that x,y for hotspot are - ;; unsigned, so what we're doing here I don't know - ;;(setf (image-x-hot image) (- x)) - ;;(setf (image-y-hot image) (- y)) - image)) - -(defun image-test-subimage-parameters (image random-subimage-p) - (if random-subimage-p - (let* ((x (random (floor (image-width image) 3))) - (y (random (floor (image-height image) 3))) - (hw (floor (- (image-width image) x) 3)) - (hh (floor (- (image-height image) y) 3)) - (width (+ hw hw (random hw))) - (height (+ hh hh (random hh)))) - (values x y width height)) - (values 0 0 (image-width image) (image-height image)))) - -(defun image-test-copy-image (image random-subimage-p) - (let ((result-type - (if (zerop (random 2)) - (type-of image) - (etypecase image - (image-x (ecase (image-x-format image) - (:xy-pixmap 'image-xy) - (:z-pixmap 'image-z))) - ((or image-xy image-z) 'image-x))))) - (multiple-value-bind (x y width height) - (image-test-subimage-parameters image random-subimage-p) - (copy-image image :x x :y y :width width :height height - :result-type result-type)))) - -(defun image-test-put-image (screen gcontext image info random-subimage-p) - (multiple-value-bind (src-x src-y width height) - (image-test-subimage-parameters image random-subimage-p) - (let* ((border-width 1) - (x (- src-x #+nil (image-x-hot image) border-width)) - (y (- src-y #+nil (image-y-hot image) border-width))) - (unless (or (zerop width) (zerop height)) - (let ((window - (create-window - :parent (screen-root screen) :x x :y y - :width width :height height - :border-width border-width - :background (screen-white-pixel screen) - :override-redirect :on))) - (map-window window) - (display-finish-output (drawable-display window)) - (put-image window gcontext image - :x 0 :y 0 :src-x src-x :src-y src-y - :width width :height height) - (draw-image-glyphs window gcontext 0 (1- height) info) - (display-finish-output (drawable-display window)) - window))))) - -(defun image-info (image) - (etypecase image - (image-x (ecase (image-x-format image) - (:xy-pixmap "XXY") - (:z-pixmap "XZ "))) - (image-xy "XY ") - (image-z "Z "))) diff --git a/src/eclx/test/trapezoid.lisp b/src/eclx/test/trapezoid.lisp deleted file mode 100644 index 7b1a571b4..000000000 --- a/src/eclx/test/trapezoid.lisp +++ /dev/null @@ -1,72 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;;; CLX trapezoid Extension test program - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - - -(defun zoid-test (host) - ;; Display the part picture in /extensions/test/datafile - (let* ((display (open-display host)) - (width 400) - (height 400) - (screen (display-default-screen display)) - (black (screen-black-pixel screen)) - (white (screen-white-pixel screen)) - (win (create-window - :parent (screen-root screen) - :background black - :border white - :border-width 1 - :colormap (screen-default-colormap screen) - :bit-gravity :center - :event-mask '(:exposure :key-press) - :x 20 :y 20 - :width width :height height)) - (gc (create-gcontext - :drawable win - :background black - :foreground white))) - (initialize-extensions display) - - (map-window win) ; Map the window - ;; Handle events - (unwind-protect - (loop - (event-case (display :force-output-p t) - (exposure ;; Come here on exposure events - (window count) - (when (zerop count) ;; Ignore all but the last exposure event - (clear-area window) - ;; NOT VERY INTERESTING, BUT CHECKS ALL THE POSSIBILITIES - (poly-fill-Trapezoids window gc '(10 20 30 40 100 200)) - (setf (gcontext-trapezoid-alignment gc) :y) - (poly-fill-Trapezoids window gc #(10 20 30 40 100 200)) - (with-gcontext (gc :trapezoid-alignment :x) - (poly-fill-Trapezoids window gc '(40 50 60 70 140 240))) - (setf (gcontext-trapezoid-alignment gc) :x) - (poly-fill-Trapezoids window gc #(40 50 60 70 80 90)) - (with-gcontext (gc :trapezoid-alignment :y) - (poly-fill-Trapezoids window gc #(40 50 60 70 140 240))) - - (draw-glyphs window gc 10 10 "Press any key to exit") - ;; Returning non-nil causes event-case to exit - t)) - (key-press () (return-from zoid-test t)))) - (close-display display)))) diff --git a/src/eclx/text.lisp b/src/eclx/text.lisp deleted file mode 100644 index 25bc4253d..000000000 --- a/src/eclx/text.lisp +++ /dev/null @@ -1,1063 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; CLX text keyboard and pointer requests - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; -#+cmu -(ext:file-comment - "$Header$") - -(in-package :xlib) - -;; Strings are broken up into chunks of this size -(defparameter *max-string-size* 254) - -;; In the functions below, the transform is used to convert an element of the -;; sequence into a font index. The transform is applied to each element of the -;; (sub)sequence, until either the transform returns nil or the end of the -;; (sub)sequence is reached. If transform returns nil for an element, the -;; index of that element in the sequence is returned, otherwise nil is -;; returned. - -(deftype translation-function () - '(function (sequence array-index array-index (or null font) vector array-index) - (values array-index (or null int16 font) (or null int32)))) - -;; In the functions below, if width is specified, it is assumed to be the pixel -;; width of whatever string of glyphs is actually drawn. Specifying width will -;; allow for appending the output of subsequent calls to the same protocol -;; request, provided gcontext has not been modified in the interim. If width -;; is not specified, appending of subsequent output might not occur. -;; Specifying width is simply a hint, for performance. Note that specifying -;; width may be difficult if transform can return nil. - -(defun translate-default (src src-start src-end afont dst dst-start) - ;; dst is guaranteed to have room for (- src-end src-start) integer elements, - ;; starting at dst-start; whether dst holds 8-bit or 16-bit elements depends - ;; on context. font is the current font, if known. The function should - ;; translate as many elements of src as possible into indexes in the current - ;; font, and store them into dst. - ;; - ;; The first return value should be the src index of the first untranslated - ;; element. If no further elements need to be translated, the second return - ;; value should be nil. If a horizontal motion is required before further - ;; translation, the second return value should be the delta in x coordinate. - ;; If a font change is required for further translation, the second return - ;; value should be the new font. If known, the pixel width of the translated - ;; text can be returned as the third value; this can allow for appending of - ;; subsequent output to the same protocol request, if no overall width has - ;; been specified at the higher level. - ;; (returns values: ending-index - ;; (OR null horizontal-motion font) - ;; (OR null translated-width)) - - ;; This is for replacing the clx-translate-default-function - ;; who does'nt know about accentated characters because - ;; of a call to cl:graphic-char-p that return nil with accentated characters. - ;; For further informations, on a clx-translate-function, see the clx-man. - (declare (type sequence src) - (type xlib:array-index src-start src-end dst-start) - (type (or null xlib:font) afont) - (type vector dst)) - (declare (xlib::clx-values integer (or null integer xlib:font) (or null integer))) - - (let ((min-char-index (xlib:font-min-char afont)) - (max-char-index (xlib:font-max-char afont))) - afont - (if (stringp src) - (do ((i src-start (xlib::index+ i 1)) - (j dst-start (xlib::index+ j 1)) - (char)) - ((xlib::index>= i src-end) - i) - (declare (type xlib:array-index i j)) - (setq char (xlib:char->card8 (char src i))) - (if (or (< char min-char-index) (> char max-char-index)) - (return i) - (setf (aref dst j) char))) - (do ((i src-start (xlib::index+ i 1)) - (j dst-start (xlib::index+ j 1)) - (elt)) - ((xlib::index>= i src-end) - i) - (declare (type xlib:array-index i j)) - (setq elt (elt src i)) - (when (characterp elt) (setq elt (xlib:char->card8 elt))) - (if (or (not (integerp elt)) - (< elt min-char-index) - (> elt max-char-index)) - (return i) - (setf (aref dst j) elt)))))) - -;; There is a question below of whether translate should always be required, or -;; if not, what the default should be or where it should come from. For -;; example, the default could be something that expected a string as src and -;; translated the CL standard character set to ASCII indexes, and ignored fonts -;; and bits. Or the default could expect a string but otherwise be "system -;; dependent". Or the default could be something that expected a vector of -;; integers and did no translation. Or the default could come from the -;; gcontext (but what about text-extents and text-width?). - -(defun text-extents (font sequence &key (start 0) end translate) - ;; If multiple fonts are involved, font-ascent and font-descent will be the - ;; maximums. If multiple directions are involved, the direction will be nil. - ;; Translate will always be called with a 16-bit dst buffer. - (declare (type sequence sequence) - (type (or font gcontext) font)) - (declare (type (or null translation-function) translate) - (dynamic-extent translate)) - (declare (clx-values width ascent descent left right - font-ascent font-descent direction - (or null array-index))) - (when (type? font 'gcontext) - (force-gcontext-changes font) - (setq font (gcontext-font font t))) - (check-type font font) - (let* ((left-bearing 0) - (right-bearing 0) - ;; Sum of widths - (width 0) - (ascent 0) - (descent 0) - (overall-ascent (font-ascent font)) - (overall-descent (font-descent font)) - (overall-direction (font-direction font)) - (next-start nil) - (display (font-display font))) - (declare (type int16 ascent descent overall-ascent overall-descent) - (type int32 left-bearing right-bearing width) - (type (or null array-index) next-start) - (type display display)) - (with-display (display) - (do* ((wbuf (display-tbuf16 display)) - (src-end (or end (length sequence))) - (src-start start (index+ src-start buf-end)) - (end (index-min src-end (index+ src-start +buffer-text16-size+)) - (index-min src-end (index+ src-start +buffer-text16-size+))) - (buf-end 0) - (new-font) - (font-ascent 0) - (font-descent 0) - (font-direction) - (stop-p nil)) - ((or stop-p (index>= src-start src-end)) - (when (index< src-start src-end) - (setq next-start src-start))) - (declare (type buffer-text16 wbuf) - (type array-index src-start src-end end buf-end) - (type int16 font-ascent font-descent) - (type generalized-boolean stop-p)) - ;; Translate the text - (multiple-value-setq (buf-end new-font) - (funcall (or translate #'translate-default) - sequence src-start end font wbuf 0)) - (setq buf-end (- buf-end src-start)) - (cond ((null new-font) (setq stop-p t)) - ((integerp new-font) (incf width (the int32 new-font)))) - - (let (w a d l r) - (if (or (font-char-infos-internal font) (font-local-only-p font)) - ;; Calculate text extents locally - (progn - (multiple-value-setq (w a d l r) - (text-extents-local font wbuf 0 buf-end nil)) - (setq font-ascent (the int16 (font-ascent font)) - font-descent (the int16 (font-descent font)) - font-direction (font-direction font))) - ;; Let the server calculate text extents - (multiple-value-setq - (w a d l r font-ascent font-descent font-direction) - (text-extents-server font wbuf 0 buf-end))) - (incf width (the int32 w)) - (cond ((index= src-start start) - (setq left-bearing (the int32 l)) - (setq right-bearing (the int32 r)) - (setq ascent (the int16 a)) - (setq descent (the int16 d))) - (t - (setq left-bearing (the int32 (min left-bearing (the int32 l)))) - (setq right-bearing (the int32 (max right-bearing (the int32 r)))) - (setq ascent (the int16 (max ascent (the int16 a)))) - (setq descent (the int16 (max descent (the int16 d))))))) - - (when (type? new-font 'font) - (setq font new-font)) - - (setq overall-ascent (the int16 (max overall-ascent font-ascent))) - (setq overall-descent (the int16 (max overall-descent font-descent))) - (case overall-direction - (:unknown (setq overall-direction font-direction)) - (:left-to-right (unless (eq font-direction :left-to-right) - (setq overall-direction nil))) - (:right-to-left (unless (eq font-direction :right-to-left) - (setq overall-direction nil)))))) - - (values width - ascent - descent - left-bearing - right-bearing - overall-ascent - overall-descent - overall-direction - next-start))) - -(defun text-width (font sequence &key (start 0) end translate) - ;; Translate will always be called with a 16-bit dst buffer. - (declare (type sequence sequence) - (type (or font gcontext) font) - (type array-index start) - (type (or null array-index) end)) - (declare (type (or null translation-function) translate) - (dynamic-extent translate)) - (declare (clx-values integer (or null integer))) - (when (type? font 'gcontext) - (force-gcontext-changes font) - (setq font (gcontext-font font t))) - (check-type font font) - (let* ((width 0) - (next-start nil) - (display (font-display font))) - (declare (type int32 width) - (type (or null array-index) next-start) - (type display display)) - (with-display (display) - (do* ((wbuf (display-tbuf16 display)) - (src-end (or end (length sequence))) - (src-start start (index+ src-start buf-end)) - (end (index-min src-end (index+ src-start +buffer-text16-size+)) - (index-min src-end (index+ src-start +buffer-text16-size+))) - (buf-end 0) - (new-font) - (stop-p nil)) - ((or stop-p (index>= src-start src-end)) - (when (index< src-start src-end) - (setq next-start src-start))) - (declare (type buffer-text16 wbuf) - (type array-index src-start src-end end buf-end) - (type generalized-boolean stop-p)) - ;; Translate the text - (multiple-value-setq (buf-end new-font) - (funcall (or translate #'translate-default) - sequence src-start end font wbuf 0)) - (setq buf-end (- buf-end src-start)) - (cond ((null new-font) (setq stop-p t)) - ((integerp new-font) (incf width (the int32 new-font)))) - - (incf width - (if (or (font-char-infos-internal font) (font-local-only-p font)) - (text-extents-local font wbuf 0 buf-end :width-only) - (text-width-server font wbuf 0 buf-end))) - (when (type? new-font 'font) - (setq font new-font)))) - (values width next-start))) - -(defun text-extents-server (font string start end) - (declare (type font font) - (type string string) - (type array-index start end)) - (declare (clx-values width ascent descent left right font-ascent font-descent direction)) - (let ((display (font-display font)) - (length (index- end start)) - (font-id (font-id font))) - (declare (type display display) - (type array-index length) - (type resource-id font-id)) - (with-buffer-request-and-reply (display +x-querytextextents+ 28 :sizes (8 16 32)) - (((data boolean) (oddp length)) - (length (index+ (index-ceiling length 2) 2)) - (resource-id font-id) - ((sequence :format char2b :start start :end end :appending t) - string)) - (values - (integer-get 16) - (int16-get 12) - (int16-get 14) - (integer-get 20) - (integer-get 24) - (int16-get 8) - (int16-get 10) - (member8-get 1 :left-to-right :right-to-left))))) - -(defun text-width-server (font string start end) - (declare (type (or font gcontext) font) - (type string string) - (type array-index start end)) - (declare (clx-values integer)) - (let ((display (font-display font)) - (length (index- end start)) - (font-id (font-id font))) - (declare (type display display) - (type array-index length) - (type resource-id font-id)) - (with-buffer-request-and-reply (display +x-querytextextents+ 28 :sizes 32) - (((data boolean) (oddp length)) - (length (index+ (index-ceiling length 2) 2)) - (resource-id font-id) - ((sequence :format char2b :start start :end end :appending t) - string)) - (values (integer-get 16))))) - -(defun text-extents-local (font sequence start end width-only-p) - (declare (type font font) - (type sequence sequence) - (type integer start end) - (type generalized-boolean width-only-p)) - (declare (clx-values width ascent descent overall-left overall-right)) - (let* ((char-infos (font-char-infos font)) - (font-info (font-font-info font))) - (declare (type font-info font-info)) - (declare (type (simple-array int16 (*)) char-infos)) - (if (zerop (length char-infos)) - ;; Fixed width font - (let* ((font-width (max-char-width font)) - (font-ascent (max-char-ascent font)) - (font-descent (max-char-descent font)) - (width (* (index- end start) font-width))) - (declare (type int16 font-width font-ascent font-descent) - (type int32 width)) - (if width-only-p - width - (values width - font-ascent - font-descent - (max-char-left-bearing font) - (+ width (- font-width) (max-char-right-bearing font))))) - - ;; Variable-width font - (let* ((first-col (font-info-min-byte2 font-info)) - (num-cols (1+ (- (font-info-max-byte2 font-info) first-col))) - (first-row (font-info-min-byte1 font-info)) - (last-row (font-info-max-byte1 font-info)) - (num-rows (1+ (- last-row first-row)))) - (declare (type card8 first-col first-row last-row) - (type card16 num-cols num-rows)) - (if (or (plusp first-row) (plusp last-row)) - - ;; Matrix (16 bit) font - (macrolet ((char-info-elt (sequence elt) - `(let* ((char (the card16 (elt ,sequence ,elt))) - (row (- (ash char -8) first-row)) - (col (- (logand char #xff) first-col))) - (declare (type card16 char) - (type int16 row col)) - (if (and (< -1 row num-rows) (< -1 col num-cols)) - (index* 6 (index+ (index* row num-cols) col)) - -1)))) - (if width-only-p - (do ((i start (index1+ i)) - (width 0)) - ((index>= i end) width) - (declare (type array-index i) - (type int32 width)) - (let ((n (char-info-elt sequence i))) - (declare (type fixnum n)) - (unless (minusp n) ;; Ignore characters not in the font - (incf width (the int16 (aref char-infos (index+ 2 n))))))) - ;; extents - (do ((i start (index1+ i)) - (width 0) - (ascent #x-7fff) - (descent #x-7fff) - (left #x7fff) - (right #x-7fff)) - ((index>= i end) - (values width ascent descent left right)) - (declare (type array-index i) - (type int16 ascent descent) - (type int32 width left right)) - (let ((n (char-info-elt sequence i))) - (declare (type fixnum n)) - (unless (minusp n) ;; Ignore characters not in the font - (setq left (min left (+ width (aref char-infos n)))) - (setq right (max right (+ width (aref char-infos (index1+ n))))) - (incf width (aref char-infos (index+ 2 n))) - (setq ascent (max ascent (aref char-infos (index+ 3 n)))) - (setq descent (max descent (aref char-infos (index+ 4 n))))))))) - - ;; Non-matrix (8 bit) font - ;; The code here is identical to the above, except for the following macro: - (macrolet ((char-info-elt (sequence elt) - `(let ((col (- (the card16 (elt ,sequence ,elt)) first-col))) - (declare (type int16 col)) - (if (< -1 col num-cols) - (index* 6 col) - -1)))) - (if width-only-p - (do ((i start (index1+ i)) - (width 0)) - ((index>= i end) width) - (declare (type array-index i) - (type int32 width)) - (let ((n (char-info-elt sequence i))) - (declare (type fixnum n)) - (unless (minusp n) ;; Ignore characters not in the font - (incf width (the int16 (aref char-infos (index+ 2 n))))))) - ;; extents - (do ((i start (index1+ i)) - (width 0) - (ascent #x-7fff) - (descent #x-7fff) - (left #x7fff) - (right #x-7fff)) - ((index>= i end) - (values width ascent descent left right)) - (declare (type array-index i) - (type int16 ascent descent) - (type int32 width left right)) - (let ((n (char-info-elt sequence i))) - (declare (type fixnum n)) - (unless (minusp n) ;; Ignore characters not in the font - (setq left (min left (+ width (aref char-infos n)))) - (setq right (max right (+ width (aref char-infos (index1+ n))))) - (incf width (aref char-infos (index+ 2 n))) - (setq ascent (max ascent (aref char-infos (index+ 3 n)))) - (setq descent (max descent (aref char-infos (index+ 4 n))))) - )))) - ))))) - -;;----------------------------------------------------------------------------- - -;; This controls the element size of the dst buffer given to translate. If -;; :default is specified, the size will be based on the current font, if known, -;; and otherwise 16 will be used. [An alternative would be to pass the buffer -;; size to translate, and allow it to return the desired size if it doesn't -;; like the current size. The problem is that the protocol doesn't allow -;; switching within a single request, so to allow switching would require -;; knowing the width of text, which isn't necessarily known. We could call -;; text-width to compute it, but perhaps that is doing too many favors?] [An -;; additional possibility is to allow an index-size of :two-byte, in which case -;; translate would be given a double-length 8-bit array, and translate would be -;; expected to store first-byte/second-byte instead of 16-bit integers.] - -(deftype index-size () '(member :default 8 16)) - -;; In the functions below, if width is specified, it is assumed to be the total -;; pixel width of whatever string of glyphs is actually drawn. Specifying -;; width will allow for appending the output of subsequent calls to the same -;; protocol request, provided gcontext has not been modified in the interim. -;; If width is not specified, appending of subsequent output might not occur -;; (unless translate returns the width). Specifying width is simply a hint, -;; for performance. - -(defun draw-glyph (drawable gcontext x y elt - &key translate width (size :default)) - ;; Returns true if elt is output, nil if translate refuses to output it. - ;; Second result is width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type (or null int32) width) - (type index-size size)) - (declare (type (or null translation-function) translate) - (dynamic-extent translate)) - (declare (clx-values generalized-boolean (or null int32))) - (let* ((display (gcontext-display gcontext)) - (result t) - (opcode +x-polytext8+)) - (declare (type display display)) - (let ((vector (allocate-gcontext-state))) - (declare (type gcontext-state vector)) - (setf (aref vector 0) elt) - (multiple-value-bind (new-start new-font translate-width) - (funcall (or translate #'translate-default) - vector 0 1 (gcontext-font gcontext t) vector 1) - ;; Allow translate to set a new font - (when (type? new-font 'font) - (setf (gcontext-font gcontext) new-font) - (multiple-value-setq (new-start new-font translate-width) - (funcall translate vector 0 1 new-font vector 1))) - ;; If new-start is zero, translate refuses to output it - (setq result (index-plusp new-start) - elt (aref vector 1)) - (deallocate-gcontext-state vector) - (when translate-width (setq width translate-width)))) - (when result - (when (eql size 16) - (setq opcode +x-polytext16+) - (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt)))) - (with-buffer-request (display opcode :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (card8 1 0) - (card8 (ldb (byte 8 0) elt)) - (card8 (ldb (byte 8 8) elt))) - (values t width)))) - -(defun draw-glyphs (drawable gcontext x y sequence - &key (start 0) end translate width (size :default)) - ;; First result is new start, if end was not reached. Second result is - ;; overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width) - (type index-size size)) - (declare (type (or null translation-function) translate) - (dynamic-extent translate)) - (declare (clx-values (or null array-index) (or null int32))) - (unless end (setq end (length sequence))) - (ecase size - ((:default 8) (draw-glyphs8 drawable gcontext x y sequence start end - (or translate #'translate-default) width)) - (16 (draw-glyphs16 drawable gcontext x y sequence start end - (or translate #'translate-default) width)))) - -(defun draw-glyphs8 (drawable gcontext x y sequence start end translate width) - ;; First result is new start, if end was not reached. Second result is - ;; overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width)) - (declare (clx-values (or null array-index) (or null int32))) - (declare (type translation-function translate) - (dynamic-extent translate)) - (let* ((src-start start) - (src-end (or end (length sequence))) - (next-start nil) - (length (index- src-end src-start)) - (request-length (* length 2)) ; Leave lots of room for font shifts. - (display (gcontext-display gcontext)) - ;; Should metrics-p be T? Don't want to pass a NIL font into translate... - (font (gcontext-font gcontext t))) - (declare (type array-index src-start src-end length) - (type (or null array-index) next-start) - (type display display)) - (with-buffer-request (display +x-polytext8+ :gc-force gcontext :length request-length) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (progn - ;; Don't let any flushes happen since we manually set the request - ;; length when we're done. - (with-buffer-flush-inhibited (display) - (do* ((boffset (index+ buffer-boffset 16)) - (src-chunk 0) - (dst-chunk 0) - (offset 0) - (overall-width 0) - (stop-p nil)) - ((or stop-p (zerop length)) - ;; Ensure terminated with zero bytes - (do ((end (the array-index (lround boffset)))) - ((index>= boffset end)) - (setf (aref buffer-bbuf boffset) 0) - (index-incf boffset)) - (length-put 2 (index-ash (index- boffset buffer-boffset) -2)) - (setf (buffer-boffset display) boffset) - (unless (index-zerop length) (setq next-start src-start)) - (when overall-width (setq width overall-width))) - - (declare (type array-index src-chunk dst-chunk offset) - (type (or null int32) overall-width) - (type generalized-boolean stop-p)) - (setq src-chunk (index-min length *max-string-size*)) - (multiple-value-bind (new-start new-font translated-width) - (funcall translate - sequence src-start (index+ src-start src-chunk) - font buffer-bbuf (index+ boffset 2)) - (setq dst-chunk (index- new-start src-start) - length (index- length dst-chunk) - src-start new-start) - (if translated-width - (when overall-width (incf overall-width translated-width)) - (setq overall-width nil)) - (when (index-plusp dst-chunk) - (setf (aref buffer-bbuf boffset) dst-chunk) - (setf (aref buffer-bbuf (index+ boffset 1)) offset) - (incf boffset (index+ dst-chunk 2))) - (setq offset 0) - (cond ((null new-font) - ;; Don't stop if translate copied whole chunk - (unless (index= src-chunk dst-chunk) - (setq stop-p t))) - ((integerp new-font) (setq offset new-font)) - ((type? new-font 'font) - (setq font new-font) - (let ((font-id (font-id font)) - (buffer-boffset boffset)) - (declare (type resource-id font-id) - (type array-index buffer-boffset)) - ;; This changes the gcontext font in the server - ;; Update the gcontext cache (both local and server state) - (let ((local-state (gcontext-local-state gcontext)) - (server-state (gcontext-server-state gcontext))) - (declare (type gcontext-state local-state server-state)) - (setf (gcontext-internal-font-obj server-state) font - (gcontext-internal-font server-state) font-id) - (without-interrupts - (setf (gcontext-internal-font-obj local-state) font - (gcontext-internal-font local-state) font-id))) - (card8-put 0 #xff) - (card8-put 1 (ldb (byte 8 24) font-id)) - (card8-put 2 (ldb (byte 8 16) font-id)) - (card8-put 3 (ldb (byte 8 8) font-id)) - (card8-put 4 (ldb (byte 8 0) font-id))) - (index-incf boffset 5))) - ))))) - (values next-start width))) - -;; NOTE: After the first font change by the TRANSLATE function, characters are no-longer -;; on 16bit boundaries and this function garbles the bytes. -(defun draw-glyphs16 (drawable gcontext x y sequence start end translate width) - ;; First result is new start, if end was not reached. Second result is - ;; overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width)) - (declare (clx-values (or null array-index) (or null int32))) - (declare (type translation-function translate) - (dynamic-extent translate)) - (let* ((src-start start) - (src-end (or end (length sequence))) - (next-start nil) - (length (index- src-end src-start)) - (request-length (* length 3)) ; Leave lots of room for font shifts. - (display (gcontext-display gcontext)) - ;; Should metrics-p be T? Don't want to pass a NIL font into translate... - (font (gcontext-font gcontext t)) - (buffer (display-tbuf16 display))) - (declare (type array-index src-start src-end length) - (type (or null array-index) next-start) - (type display display) - (type buffer-text16 buffer)) - (with-buffer-request (display +x-polytext16+ :gc-force gcontext :length request-length) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (progn - ;; Don't let any flushes happen since we manually set the request - ;; length when we're done. - (with-buffer-flush-inhibited (display) - (do* ((boffset (index+ buffer-boffset 16)) - (src-chunk 0) - (dst-chunk 0) - (offset 0) - (overall-width 0) - (stop-p nil)) - ((or stop-p (zerop length)) - ;; Ensure terminated with zero bytes - (do ((end (lround boffset))) - ((index>= boffset end)) - (setf (aref buffer-bbuf boffset) 0) - (index-incf boffset)) - (length-put 2 (index-ash (index- boffset buffer-boffset) -2)) - (setf (buffer-boffset display) boffset) - (unless (zerop length) (setq next-start src-start)) - (when overall-width (setq width overall-width))) - - (declare (type array-index boffset src-chunk dst-chunk offset) - (type (or null int32) overall-width) - (type generalized-boolean stop-p)) - (setq src-chunk (index-min length *max-string-size*)) - (multiple-value-bind (new-start new-font translated-width) - (funcall translate - sequence src-start (index+ src-start src-chunk) - font buffer 0) - (setq dst-chunk (index- new-start src-start) - length (index- length dst-chunk) - src-start new-start) - (write-sequence-char2b display (index+ boffset 2) buffer 0 dst-chunk) - (if translated-width - (when overall-width (incf overall-width translated-width)) - (setq overall-width nil)) - (when (index-plusp dst-chunk) - (setf (aref buffer-bbuf boffset) dst-chunk) - (setf (aref buffer-bbuf (index+ boffset 1)) offset) - (index-incf boffset (index+ dst-chunk dst-chunk 2))) - (setq offset 0) - (cond ((null new-font) - ;; Don't stop if translate copied whole chunk - (unless (index= src-chunk dst-chunk) - (setq stop-p t))) - ((integerp new-font) (setq offset new-font)) - ((type? new-font 'font) - (setq font new-font) - (let ((font-id (font-id font)) - (buffer-boffset boffset)) - (declare (type resource-id font-id) - (type array-index buffer-boffset)) - ;; This changes the gcontext font in the SERVER - ;; Update the gcontext cache (both local and server state) - (let ((local-state (gcontext-local-state gcontext)) - (server-state (gcontext-server-state gcontext))) - (declare (type gcontext-state local-state server-state)) - (setf (gcontext-internal-font-obj server-state) font - (gcontext-internal-font server-state) font-id) - (without-interrupts - (setf (gcontext-internal-font-obj local-state) font - (gcontext-internal-font local-state) font-id))) - (card8-put 0 #xff) - (card8-put 1 (ldb (byte 8 24) font-id)) - (card8-put 2 (ldb (byte 8 16) font-id)) - (card8-put 3 (ldb (byte 8 8) font-id)) - (card8-put 4 (ldb (byte 8 0) font-id))) - (index-incf boffset 5))) - ))))) - (values next-start width))) - -(defun draw-image-glyph (drawable gcontext x y elt - &key translate width (size :default)) - ;; Returns true if elt is output, nil if translate refuses to output it. - ;; Second result is overall width, if known. An initial font change is - ;; allowed from translate. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type (or null int32) width) - (type index-size size)) - (declare (type (or null translation-function) translate) - (dynamic-extent translate)) - (declare (clx-values generalized-boolean (or null int32))) - (let* ((display (gcontext-display gcontext)) - (result t) - (opcode +x-imagetext8+)) - (declare (type display display)) - (let ((vector (allocate-gcontext-state))) - (declare (type gcontext-state vector)) - (setf (aref vector 0) elt) - (multiple-value-bind (new-start new-font translate-width) - (funcall (or translate #'translate-default) - vector 0 1 (gcontext-font gcontext t) vector 1) - ;; Allow translate to set a new font - (when (type? new-font 'font) - (setf (gcontext-font gcontext) new-font) - (multiple-value-setq (new-start new-font translate-width) - (funcall translate vector 0 1 new-font vector 1))) - ;; If new-start is zero, translate refuses to output it - (setq result (index-plusp new-start) - elt (aref vector 1)) - (deallocate-gcontext-state vector) - (when translate-width (setq width translate-width)))) - (when result - (when (eql size 16) - (setq opcode +x-imagetext16+) - (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt)))) - (with-buffer-request (display opcode :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - (data 1) ;; 1 character - (int16 x y) - (card8 (ldb (byte 8 0) elt)) - (card8 (ldb (byte 8 8) elt))) - (values t width)))) - -(defun draw-image-glyphs (drawable gcontext x y sequence - &key (start 0) end translate width (size :default)) - ;; An initial font change is allowed from translate, but any subsequent font - ;; change or horizontal motion will cause termination (because the protocol - ;; doesn't support chaining). [Alternatively, font changes could be accepted - ;; as long as they are accompanied with a width return value, or always - ;; accept font changes and call text-width as required. However, horizontal - ;; motion can't really be accepted, due to semantics.] First result is new - ;; start, if end was not reached. Second result is overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type (or null array-index) end) - (type sequence sequence) - (type (or null int32) width) - (type index-size size)) - (declare (type (or null translation-function) translate) - (dynamic-extent translate)) - (declare (clx-values (or null array-index) (or null int32))) - (setf end (index-min (index+ start 255) (or end (length sequence)))) - (ecase size - ((:default 8) - (draw-image-glyphs8 drawable gcontext x y sequence start end translate width)) - (16 - (draw-image-glyphs16 drawable gcontext x y sequence start end translate width)))) - -(defun draw-image-glyphs8 (drawable gcontext x y sequence start end translate width) - ;; An initial font change is allowed from translate, but any subsequent font - ;; change or horizontal motion will cause termination (because the protocol - ;; doesn't support chaining). [Alternatively, font changes could be accepted - ;; as long as they are accompanied with a width return value, or always - ;; accept font changes and call text-width as required. However, horizontal - ;; motion can't really be accepted, due to semantics.] First result is new - ;; start, if end was not reached. Second result is overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width)) - (declare (type (or null translation-function) translate) - (dynamic-extent translate)) - (declare (clx-values (or null array-index) (or null int32))) - (do* ((display (gcontext-display gcontext)) - (length (index- end start)) - ;; Should metrics-p be T? Don't want to pass a NIL font into translate... - (font (gcontext-font gcontext t)) - (font-change nil) - (new-start) (translated-width) (chunk)) - (nil) ;; forever - (declare (type display display) - (type array-index length) - (type (or null array-index) new-start chunk)) - - (when font-change - (setf (gcontext-font gcontext) font)) - (block change-font - (with-buffer-request (display +x-imagetext8+ :gc-force gcontext :length length) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (progn - ;; Don't let any flushes happen since we manually set the request - ;; length when we're done. - (with-buffer-flush-inhibited (display) - ;; Translate the sequence into the buffer - (multiple-value-setq (new-start font translated-width) - (funcall (or translate #'translate-default) sequence start end - font buffer-bbuf (index+ buffer-boffset 16))) - ;; Number of glyphs translated - (setq chunk (index- new-start start)) - ;; Check for initial font change - (when (and (index-zerop chunk) (type? font 'font)) - (setq font-change t) ;; Loop around changing font - (return-from change-font)) - ;; Quit when nothing translated - (when (index-zerop chunk) - (return-from draw-image-glyphs8 new-start)) - ;; Update buffer pointers - (data-put 1 chunk) - (let ((blen (lround (index+ 16 chunk)))) - (length-put 2 (index-ash blen -2)) - (setf (buffer-boffset display) (index+ buffer-boffset blen)))))) - ;; Normal exit - (return-from draw-image-glyphs8 - (values (if (index= chunk length) nil new-start) - (or translated-width width)))))) - -(defun draw-image-glyphs16 (drawable gcontext x y sequence start end translate width) - ;; An initial font change is allowed from translate, but any subsequent font - ;; change or horizontal motion will cause termination (because the protocol - ;; doesn't support chaining). [Alternatively, font changes could be accepted - ;; as long as they are accompanied with a width return value, or always - ;; accept font changes and call text-width as required. However, horizontal - ;; motion can't really be accepted, due to semantics.] First result is new - ;; start, if end was not reached. Second result is overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width)) - (declare (type (or null translation-function) translate) - (dynamic-extent translate)) - (declare (clx-values (or null array-index) (or null int32))) - (do* ((display (gcontext-display gcontext)) - (length (index- end start)) - ;; Should metrics-p be T? Don't want to pass a NIL font into translate... - (font (gcontext-font gcontext t)) - (font-change nil) - (new-start) (translated-width) (chunk) - (buffer (buffer-tbuf16 display))) - (nil) ;; forever - - (declare (type display display) - (type array-index length) - (type (or null array-index) new-start chunk) - (type buffer-text16 buffer)) - (when font-change - (setf (gcontext-font gcontext) font)) - - (block change-font - (with-buffer-request (display +x-imagetext16+ :gc-force gcontext :length length) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (progn - ;; Don't let any flushes happen since we manually set the request - ;; length when we're done. - (with-buffer-flush-inhibited (display) - ;; Translate the sequence into the buffer - (multiple-value-setq (new-start font translated-width) - (funcall (or translate #'translate-default) sequence start end - font buffer 0)) - ;; Number of glyphs translated - (setq chunk (index- new-start start)) - ;; Check for initial font change - (when (and (index-zerop chunk) (type? font 'font)) - (setq font-change t) ;; Loop around changing font - (return-from change-font)) - ;; Quit when nothing translated - (when (index-zerop chunk) - (return-from draw-image-glyphs16 new-start)) - (write-sequence-char2b display (index+ buffer-boffset 16) buffer 0 chunk) - ;; Update buffer pointers - (data-put 1 chunk) - (let ((blen (lround (index+ 16 (index-ash chunk 1))))) - (length-put 2 (index-ash blen -2)) - (setf (buffer-boffset display) (index+ buffer-boffset blen)))))) - ;; Normal exit - (return-from draw-image-glyphs16 - (values (if (index= chunk length) nil new-start) - (or translated-width width)))))) - - -;;----------------------------------------------------------------------------- - -(defun display-keycode-range (display) - (declare (type display display)) - (declare (clx-values min max)) - (values (display-min-keycode display) - (display-max-keycode display))) - -;; Should this signal device-busy like the pointer-mapping setf, and return a -;; generalized-boolean instead (true for success)? Alternatively, should the -;; pointer-mapping setf be changed to set-pointer-mapping with a (member -;; :success :busy) result? - -(defun set-modifier-mapping (display &key shift lock control mod1 mod2 mod3 mod4 mod5) - ;; Setf ought to allow multiple values. - (declare (type display display) - (type sequence shift lock control mod1 mod2 mod3 mod4 mod5)) - (declare (clx-values (member :success :busy :failed))) - (let* ((keycodes-per-modifier (index-max (length shift) - (length lock) - (length control) - (length mod1) - (length mod2) - (length mod3) - (length mod4) - (length mod5))) - (data (make-array (index* 8 keycodes-per-modifier) - :element-type 'card8 - :initial-element 0))) - (replace data shift) - (replace data lock :start1 keycodes-per-modifier) - (replace data control :start1 (index* 2 keycodes-per-modifier)) - (replace data mod1 :start1 (index* 3 keycodes-per-modifier)) - (replace data mod2 :start1 (index* 4 keycodes-per-modifier)) - (replace data mod3 :start1 (index* 5 keycodes-per-modifier)) - (replace data mod4 :start1 (index* 6 keycodes-per-modifier)) - (replace data mod5 :start1 (index* 7 keycodes-per-modifier)) - (with-buffer-request-and-reply (display +x-setmodifiermapping+ 4 :sizes 8) - ((data keycodes-per-modifier) - ((sequence :format card8) data)) - (values (member8-get 1 :success :busy :failed))))) - -(defun modifier-mapping (display) - ;; each value is a list of integers - (declare (type display display)) - (declare (clx-values shift lock control mod1 mod2 mod3 mod4 mod5)) - (let ((lists nil)) - (with-buffer-request-and-reply (display +x-getmodifiermapping+ nil :sizes 8) - () - (do* ((keycodes-per-modifier (card8-get 1)) - (advance-by +replysize+ keycodes-per-modifier) - (keys nil nil) - (i 0 (index+ i 1))) - ((index= i 8)) - (advance-buffer-offset advance-by) - (dotimes (j keycodes-per-modifier) - (let ((key (read-card8 j))) - (unless (zerop key) - (push key keys)))) - (push (nreverse keys) lists))) - (values-list (nreverse lists)))) - -;; Either we will want lots of defconstants for well-known values, or perhaps -;; an integer-to-keyword translation function for well-known values. - -(defun change-keyboard-mapping - (display keysyms &key (start 0) end (first-keycode start)) - ;; start/end give subrange of keysyms - ;; first-keycode is the first-keycode to store at - (declare (type display display) - (type array-index start) - (type card8 first-keycode) - (type (or null array-index) end) - (type (array * (* *)) keysyms)) - (let* ((keycode-end (or end (array-dimension keysyms 0))) - (keysyms-per-keycode (array-dimension keysyms 1)) - (length (index- keycode-end start)) - (size (index* length keysyms-per-keycode)) - (request-length (index+ size 2))) - (declare (type array-index keycode-end keysyms-per-keycode length request-length)) - (with-buffer-request (display +x-setkeyboardmapping+ - :length (index-ash request-length 2) - :sizes (32)) - (data length) - (length request-length) - (card8 first-keycode keysyms-per-keycode) - (progn - (do ((limit (index-ash (buffer-size display) -2)) - (w (index+ 2 (index-ash buffer-boffset -2))) - (i start (index+ i 1))) - ((index>= i keycode-end) - (setf (buffer-boffset display) (index-ash w 2))) - (declare (type array-index limit w i)) - (when (index> w limit) - (buffer-flush display) - (setq w (index-ash (buffer-boffset display) -2))) - (do ((j 0 (index+ j 1))) - ((index>= j keysyms-per-keycode)) - (declare (type array-index j)) - (card29-put (index* w 4) (aref keysyms i j)) - (index-incf w))))))) - -(defun keyboard-mapping (display &key first-keycode start end data) - ;; First-keycode specifies which keycode to start at (defaults to min-keycode). - ;; Start specifies where (in result) to put first-keycode. (defaults to first-keycode) - ;; (- end start) is the number of keycodes to get. (End defaults to (1+ max-keycode)). - ;; If DATA is specified, the results are put there. - (declare (type display display) - (type (or null card8) first-keycode) - (type (or null array-index) start end) - (type (or null (array * (* *))) data)) - (declare (clx-values (array * (* *)))) - (unless first-keycode (setq first-keycode (display-min-keycode display))) - (unless start (setq start first-keycode)) - (unless end (setq end (1+ (display-max-keycode display)))) - (with-buffer-request-and-reply (display +x-getkeyboardmapping+ nil :sizes (8 32)) - ((card8 first-keycode (index- end start))) - (do* ((keysyms-per-keycode (card8-get 1)) - (bytes-per-keycode (* keysyms-per-keycode 4)) - (advance-by +replysize+ bytes-per-keycode) - (keycode-count (floor (card32-get 4) keysyms-per-keycode) - (index- keycode-count 1)) - (result (if (and (arrayp data) - (= (array-rank data) 2) - (>= (array-dimension data 0) (index+ start keycode-count)) - (>= (array-dimension data 1) keysyms-per-keycode)) - data - (make-array `(,(index+ start keycode-count) ,keysyms-per-keycode) - :element-type 'keysym :initial-element 0))) - (i start (1+ i))) - ((zerop keycode-count) (setq data result)) - (advance-buffer-offset advance-by) - (dotimes (j keysyms-per-keycode) - (setf (aref result i j) (card29-get (* j 4)))))) - data) diff --git a/src/eclx/translate.lisp b/src/eclx/translate.lisp deleted file mode 100644 index c542322ae..000000000 --- a/src/eclx/translate.lisp +++ /dev/null @@ -1,559 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES -*- - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(defvar *keysym-sets* nil) ;; Alist of (name first-keysym last-keysym) - -(defun define-keysym-set (set first-keysym last-keysym) - ;; Define all keysyms from first-keysym up to and including - ;; last-keysym to be in SET (returned from the keysym-set function). - ;; Signals an error if the keysym range overlaps an existing set. - (declare (type keyword set) - (type keysym first-keysym last-keysym)) - (when (> first-keysym last-keysym) - (rotatef first-keysym last-keysym)) - (setq *keysym-sets* (delete set *keysym-sets* :key #'car)) - (dolist (set *keysym-sets*) - (let ((first (second set)) - (last (third set))) - (when (or (<= first first-keysym last) - (<= first last-keysym last)) - (error "Keysym range overlaps existing set ~s" set)))) - (push (list set first-keysym last-keysym) *keysym-sets*) - set) - -(defun keysym-set (keysym) - ;; Return the character code set name of keysym - (declare (type keysym keysym) - (clx-values keyword)) - (dolist (set *keysym-sets*) - (let ((first (second set)) - (last (third set))) - (when (<= first keysym last) - (return (first set)))))) - -(eval-when (:compile-toplevel :execute :load-toplevel) ;; Required for Vaxlisp ... -(defmacro keysym (keysym &rest bytes) - ;; Build a keysym. - ;; If KEYSYM is an integer, it is used as the most significant bits of - ;; the keysym, and BYTES are used to specify low order bytes. The last - ;; parameter is always byte4 of the keysym. If KEYSYM is not an - ;; integer, the keysym associated with KEYSYM is returned. - ;; - ;; This is a macro and not a function macro to promote compile-time - ;; lookup. All arguments are evaluated. - (declare (type t keysym) - (type list bytes) - (clx-values keysym)) - (typecase keysym - ((integer 0 *) - (dolist (b bytes keysym) (setq keysym (+ (ash keysym 8) b)))) - (otherwise - (or (car (character->keysyms keysym)) - (error "~s Isn't the name of a keysym" keysym))))) -) - -(defvar *keysym->character-map* - (make-hash-table :test (keysym->character-map-test) :size 400)) - -;; Keysym-mappings are a list of the form (object translate lowercase modifiers mask) -;; With the following accessor macros. Everything after OBJECT is optional. - -(defmacro keysym-mapping-object (keysym-mapping) - ;; Parameter to translate - `(first ,keysym-mapping)) - -(defmacro keysym-mapping-translate (keysym-mapping) - ;; Function to be called with parameters (display state OBJECT) - ;; when translating KEYSYM and modifiers and mask are satisfied. - `(second ,keysym-mapping)) - -(defmacro keysym-mapping-lowercase (keysym-mapping) - ;; LOWERCASE is used for uppercase alphabetic keysyms. The value - ;; is the associated lowercase keysym. - `(third ,keysym-mapping)) - -(defmacro keysym-mapping-modifiers (keysym-mapping) - ;; MODIFIERS is either a modifier-mask or list containing intermixed - ;; keysyms and state-mask-keys specifying when to use this - ;; keysym-translation. - `(fourth ,keysym-mapping)) - -(defmacro keysym-mapping-mask (keysym-mapping) - ;; MASK is either a modifier-mask or list containing intermixed - ;; keysyms and state-mask-keys specifying which modifiers to look at - ;; (i.e. modifiers not specified are don't-cares) - `(fifth ,keysym-mapping)) - -(defvar *default-keysym-translate-mask* - (the (or (member :modifiers) mask16 (clx-list (or keysym state-mask-key))) - (logand #xff (lognot (make-state-mask :lock)))) - "Default keysym state mask to use during keysym-translation.") - -(defun define-keysym (object keysym &key lowercase translate modifiers mask display) - ;; Define the translation from keysym/modifiers to a (usually - ;; character) object. ANy previous keysym definition with - ;; KEYSYM and MODIFIERS is deleted before adding the new definition. - ;; - ;; MODIFIERS is either a modifier-mask or list containing intermixed - ;; keysyms and state-mask-keys specifying when to use this - ;; keysym-translation. The default is NIL. - ;; - ;; MASK is either a modifier-mask or list containing intermixed - ;; keysyms and state-mask-keys specifying which modifiers to look at - ;; (i.e. modifiers not specified are don't-cares). - ;; If mask is :MODIFIERS then the mask is the same as the modifiers - ;; (i.e. modifiers not specified by modifiers are don't cares) - ;; The default mask is *default-keysym-translate-mask* - ;; - ;; If DISPLAY is specified, the translation will be local to DISPLAY, - ;; otherwise it will be the default translation for all displays. - ;; - ;; LOWERCASE is used for uppercase alphabetic keysyms. The value - ;; is the associated lowercase keysym. This information is used - ;; by the keysym-both-case-p predicate (for caps-lock computations) - ;; and by the keysym-downcase function. - ;; - ;; TRANSLATE will be called with parameters (display state OBJECT) - ;; when translating KEYSYM and modifiers and mask are satisfied. - ;; [e.g (zerop (logxor (logand state (or mask *default-keysym-translate-mask*)) - ;; (or modifiers 0))) - ;; when mask and modifiers aren't lists of keysyms] - ;; The default is #'default-keysym-translate - ;; - (declare (type (or base-char t) object) - (type keysym keysym) - (type (or null mask16 (clx-list (or keysym state-mask-key))) - modifiers) - (type (or null (member :modifiers) mask16 (clx-list (or keysym state-mask-key))) - mask) - (type (or null display) display) - (type (or null keysym) lowercase) - (type (or null (function (display card16 t) t)) translate)) - (flet ((merge-keysym-mappings (new old) - ;; Merge new keysym-mapping with list of old mappings. - ;; Ensure that the mapping with no modifiers or mask comes first. - (let* ((key (keysym-mapping-modifiers new)) - (merge (delete key old :key #'cadddr :test #'equal))) - (if key - (nconc merge (list new)) - (cons new merge)))) - (mask-check (mask) - (unless (or (numberp mask) - (dolist (element mask t) - (unless (or (find element *state-mask-vector*) - (gethash element *keysym->character-map*)) - (return nil)))) - (x-type-error mask '(or mask16 (clx-list (or modifier-key modifier-keysym))))))) - (let ((entry - ;; Create with a single LIST call, to ensure cdr-coding - (cond - (mask - (unless (eq mask :modifiers) - (mask-check mask)) - (when (or (null modifiers) (and (numberp modifiers) (zerop modifiers))) - (error "Mask with no modifiers")) - (list object translate lowercase modifiers mask)) - (modifiers (mask-check modifiers) - (list object translate lowercase modifiers)) - (lowercase (list object translate lowercase)) - (translate (list object translate)) - (t (list object))))) - (if display - (let ((previous (assoc keysym (display-keysym-translation display)))) - (if previous - (setf (cdr previous) (merge-keysym-mappings entry (cdr previous))) - (push (list keysym entry) (display-keysym-translation display)))) - (setf (gethash keysym *keysym->character-map*) - (merge-keysym-mappings entry (gethash keysym *keysym->character-map*))))) - object)) - -(defun undefine-keysym (object keysym &key display modifiers &allow-other-keys) - ;; Undefine the keysym-translation translating KEYSYM to OBJECT with MODIFIERS. - ;; If DISPLAY is non-nil, undefine the translation for DISPLAY if it exists. - (declare (type (or base-char t) object) - (type keysym keysym) - (type (or null mask16 (clx-list (or keysym state-mask-key))) - modifiers) - (type (or null display) display)) - (flet ((match (key entry) - (let ((object (car key)) - (modifiers (cdr key))) - (or (eql object (keysym-mapping-object entry)) - (equal modifiers (keysym-mapping-modifiers entry)))))) - (let* (entry - (previous (if display - (cdr (setq entry (assoc keysym (display-keysym-translation display)))) - (gethash keysym *keysym->character-map*))) - (key (cons object modifiers))) - (when (and previous (find key previous :test #'match)) - (setq previous (delete key previous :test #'match)) - (if display - (setf (cdr entry) previous) - (setf (gethash keysym *keysym->character-map*) previous)))))) - -(defun keysym-downcase (keysym) - ;; If keysym has a lower-case equivalent, return it, otherwise return keysym. - (declare (type keysym keysym)) - (declare (clx-values keysym)) - (let ((translations (gethash keysym *keysym->character-map*))) - (or (and translations (keysym-mapping-lowercase (first translations))) keysym))) - -(defun keysym-uppercase-alphabetic-p (keysym) - ;; Returns T if keysym is uppercase-alphabetic. - ;; I.E. If it has a lowercase equivalent. - (declare (type keysym keysym)) - (declare (clx-values (or null keysym))) - (let ((translations (gethash keysym *keysym->character-map*))) - (and translations - (keysym-mapping-lowercase (first translations))))) - -(defun character->keysyms (character &optional display) - ;; Given a character, return a list of all matching keysyms. - ;; If DISPLAY is given, translations specific to DISPLAY are used, - ;; otherwise only global translations are used. - ;; Implementation dependent function. - ;; May be slow [i.e. do a linear search over all known keysyms] - (declare (type t character) - (type (or null display) display) - (clx-values (clx-list keysym))) - (let ((result nil)) - (when display - (dolist (mapping (display-keysym-translation display)) - (when (eql character (second mapping)) - (push (first mapping) result)))) - (maphash #'(lambda (keysym mappings) - (dolist (mapping mappings) - (when (eql (keysym-mapping-object mapping) character) - (pushnew keysym result)))) - *keysym->character-map*) - result)) - -(eval-when (:compile-toplevel :execute :load-toplevel) ;; Required for Symbolics... -(defparameter character-set-switch-keysym (keysym 255 126)) -(defparameter left-shift-keysym (keysym 255 225)) -(defparameter right-shift-keysym (keysym 255 226)) -(defparameter left-control-keysym (keysym 255 227)) -(defparameter right-control-keysym (keysym 255 228)) -(defparameter caps-lock-keysym (keysym 255 229)) -(defparameter shift-lock-keysym (keysym 255 230)) -(defparameter left-meta-keysym (keysym 255 231)) -(defparameter right-meta-keysym (keysym 255 232)) -(defparameter left-alt-keysym (keysym 255 233)) -(defparameter right-alt-keysym (keysym 255 234)) -(defparameter left-super-keysym (keysym 255 235)) -(defparameter right-super-keysym (keysym 255 236)) -(defparameter left-hyper-keysym (keysym 255 237)) -(defparameter right-hyper-keysym (keysym 255 238)) -) ;; end eval-when - - -;;----------------------------------------------------------------------------- -;; Keysym mapping functions - -(defun display-keyboard-mapping (display) - (declare (type display display)) - (declare (clx-values (simple-array keysym (display-max-keycode keysyms-per-keycode)))) - (or (display-keysym-mapping display) - (setf (display-keysym-mapping display) (keyboard-mapping display)))) - -(defun keycode->keysym (display keycode keysym-index) - (declare (type display display) - (type card8 keycode) - (type card8 keysym-index) - (clx-values keysym)) - (let* ((mapping (display-keyboard-mapping display)) - (keysym (aref mapping keycode keysym-index))) - (declare (type (simple-array keysym (* *)) mapping) - (type keysym keysym)) - ;; The keysym-mapping is brain dammaged. - ;; Mappings for both-case alphabetic characters have the - ;; entry for keysym-index zero set to the uppercase keysym - ;; (this is normally where the lowercase keysym goes), and the - ;; entry for keysym-index one is zero. - (cond ((zerop keysym-index) ; Lowercase alphabetic keysyms - (keysym-downcase keysym)) - ((and (zerop keysym) (plusp keysym-index)) ; Get the uppercase keysym - (aref mapping keycode 0)) - (t keysym)))) - -(defun keysym->character (display keysym &optional (state 0)) - ;; Find the character associated with a keysym. - ;; STATE can be used to set character attributes. - ;; Implementation dependent function. - (declare (type display display) - (type keysym keysym) - (type card16 state)) - (declare (clx-values (or null character))) - (let* ((display-mappings (cdr (assoc keysym (display-keysym-translation display)))) - (mapping (or ;; Find the matching display mapping - (dolist (mapping display-mappings) - (when (mapping-matches-p display state mapping) - (return mapping))) - ;; Find the matching static mapping - (dolist (mapping (gethash keysym *keysym->character-map*)) - (when (mapping-matches-p display state mapping) - (return mapping)))))) - (when mapping - (funcall (or (keysym-mapping-translate mapping) 'default-keysym-translate) - display state (keysym-mapping-object mapping))))) - -(defun mapping-matches-p (display state mapping) - ;; Returns T when the modifiers and mask in MAPPING satisfies STATE for DISPLAY - (declare (type display display) - (type mask16 state) - (type list mapping)) - (declare (clx-values generalized-boolean)) - (flet - ((modifiers->mask (display-mapping modifiers errorp &aux (mask 0)) - ;; Convert MODIFIERS, which is a modifier mask, or a list of state-mask-keys into a mask. - ;; If ERRORP is non-nil, return NIL when an unknown modifier is specified, - ;; otherwise ignore unknown modifiers. - (declare (type list display-mapping) ; Alist of (keysym . mask) - (type (or mask16 list) modifiers) - (type mask16 mask)) - (declare (clx-values (or null mask16))) - (if (numberp modifiers) - modifiers - (dolist (modifier modifiers mask) - (declare (type symbol modifier)) - (let ((bit (position modifier (the simple-vector *state-mask-vector*) :test #'eq))) - (setq mask - (logior mask - (if bit - (ash 1 bit) - (or (cdr (assoc modifier display-mapping)) - ;; bad modifier - (if errorp - (return-from modifiers->mask nil) - 0)))))))))) - - (let* ((display-mapping (get-display-modifier-mapping display)) - (mapping-modifiers (keysym-mapping-modifiers mapping)) - (modifiers (or (modifiers->mask display-mapping (or mapping-modifiers 0) t) - (return-from mapping-matches-p nil))) - (mapping-mask (or (keysym-mapping-mask mapping) ; If no mask, use the default. - (if mapping-modifiers ; If no modifiers, match anything. - *default-keysym-translate-mask* - 0))) - (mask (if (eq mapping-mask :modifiers) - modifiers - (modifiers->mask display-mapping mapping-mask nil)))) - (declare (type mask16 modifiers mask)) - (= (logand state mask) modifiers)))) - -(defun default-keysym-index (display keycode state) - ;; Returns a keysym-index for use with keycode->character - (declare (clx-values card8)) - (macrolet ((keystate-p (state keyword) - `(logbitp ,(position keyword *state-mask-vector*) ,state))) - (let* ((mapping (display-keyboard-mapping display)) - (keysyms-per-keycode (array-dimension mapping 1)) - (symbolp (and (> keysyms-per-keycode 2) - (state-keysymp display state character-set-switch-keysym))) - (result (if symbolp 2 0))) - (declare (type (simple-array keysym (* *)) mapping) - (type generalized-boolean symbolp) - (type card8 keysyms-per-keycode result)) - (when (and (< result keysyms-per-keycode) - (keysym-shift-p display state (keysym-uppercase-alphabetic-p - (aref mapping keycode 0)))) - (incf result)) - result))) - -(defun keysym-shift-p (display state uppercase-alphabetic-p &key - shift-lock-xors - (control-modifiers - '#.(list left-meta-keysym left-super-keysym left-hyper-keysym))) - (declare (type display display) - (type card16 state) - (type generalized-boolean uppercase-alphabetic-p) - (type generalized-boolean shift-lock-xors));;; If T, both SHIFT-LOCK and SHIFT is the same - ;;; as neither if the character is alphabetic. - (declare (clx-values generalized-boolean)) - (macrolet ((keystate-p (state keyword) - `(logbitp ,(position keyword *state-mask-vector*) ,state))) - (let* ((controlp (or (keystate-p state :control) - (dolist (modifier control-modifiers) - (when (state-keysymp display state modifier) - (return t))))) - (shiftp (keystate-p state :shift)) - (lockp (keystate-p state :lock)) - (alphap (or uppercase-alphabetic-p - (not (state-keysymp display #.(make-state-mask :lock) - caps-lock-keysym))))) - (declare (type generalized-boolean controlp shiftp lockp alphap)) - ;; Control keys aren't affected by lock - (unless controlp - ;; Not a control character - check state of lock modifier - (when (and lockp - alphap - (or (not shiftp) shift-lock-xors)) ; Lock doesn't unshift unless shift-lock-xors - (setq shiftp (not shiftp)))) - shiftp))) - -;;; default-keysym-index implements the following tables: -;;; -;;; control shift caps-lock character character -;;; 0 0 0 #\a #\8 -;;; 0 0 1 #\A #\8 -;;; 0 1 0 #\A #\* -;;; 0 1 1 #\A #\* -;;; 1 0 0 #\control-A #\control-8 -;;; 1 0 1 #\control-A #\control-8 -;;; 1 1 0 #\control-shift-a #\control-* -;;; 1 1 1 #\control-shift-a #\control-* -;;; -;;; control shift shift-lock character character -;;; 0 0 0 #\a #\8 -;;; 0 0 1 #\A #\* -;;; 0 1 0 #\A #\* -;;; 0 1 1 #\A #\8 -;;; 1 0 0 #\control-A #\control-8 -;;; 1 0 1 #\control-A #\control-* -;;; 1 1 0 #\control-shift-a #\control-* -;;; 1 1 1 #\control-shift-a #\control-8 - -(defun keycode->character (display keycode state &key keysym-index - (keysym-index-function #'default-keysym-index)) - ;; keysym-index defaults to the result of keysym-index-function which - ;; is called with the following parameters: - ;; (char0 state caps-lock-p keysyms-per-keycode) - ;; where char0 is the "character" object associated with keysym-index 0 and - ;; caps-lock-p is non-nil when the keysym associated with the lock - ;; modifier is for caps-lock. - ;; STATE can also used for setting character attributes. - ;; Implementation dependent function. - (declare (type display display) - (type card8 keycode) - (type card16 state) - (type (or null card8) keysym-index) - (type (or null (function (base-char card16 generalized-boolean card8) card8)) - keysym-index-function)) - (declare (clx-values (or null character))) - (let* ((index (or keysym-index - (funcall keysym-index-function display keycode state))) - (keysym (if index (keycode->keysym display keycode index) 0))) - (declare (type (or null card8) index) - (type keysym keysym)) - (when (plusp keysym) - (keysym->character display keysym state)))) - -(defun get-display-modifier-mapping (display) - (labels ((keysym-replace (display modifiers mask &aux result) - (dolist (modifier modifiers result) - (push (cons (keycode->keysym display modifier 0) mask) result)))) - (or (display-modifier-mapping display) - (multiple-value-bind (shift lock control mod1 mod2 mod3 mod4 mod5) - (modifier-mapping display) - (setf (display-modifier-mapping display) - (nconc (keysym-replace display shift #.(make-state-mask :shift)) - (keysym-replace display lock #.(make-state-mask :lock)) - (keysym-replace display control #.(make-state-mask :control)) - (keysym-replace display mod1 #.(make-state-mask :mod-1)) - (keysym-replace display mod2 #.(make-state-mask :mod-2)) - (keysym-replace display mod3 #.(make-state-mask :mod-3)) - (keysym-replace display mod4 #.(make-state-mask :mod-4)) - (keysym-replace display mod5 #.(make-state-mask :mod-5)))))))) - -(defun state-keysymp (display state keysym) - ;; Returns T when a modifier key associated with KEYSYM is on in STATE - (declare (type display display) - (type card16 state) - (type keysym keysym)) - (declare (clx-values generalized-boolean)) - (let* ((mapping (get-display-modifier-mapping display)) - (mask (assoc keysym mapping))) - (and mask (plusp (logand state (cdr mask)))))) - -(defun mapping-notify (display request start count) - ;; Called on a mapping-notify event to update - ;; the keyboard-mapping cache in DISPLAY - (declare (type display display) - (type (member :modifier :keyboard :pointer) request) - (type card8 start count) - (ignore count start)) - ;; Invalidate the keyboard mapping to force the next key translation to get it - (case request - (:modifier - (setf (display-modifier-mapping display) nil)) - (:keyboard - (setf (display-keysym-mapping display) nil)))) - -(defun keysym-in-map-p (display keysym keymap) - ;; Returns T if keysym is found in keymap - (declare (type display display) - (type keysym keysym) - (type (bit-vector 256) keymap)) - (declare (clx-values generalized-boolean)) - ;; The keysym may appear in the keymap more than once, - ;; So we have to search the entire keysym map. - (do* ((min (display-min-keycode display)) - (max (display-max-keycode display)) - (map (display-keyboard-mapping display)) - (jmax (min 2 (array-dimension map 1))) - (i min (1+ i))) - ((> i max)) - (declare (type card8 min max jmax) - (type (simple-array keysym (* *)) map)) - (when (and (plusp (aref keymap i)) - (dotimes (j jmax) - (when (= keysym (aref map i j)) (return t)))) - (return t)))) - -(defun character-in-map-p (display character keymap) - ;; Implementation dependent function. - ;; Returns T if character is found in keymap - (declare (type display display) - (type character character) - (type (bit-vector 256) keymap)) - (declare (clx-values generalized-boolean)) - ;; Check all one bits in keymap - (do* ((min (display-min-keycode display)) - (max (display-max-keycode display)) - (jmax (array-dimension (display-keyboard-mapping display) 1)) - (i min (1+ i))) - ((> i max)) - (declare (type card8 min max jmax)) - (when (and (plusp (aref keymap i)) - ;; Match when character is in mapping for this keycode - (dotimes (j jmax) - (when (eql character (keycode->character display i 0 :keysym-index j)) - (return t)))) - (return t)))) - -(defun keysym->keycodes (display keysym) - ;; Return keycodes for keysym, as multiple values - (declare (type display display) - (type keysym keysym)) - (declare (clx-values (or null keycode) (or null keycode) (or null keycode))) - ;; The keysym may appear in the keymap more than once, - ;; So we have to search the entire keysym map. - (do* ((min (display-min-keycode display)) - (max (display-max-keycode display)) - (map (display-keyboard-mapping display)) - (jmax (min 2 (array-dimension map 1))) - (i min (1+ i)) - (result nil)) - ((> i max) (values-list result)) - (declare (type card8 min max jmax) - (type (simple-array keysym (* *)) map)) - (dotimes (j jmax) - (when (= keysym (aref map i j)) - (push i result)))))