From ef5128c0d8aed98021a7635e1652abe98379c023 Mon Sep 17 00:00:00 2001 From: dan Date: Sun, 2 Jul 2000 11:19:46 -0700 Subject: [PATCH] Initial revision darcs-hash:20000702181946-2591e-10c47dda735bab89484a29a521a068c2b808d0f0.gz --- CHANGES | 49 + README | 48 + attributes.lisp | 638 +++++++ buffer.lisp | 1802 +++++++++++++++++++ bufmac.lisp | 184 ++ cmudep.lisp | 19 + debug/debug.lisp | 77 + debug/describe.lisp | 1243 ++++++++++++++ debug/event-test.lisp | 237 +++ debug/keytrans.lisp | 266 +++ debug/trace.lisp | 456 +++++ debug/util.lisp | 167 ++ demo/bezier.lisp | 39 + demo/beziertest.lisp | 81 + demo/hello.lisp | 65 + demo/menu.lisp | 382 +++++ demo/zoid.lisp | 58 + display.lisp | 583 +++++++ doc.lisp | 3803 +++++++++++++++++++++++++++++++++++++++++ exclMakefile | 168 ++ exclREADME | 56 + exclcmac.lisp | 260 +++ excldefsys.lisp | 186 ++ excldep.c | 73 + excldep.lisp | 449 +++++ fonts.lisp | 365 ++++ generalock.lisp | 72 + graphics.lisp | 447 +++++ input.lisp | 1887 ++++++++++++++++++++ keysyms.lisp | 408 +++++ manager.lisp | 789 +++++++++ ms-patch.uu | 57 + package.lisp | 385 +++++ provide.lisp | 56 + requests.lisp | 1491 ++++++++++++++++ resource.lisp | 700 ++++++++ sockcl.lisp | 163 ++ socket.c | 153 ++ test/image.lisp | 153 ++ test/trapezoid.lisp | 72 + text.lisp | 1084 ++++++++++++ translate.lisp | 559 ++++++ 42 files changed, 20230 insertions(+) create mode 100644 CHANGES create mode 100644 README create mode 100644 attributes.lisp create mode 100644 buffer.lisp create mode 100644 bufmac.lisp create mode 100644 cmudep.lisp create mode 100644 debug/debug.lisp create mode 100644 debug/describe.lisp create mode 100644 debug/event-test.lisp create mode 100644 debug/keytrans.lisp create mode 100644 debug/trace.lisp create mode 100644 debug/util.lisp create mode 100644 demo/bezier.lisp create mode 100644 demo/beziertest.lisp create mode 100644 demo/hello.lisp create mode 100644 demo/menu.lisp create mode 100644 demo/zoid.lisp create mode 100644 display.lisp create mode 100644 doc.lisp create mode 100644 exclMakefile create mode 100644 exclREADME create mode 100644 exclcmac.lisp create mode 100644 excldefsys.lisp create mode 100644 excldep.c create mode 100644 excldep.lisp create mode 100644 fonts.lisp create mode 100644 generalock.lisp create mode 100644 graphics.lisp create mode 100644 input.lisp create mode 100644 keysyms.lisp create mode 100644 manager.lisp create mode 100644 ms-patch.uu create mode 100644 package.lisp create mode 100644 provide.lisp create mode 100644 requests.lisp create mode 100644 resource.lisp create mode 100644 sockcl.lisp create mode 100644 socket.c create mode 100644 test/image.lisp create mode 100644 test/trapezoid.lisp create mode 100644 text.lisp create mode 100644 translate.lisp diff --git a/CHANGES b/CHANGES new file mode 100644 index 0000000..b7fefc9 --- /dev/null +++ b/CHANGES @@ -0,0 +1,49 @@ +Details of changes since R5: + +Changes in CLX 5.02: + +Replace LCL:ENVIRONMENT-VALUE with LCL:ENVIRONMENT-VARIABLE. + +Fix a declaration in the DEFINE-ERROR macro. + +Quote type argument to TYPE-CHECK consistently. + + +Changes in CLX 5.01: + +Support for MIT-MAGIC-COOKIE-1 authorization has been added. + +All VALUES declarations have been changed to CLX-VALUES declarations. +VALUES is a CL type name and cannot be used as a declaration name. + +All ARRAY-REGISTER declarations have been removed as Genera no longer +needs them. + +Many type declarations have been corrected or tightened up now that some +Lisps look at them. + +Print functions have been defined for bitmap and pixmap formats. + +The DISPLAY-PLIST slot will be initialized to NIL. + +When debugging, don't optimize SPEED in the buffer macros. + +Make the CARD8<->CHAR and the window manager code work for sparse +character sets (where some codes do not have corresponding characters). + +The default gcontext extension set and copy functions will take the +correct number of arguments. + +PUT-IMAGE will now work for 24-bit images. + +The buffer accessors for MEMBER8, etc., will use the standard mechanisms +for reporting type errors. + +Typographical errors in SET-WM-PROPERTIES, SET-STANDARD-COLORMAP, and +POINTER-CONTROL have been fixed. + +Symbolics systems will do lazy macroexpansion in the buffer macros. + +A variety of changes for Symbolics Minima systems have been made. + +Some system-dependent code has been added for CMU Common Lisp. diff --git a/README b/README new file mode 100644 index 0000000..7f4aa19 --- /dev/null +++ b/README @@ -0,0 +1,48 @@ +These files contain beta code, but they have been tested to some extent under +Symbolics, TI, Lucid and Franz. The files have been given .l suffixes to keep +them within 12 characters, to keep SysV sites happy. Please rename them with +more appropriate suffixes for your system. + + +For Franz systems, see exclREADME. + + +For Symbolics systems, first rename all the .l files to .lisp. Then edit your +sys.translations file so that sys:x11;clx; points to this directory and put a +clx.system file in your sys:site;directory that has the form + + (si:set-system-source-file "clx" "sys:x11;clx;defsystem.lisp") + +in it. After that CLX can be compiled with the "Compile System CLX" command +and loaded with the "Load System CLX" command. + + + +For TI systems, rename all the .l files to .lisp, and make a clx.translations +file in your sys:site; directory pointing to this directory and a +sys:site;clx.system file like the one described for symbolics systems above, +but with the defsystem file being in the clx:clx; directory. Then CLX can be +compiled with (make-system "CLX" :compile :noconfirm) and loaded with +(make-system "CLX" :noconfirm). + + + +For Lucid systems, you should rename all the .l files to .lisp too (This might +not be possible on SysV systems). After loading the defsystem.l file, CLX can +be compiled with the (compile-clx) function and loaded with the +(load-clx) form. + +The ms-patch.uu file is a patch to Lucid version 2 systems. You probably +don't need it, as you are probably running Lucid version 3 or later, but if +you are still using Lucid version 2, you need this patch. You'll need to +uudecode it to produce the binary. + + + +For kcl systems, after loading the defsystem.l file, CLX can be compiled with +the (compile-clx) function and loaded with the (load-clx) form. + + + +For more information, see defsystem.l and provide.l. + diff --git a/attributes.lisp b/attributes.lisp new file mode 100644 index 0000000..bfeabb2 --- /dev/null +++ b/attributes.lisp @@ -0,0 +1,638 @@ +;;; -*- 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. +;;; + +;;; 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 load eval) ;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) + +#+Genera (eval-when (compile) (compiler:function-defined 'window-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) + +#+Genera (eval-when (compile) (compiler:function-defined 'window-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) + +#+Genera (eval-when (compile) (compiler:function-defined 'window-priority)) + +(defsetf window-priority (window &optional sibling) (mode) + ;; A bit strange, but retains setf form. + `(set-window-priority ,mode ,window ,sibling)) diff --git a/buffer.lisp b/buffer.lisp new file mode 100644 index 0000000..ead5e83 --- /dev/null +++ b/buffer.lisp @@ -0,0 +1,1802 @@ +;;; -*- 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. +;;; + +;; 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)) + #+clx-ansi-common-lisp + (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) + #+clx-ansi-common-lisp + (dynamic-extent function) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + #+clx-overlapping-arrays + `(aref-card16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1))) + #-clx-overlapping-arrays + `(aref-card16 buffer-bbuf (index+ buffer-boffset ,byte-index))) + +(defmacro read-int16 (byte-index) + #+clx-overlapping-arrays + `(aref-int16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1))) + #-clx-overlapping-arrays + `(aref-int16 buffer-bbuf (index+ buffer-boffset ,byte-index))) + +(defmacro read-card32 (byte-index) + #+clx-overlapping-arrays + `(aref-card32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) + #-clx-overlapping-arrays + `(aref-card32 buffer-bbuf (index+ buffer-boffset ,byte-index))) + +(defmacro read-int32 (byte-index) + #+clx-overlapping-arrays + `(aref-int32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) + #-clx-overlapping-arrays + `(aref-int32 buffer-bbuf (index+ buffer-boffset ,byte-index))) + +(defmacro read-card29 (byte-index) + #+clx-overlapping-arrays + `(aref-card29 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) + #-clx-overlapping-arrays + `(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))) + #-clx-overlapping-arrays + (buffer-bbuf (reply-ibuf8 %reply-buffer)) + #+clx-overlapping-arrays + ,@(append + (when (member 8 sizes) + `((buffer-bbuf (reply-ibuf8 %reply-buffer)))) + (when (or (member 16 sizes) (member 160 sizes)) + `((buffer-woffset (index-ash buffer-boffset -1)) + (buffer-wbuf (reply-ibuf16 %reply-buffer)))) + (when (member 32 sizes) + `((buffer-loffset (index-ash buffer-boffset -2)) + (buffer-lbuf (reply-ibuf32 %reply-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))) + +(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 + #+clx-overlapping-arrays + :obuf16 + #+clx-overlapping-arrays + (make-array (index-ash output-size -1) + :element-type 'overlap16 + :displaced-to byte-output) + #+clx-overlapping-arrays + :obuf32 + #+clx-overlapping-arrays + (make-array (index-ash output-size -2) + :element-type 'overlap32 + :displaced-to 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 + #+clx-overlapping-arrays + :ibuf16 + #+clx-overlapping-arrays + (make-array (index-ash size -1) + :element-type 'overlap16 + :displaced-to byte-input) + #+clx-overlapping-arrays + :ibuf32 + #+clx-overlapping-arrays + (make-array (index-ash size -2) + :element-type 'overlap32 + :displaced-to 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) + #+clx-overlapping-arrays + (setf (buffer-obuf16 buffer) + (make-array (index-ash new-buffer-size -1) + :element-type 'overlap16 + :displaced-to new-buffer) + (buffer-obuf32 buffer) + (make-array (index-ash new-buffer-size -2) + :element-type 'overlap32 + :displaced-to 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) + #+clx-ansi-common-lisp + (dynamic-extent request-function) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + #+clx-ansi-common-lisp + (dynamic-extent request-function) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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 #-explorer :type #-explorer (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) + #+clx-ansi-common-lisp + (dynamic-extent request-function reply-function) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) + (if transform + (flet ((card8->char->transform (v) + (declare (type card8 v)) + (funcall transform (card8->char v)))) + #+clx-ansi-common-lisp + (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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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)))))) + +#-lispm +(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)))) + +#-lispm +(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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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))) + #-lispm + ((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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) + (if transform + (flet ((card8->int8->transform (v) + (declare (type card8 v)) + (funcall transform (card8->int8 v)))) + #+clx-ansi-common-lisp + (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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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)))))) + +#-lispm +(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) + #-clx-overlapping-arrays + (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)))) + #+clx-overlapping-arrays + (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2))))) + +#-lispm +(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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + #-clx-overlapping-arrays + (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))) + #+clx-overlapping-arrays + (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2))))) + +(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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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))) + #-lispm + ((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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) + (if transform + (flet ((card16->int16->transform (v) + (declare (type card16 v)) + (funcall transform (card16->int16 v)))) + #+clx-ansi-common-lisp + (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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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)))))) + +#-lispm +(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) + #-clx-overlapping-arrays + (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)))) + #+clx-overlapping-arrays + (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4))))) + +#-lispm +(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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + #-clx-overlapping-arrays + (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))) + #+clx-overlapping-arrays + (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4))))) + +(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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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))) + #-lispm + ((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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) + (if transform + (flet ((card32->int32->transform (v) + (declare (type card32 v)) + (funcall transform (card32->int32 v)))) + #+clx-ansi-common-lisp + (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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) + (if transform + (flet ((transform->char->card8 (x) + (char->card8 (the character (funcall transform x))))) + #+clx-ansi-common-lisp + (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)) + #-ti (write-card8 j (pop lst)) ;TI Compiler bug + #+ti (setf (aref buffer-bbuf (index+ buffer-boffset 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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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 +#-lispm +(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) + +#-lispm +(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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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))) + #-lispm + ((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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) + (if transform + (flet ((transform->int8->card8 (x) + (int8->card8 (the int8 (funcall transform x))))) + #+clx-ansi-common-lisp + (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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + +#-lispm +(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) + +#-lispm +(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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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))) + #-lispm + ((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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + +#-lispm +(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) + +#-lispm +(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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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))) + #-lispm + ((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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + +#-lispm +(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) + +#-lispm +(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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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))) + #-lispm + ((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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) + (if transform + (flet ((transform->int32->card32 (x) + (int32->card32 (the int32 (funcall transform x))))) + #+clx-ansi-common-lisp + (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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + +#-lispm +(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) + +#-lispm +(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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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))) + #-lispm + ((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/bufmac.lisp b/bufmac.lisp new file mode 100644 index 0000000..1e002b8 --- /dev/null +++ b/bufmac.lisp @@ -0,0 +1,184 @@ +;;; -*- 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. +;;; + +(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/cmudep.lisp b/cmudep.lisp new file mode 100644 index 0000000..8624a3e --- /dev/null +++ b/cmudep.lisp @@ -0,0 +1,19 @@ +;;; -*- Package: XLIB -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /loaclhost/usr/local/src/cvs/clx/cmudep.lisp,v 1.1 2000/07/02 19:19:46 dan Exp $") +;;; +;;; ********************************************************************** +;;; +(in-package "XLIB") + +(alien:def-alien-routine ("connect_to_server" xlib::connect-to-server) + c-call:int + (host c-call:c-string) + (port c-call:int)) diff --git a/debug/debug.lisp b/debug/debug.lisp new file mode 100644 index 0000000..69f3dd6 --- /dev/null +++ b/debug/debug.lisp @@ -0,0 +1,77 @@ +;;; -*- 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/debug/describe.lisp b/debug/describe.lisp new file mode 100644 index 0000000..00371fc --- /dev/null +++ b/debug/describe.lisp @@ -0,0 +1,1243 @@ +;;; -*- 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/debug/event-test.lisp b/debug/event-test.lisp new file mode 100644 index 0000000..5ded127 --- /dev/null +++ b/debug/event-test.lisp @@ -0,0 +1,237 @@ +;;; -*- 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/debug/keytrans.lisp b/debug/keytrans.lisp new file mode 100644 index 0000000..333c1ef --- /dev/null +++ b/debug/keytrans.lisp @@ -0,0 +1,266 @@ +;;; -*- 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/debug/trace.lisp b/debug/trace.lisp new file mode 100644 index 0000000..276e2f5 --- /dev/null +++ b/debug/trace.lisp @@ -0,0 +1,456 @@ +;;; -*- 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/debug/util.lisp b/debug/util.lisp new file mode 100644 index 0000000..7db6be6 --- /dev/null +++ b/debug/util.lisp @@ -0,0 +1,167 @@ +;;; -*- 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/demo/bezier.lisp b/demo/bezier.lisp new file mode 100644 index 0000000..fca439b --- /dev/null +++ b/demo/bezier.lisp @@ -0,0 +1,39 @@ +;;; -*- 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/demo/beziertest.lisp b/demo/beziertest.lisp new file mode 100644 index 0000000..dc5bb91 --- /dev/null +++ b/demo/beziertest.lisp @@ -0,0 +1,81 @@ +;;; -*- 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/demo/hello.lisp b/demo/hello.lisp new file mode 100644 index 0000000..a3fbd88 --- /dev/null +++ b/demo/hello.lisp @@ -0,0 +1,65 @@ +;;; -*- 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/demo/menu.lisp b/demo/menu.lisp new file mode 100644 index 0000000..80bc08e --- /dev/null +++ b/demo/menu.lisp @@ -0,0 +1,382 @@ +;;; -*- 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/demo/zoid.lisp b/demo/zoid.lisp new file mode 100644 index 0000000..0a31305 --- /dev/null +++ b/demo/zoid.lisp @@ -0,0 +1,58 @@ +;;; -*- 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/display.lisp b/display.lisp new file mode 100644 index 0000000..58901cb --- /dev/null +++ b/display.lisp @@ -0,0 +1,583 @@ +;;; -*- 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. +;;; + +(in-package :xlib) + +;;; Authorizaton + +(defparameter *known-authorizations* '("MIT-MAGIC-COOKIE-1")) + +(defun get-best-authorization (host display protocol) + (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 ((pathname (authority-pathname))) + (when pathname + (with-open-file (stream pathname :element-type '(unsigned-byte 8) + :if-does-not-exist nil) + (when stream + (let* ((host-family (ecase protocol + ((:tcp :internet nil) 0) + ((:dna :DECnet) 1) + ((:chaos) 2) + ((:unix) 256))) + (host-address (if (eq protocol :unix) + (map 'list #'char-int (machine-instance)) + (rest (host-address host host-family)))) + (best-name nil) + (best-data nil)) + (loop + (let ((family (read-short stream nil))) + (when (null family) + (return)) + (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))) + (when (and (= family host-family) + (equal host-address (coerce address 'list)) + (= number display) + (let ((pos1 (position name *known-authorizations* :test #'string=))) + (and pos1 + (or (null best-name) + (< pos1 (position best-name *known-authorizations* + :test #'string=)))))) + (setf best-name name) + (setf 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)) + #+clx-ansi-common-lisp + (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) + #+clx-ansi-common-lisp + (dynamic-extent function) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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-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 nework 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 :unix + (when (null authorization-name) + (multiple-value-setq (authorization-name authorization-data) + (get-best-authorization host + display + (if (member host '("" "unix") :test #'equal) + :unix + protocol)))) + ;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM. + (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/doc.lisp b/doc.lisp new file mode 100644 index 0000000..bff618e --- /dev/null +++ b/doc.lisp @@ -0,0 +1,3803 @@ +;;; -*- 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. + +;; 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/exclMakefile b/exclMakefile new file mode 100644 index 0000000..bd0c936 --- /dev/null +++ b/exclMakefile @@ -0,0 +1,168 @@ +# +# Makefile for CLX +# (X11 R4.4 release, Franz Allegro Common Lisp version) +# + +# ************************************************************************* +# * Change the next line to point to where you have Common Lisp installed * +# * (make sure the Lisp doesn't already have CLX loaded in) * +# ************************************************************************* +CL = /usr/local/bin/cl + +RM = /bin/rm +SHELL = /bin/sh +ECHO = /bin/echo +TAGS = /usr/local/lib/emacs/etc/etags + +# Name of dumped lisp +CLX = CLX + +CLOPTS = -qq + +# Use this one for Suns +CFLAGS = -O -DUNIXCONN +# Use this one for Silicon Graphics & Mips Inc MIPS based machines +# CFLAGS = -O -G 0 -I/usr/include/bsd +# Use this one for DEC MIPS based machines +# CFLAGS = -O -G 0 -DUNIXCONN +# Use this one for HP machines +# CFLAGS = -O -DSYSV -DUNIXCONN + + +# Lisp optimization for compiling +SPEED = 3 +SAFETY = 0 + + +C_SRC = excldep.c socket.c +C_OBJS = excldep.o socket.o + +L_OBJS = defsystem.fasl package.fasl excldep.fasl depdefs.fasl clx.fasl \ + dependent.fasl exclcmac.fasl macros.fasl bufmac.fasl buffer.fasl \ + display.fasl gcontext.fasl requests.fasl input.fasl fonts.fasl \ + graphics.fasl text.fasl attributes.fasl translate.fasl keysyms.fasl \ + manager.fasl image.fasl resource.fasl + +L_NOMACROS_OBJS = package.fasl excldep.fasl depdefs.fasl clx.fasl \ + dependent.fasl buffer.fasl display.fasl gcontext.fasl \ + requests.fasl input.fasl fonts.fasl graphics.fasl text.fasl \ + attributes.fasl translate.fasl keysyms.fasl manager.fasl image.fasl \ + resource.fasl + +L_SRC = defsystem.cl package.cl excldep.cl depdefs.cl clx.cl \ + dependent.cl exclcmac.cl macros.cl bufmac.cl buffer.cl \ + display.cl gcontext.cl requests.cl input.cl fonts.cl \ + graphics.cl text.cl attributes.cl translate.cl keysyms.cl \ + manager.cl image.cl resource.cl + +# default and aliases +all: no-clos +# all: partial-clos +compile-CLX-for-CLUE: compile-partial-clos-CLX +clue: partial-clos + +# +# Three build rules are provided: no-clos, partial-clos, and full-clos. +# The first is no-clos, which results in a CLX whose datastructures are +# all defstructs. partial-clos results in xlib:window, xlib:pixmap, and +# xlib:drawable being CLOS instances, all others defstructs. full-clos +# makes all CLX complex datatypes into CLOS instances. +# +# (note that the :clos feature implies native CLOS *not* PCL). +# + +no-clos: $(C_OBJS) compile-no-clos-CLX cat + +# +# This rule is used to compile CLX to be used with XCW version 2, or CLUE. +# +partial-clos: $(C_OBJS) compile-partial-clos-CLX cat + +full-clos: $(C_OBJS) compile-full-clos-CLX cat + + +c: $(C_OBJS) + + +compile-no-clos-CLX: $(C_OBJS) + $(ECHO) " \ + (set-case-mode :case-sensitive-lower) \ + (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ + #+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \ + (load \"defsystem\") \ + #+allegro (compile-system :clx) \ + #-allegro (compile-clx) \ + #+allegro (compile-system :clx-debug)" \ + | $(CL) $(CLOPTS) -batch + +compile-partial-clos-CLX: $(C_OBJS) + $(ECHO) " \ + #+clos (set-case-mode :case-sensitive-lower) \ + #-clos (setq excl::*print-nickname* t) \ + (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ + (unless (or (find-package 'clos) (find-package 'pcl)) \ + (let ((spread (sys:gsgc-parameter :generation-spread))) \ + (setf (sys:gsgc-parameter :generation-spread) 1) \ + (require :pcl) \ + (provide :pcl) \ + (gc) (gc) \ + (setf (sys:gsgc-parameter :generation-spread) spread))) \ + #+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \ + (load \"defsystem\") \ + (load \"package\") \ + (setq xlib::*def-clx-class-use-defclass* '(xlib:window xlib:pixmap xlib:drawable)) \ + #+allegro (compile-system :clx) \ + #-allegro (compile-clx \"\" \"\" :for-clue t) \ + #+allegro (compile-system :clx-debug)" \ + | $(CL) $(CLOPTS) -batch + +compile-full-clos-CLX: $(C_OBJS) + $(ECHO) " \ + #+clos (set-case-mode :case-sensitive-lower) \ + #-clos (setq excl::*print-nickname* t) \ + (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ + (unless (or (find-package 'clos) (find-package 'pcl)) \ + (let ((spread (sys:gsgc-parameter :generation-spread))) \ + (setf (sys:gsgc-parameter :generation-spread) 1) \ + (require :pcl) \ + (provide :pcl) \ + (gc) (gc) \ + (setf (sys:gsgc-parameter :generation-spread) spread))) \ + #+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \ + (load \"defsystem\") \ + (load \"package\") \ + (setq xlib::*def-clx-class-use-defclass* t) \ + #+allegro (compile-system :clx) \ + #-allegro (compile-clx \"\" \"\" :for-clue t) \ + #+allegro (compile-system :clx-debug)" \ + | $(CL) $(CLOPTS) -batch + + +cat: + -cat $(L_NOMACROS_OBJS) > CLX.fasl + + +load-CLX: + $(ECHO) " \ + (let ((spread (sys:gsgc-parameter :generation-spread))) \ + (setf (sys:gsgc-parameter :generation-spread) 1) \ + (load \"defsystem\") \ + #+allegro (load-system :clx) \ + #-allegro (load-clx) \ + (gc :tenure) \ + (setf (sys:gsgc-parameter :generation-spread) spread)) \ + (gc t)" \ + '(dumplisp :name "$(CLX)" #+allegro :checkpoint #+allegro nil)' \ + "(exit)" | $(CL) $(CLOPTS) + +clean: + $(RM) -f *.fasl debug/*.fasl $(CLX) core $(C_OBJS) make.out + + +install: + mv CLX.fasl $(DEST)/clx.fasl + mv *.o $(DEST) + + +tags: + $(TAGS) $(L_SRC) $(C_SRC) diff --git a/exclREADME b/exclREADME new file mode 100644 index 0000000..c99e388 --- /dev/null +++ b/exclREADME @@ -0,0 +1,56 @@ + This file contains instructions on how to make CLX work with Franz +Common Lisp. CLX should work on any machine that supports Allegro Common +Lisp version 3.0.1 or greater. It also works under ExCL version 2.0.10. +However it has been tested extensively with only Allegro CL versions 3.0, +3.1, and 4.0. + + There are three steps to compile and install CLX. The first is simply +moving files around. In this directory, execute (assuming you using csh): + +% foreach i (*.l */*.l) +? mv $i $i:r.cl +? end +% mv exclMakefile Makefile + + The second is compiling the source files into fasl files. The fasl files +will be combined into one big fasl file, CLX.fasl. This file is then installed +in your Common Lisp library directory in the next step. You may need to edit +the Makefile to select the proper CFLAGS for your machine -- look in Makefile +for examples. Then just: + +% make + + Now you must move the CLX.fasl file into the standard CL library. +This is normally "/usr/local/lib/cl/code", but you can find out for sure +by typing: + + (directory-namestring excl::*library-code-pathname*) + +to a running Lisp. If it prints something other than "/usr/local/lib/cl/code" +substitute what it prints in the below instructions. + +% mv CLX.fasl /usr/local/lib/cl/code/clx.fasl +% mv *.o /usr/local/lib/cl/code + +Now you can just start up Lisp and type: + + (load "clx") + +to load in CLX. You may want to dump a lisp at this point since CLX is a large +package and can take some time to load into Lisp. You probably also want to +set the :generation-spread to 1 while loading CLX. Please see your Allegro CL +User Guide for more information on :generation-spread. + + + Sophisticated users may wish to peruse the Makefile and defsystem.cl +and note how things are set up. For example we hardwire the compiler +interrupt check switch on, so that CL can still be interrupted while it +is reading from the X11 socket. Please see chapter 7 of the CL User's +guide for more information on compiler switches and their effects. + + +Please report Franz specific CLX bugs to: + + ucbvax!franz!bugs + or + bugs@Franz.COM diff --git a/exclcmac.lisp b/exclcmac.lisp new file mode 100644 index 0000000..04fd20a --- /dev/null +++ b/exclcmac.lisp @@ -0,0 +1,260 @@ +;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*- +;;; +;;; CLX -- exclcmac.cl +;;; This file provides for inline expansion of some functions. +;;; +;;; Copyright (c) 1989 Franz Inc, Berkeley, Ca. +;;; +;;; 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. +;;; +;;; Franz Incorporated provides this software "as is" without +;;; express or implied warranty. +;;; + +(in-package :xlib) + +;; +;; Type predicates +;; +(excl:defcmacro card8p (x) + (let ((xx (gensym))) + `(let ((,xx ,x)) + (declare (optimize (speed 3) (safety 0)) + (fixnum ,xx)) + (and (excl:fixnump ,xx) (> #.(expt 2 8) ,xx) (>= ,xx 0))))) + +(excl:defcmacro card16p (x) + (let ((xx (gensym))) + `(let ((,xx ,x)) + (declare (optimize (speed 3) (safety 0)) + (fixnum ,xx)) + (and (excl:fixnump ,xx) (> #.(expt 2 16) ,xx) (>= ,xx 0))))) + +(excl:defcmacro int8p (x) + (let ((xx (gensym))) + `(let ((,xx ,x)) + (declare (optimize (speed 3) (safety 0)) + (fixnum ,xx)) + (and (excl:fixnump ,xx) (> #.(expt 2 7) ,xx) (>= ,xx #.(expt -2 7)))))) + +(excl:defcmacro int16p (x) + (let ((xx (gensym))) + `(let ((,xx ,x)) + (declare (optimize (speed 3) (safety 0)) + (fixnum ,xx)) + (and (excl:fixnump ,xx) (> #.(expt 2 15) ,xx) (>= ,xx #.(expt -2 15)))))) + +;; Card29p, card32p, int32p are too large to expand inline + + +;; +;; Type transformers +;; +(excl:defcmacro card8->int8 (x) + (let ((xx (gensym))) + `(let ((,xx ,x)) + ,(declare-bufmac) + (declare (type card8 ,xx)) + (the int8 (if (logbitp 7 ,xx) + (the int8 (- ,xx #x100)) + ,xx))))) +(excl:defcmacro int8->card8 (x) + `(locally ,(declare-bufmac) + (the card8 (ldb (byte 8 0) (the int8 ,x))))) + +(excl:defcmacro card16->int16 (x) + (let ((xx (gensym))) + `(let ((,xx ,x)) + ,(declare-bufmac) + (declare (type card16 ,xx)) + (the int16 (if (logbitp 15 ,xx) + (the int16 (- ,xx #x10000)) + ,xx))))) + +(excl:defcmacro int16->card16 (x) + `(locally ,(declare-bufmac) + (the card16 (ldb (byte 16 0) (the int16 ,x))))) + +(excl:defcmacro card32->int32 (x) + (let ((xx (gensym))) + `(let ((,xx ,x)) + ,(declare-bufmac) + (declare (type card32 ,xx)) + (the int32 (if (logbitp 31 ,xx) + (the int32 (- ,xx #x100000000)) + ,xx))))) + +(excl:defcmacro int32->card32 (x) + `(locally ,(declare-bufmac) + (the card32 (ldb (byte 32 0) (the int32 ,x))))) + +(excl:defcmacro char->card8 (char) + `(locally ,(declare-bufmac) + (the card8 (char-code (the string-char ,char))))) + +(excl:defcmacro card8->char (card8) + `(locally ,(declare-bufmac) + (the string-char (code-char (the card8 ,card8))))) + + +;; +;; Array accessors and setters +;; +(excl:defcmacro aref-card8 (a i) + `(locally ,(declare-bufmac) + (the card8 (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :unsigned-byte)))) + +(excl:defcmacro aset-card8 (v a i) + `(locally ,(declare-bufmac) + (setf (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :unsigned-byte) + (the card8 ,v)))) + +(excl:defcmacro aref-int8 (a i) + `(locally ,(declare-bufmac) + (the int8 (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :signed-byte)))) + +(excl:defcmacro aset-int8 (v a i) + `(locally ,(declare-bufmac) + (setf (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :signed-byte) + (the int8 ,v)))) + +(excl:defcmacro aref-card16 (a i) + `(locally ,(declare-bufmac) + (the card16 (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :unsigned-word)))) + +(excl:defcmacro aset-card16 (v a i) + `(locally ,(declare-bufmac) + (setf (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :unsigned-word) + (the card16 ,v)))) + +(excl:defcmacro aref-int16 (a i) + `(locally ,(declare-bufmac) + (the int16 (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :signed-word)))) + +(excl:defcmacro aset-int16 (v a i) + `(locally ,(declare-bufmac) + (setf (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :signed-word) + (the int16 ,v)))) + +(excl:defcmacro aref-card32 (a i) + `(locally ,(declare-bufmac) + (the card32 (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :unsigned-long)))) + +(excl:defcmacro aset-card32 (v a i) + `(locally ,(declare-bufmac) + (setf (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :unsigned-long) + (the card32 ,v)))) + +(excl:defcmacro aref-int32 (a i) + `(locally ,(declare-bufmac) + (the int32 (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :signed-long)))) + +(excl:defcmacro aset-int32 (v a i) + `(locally ,(declare-bufmac) + (setf (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :signed-long) + (the int32 ,v)))) + +(excl:defcmacro aref-card29 (a i) + ;; Don't need to mask bits here since X protocol guarantees top bits zero + `(locally ,(declare-bufmac) + (the card29 (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :unsigned-long)))) + +(excl:defcmacro aset-card29 (v a i) + ;; I also assume here Lisp is passing a number that fits in 29 bits. + `(locally ,(declare-bufmac) + (setf (sys:memref (the buffer-bytes ,a) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :unsigned-long) + (the card29 ,v)))) + +;; +;; Font accessors +;; +(excl:defcmacro font-id (font) + ;; Get font-id, opening font if needed + (let ((f (gensym))) + `(let ((,f ,font)) + (or (font-id-internal ,f) + (open-font-internal ,f))))) + +(excl:defcmacro font-font-info (font) + (let ((f (gensym))) + `(let ((,f ,font)) + (or (font-font-info-internal ,f) + (query-font ,f))))) + +(excl:defcmacro font-char-infos (font) + (let ((f (gensym))) + `(let ((,f ,font)) + (or (font-char-infos-internal ,f) + (progn (query-font ,f) + (font-char-infos-internal ,f)))))) + + +;; +;; Miscellaneous +;; +(excl:defcmacro current-process () + `(the (or mp::process null) (and mp::*scheduler-stack-group* + mp::*current-process*))) + +(excl:defcmacro process-wakeup (process) + (let ((proc (gensym))) + `(let ((.pw-curproc. mp::*current-process*) + (,proc ,process)) + (when (and .pw-curproc. ,proc) + (if (> (mp::process-priority ,proc) + (mp::process-priority .pw-curproc.)) + (mp::process-allow-schedule ,proc)))))) + +(excl:defcmacro buffer-new-request-number (buffer) + (let ((buf (gensym))) + `(let ((,buf ,buffer)) + (declare (type buffer ,buf)) + (setf (buffer-request-number ,buf) + (ldb (byte 16 0) (1+ (buffer-request-number ,buf))))))) + + diff --git a/excldefsys.lisp b/excldefsys.lisp new file mode 100644 index 0000000..abbc5dc --- /dev/null +++ b/excldefsys.lisp @@ -0,0 +1,186 @@ +;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*- +;;; +;;; Copyright (c) 1988, 1989 Franz Inc, Berkeley, Ca. +;;; +;;; 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. +;;; +;;; Franz Incorporated provides this software "as is" without express or +;;; implied warranty. +;;; + +(in-package :xlib :use '(:foreign-functions :lisp :excl)) + +#+allegro +(require :defsystem "defsys") + +(eval-when (load) + (require :clxexcldep "excldep")) + +;; +;; The following is a suggestion. If you comment out this form be +;; prepared for possible deadlock, since no interrupts will be recognized +;; while reading from the X socket if the scheduler is not running. +;; +(setq compiler::generate-interrupt-checks-switch + (compile nil '(lambda (safety size speed) + (declare (ignore size)) + (or (< speed 3) (> safety 0))))) + + +#+allegro +(excl:defsystem :clx + () + |depdefs| + (|clx| :load-before-compile (|depdefs|) + :recompile-on (|depdefs|)) + (|dependent| :load-before-compile (|depdefs| |clx|) + :recompile-on (|clx|)) + (|exclcmac| :load-before-compile (|depdefs| |clx| |dependent|) + :recompile-on (|dependent|)) + (|macros| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|) + :recompile-on (|exclcmac|)) + (|bufmac| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros|) + :recompile-on (|macros|)) + (|buffer| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac|) + :recompile-on (|bufmac|)) + (|display| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac| |buffer|) + :recompile-on (|buffer|)) + (|gcontext| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac| |buffer| + |display|) + :recompile-on (|display|)) + (|input| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac| |buffer| |display| + ) + :recompile-on (|display|)) + (|requests| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac| |buffer| + |display| |input|) + :recompile-on (|display|)) + (|fonts| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac| |buffer| |display| + ) + :recompile-on (|display|)) + (|graphics| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac| |buffer| + |display| |fonts|) + :recompile-on (|fonts|)) + (|text| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| + |bufmac| |buffer| |display| + |gcontext| |fonts|) + :recompile-on (|gcontext| |fonts|) + :load-after (|translate|)) + ;; The above line gets around a compiler macro expansion bug. + + (|attributes| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac| |buffer| + |display|) + :recompile-on (|display|)) + (|translate| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac| |buffer| + |display| |text|) + :recompile-on (|display|)) + (|keysyms| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac| |buffer| + |display| |translate|) + :recompile-on (|translate|)) + (|manager| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac| |buffer| + |display|) + :recompile-on (|display|)) + (|image| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac| |buffer| |display| + ) + :recompile-on (|display|)) + + ;; Don't know if l-b-c list is correct. XX + (|resource| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| + |macros| |bufmac| |buffer| + |display|) + :recompile-on (|display|)) + ) + +#+allegro +(excl:defsystem :clx-debug + (:default-pathname "debug/" + :needed-systems (:clx) + :load-before-compile (:clx)) + |describe| |keytrans| |trace| |util|) + + +(defun compile-clx (&optional pathname-defaults) + (let ((*default-pathname-defaults* + (or pathname-defaults *default-pathname-defaults*))) + (declare (special *default-pathname-defaults*)) + (compile-file "depdefs") + (load "depdefs") + (compile-file "clx") + (load "clx") + (compile-file "dependent") + (load "dependent") + (compile-file "macros") + (load "macros") + (compile-file "bufmac") + (load "bufmac") + (compile-file "buffer") + (load "buffer") + (compile-file "display") + (load "display") + (compile-file "gcontext") + (load "gcontext") + (compile-file "input") + (load "input") + (compile-file "requests") + (load "requests") + (compile-file "fonts") + (load "fonts") + (compile-file "graphics") + (load "graphics") + (compile-file "text") + (load "text") + (compile-file "attributes") + (load "attributes") + (load "translate") + (compile-file "translate") ; work-around bug in 2.0 and 2.2 + (load "translate") + (compile-file "keysyms") + (load "keysyms") + (compile-file "manager") + (load "manager") + (compile-file "image") + (load "image") + (compile-file "resource") + (load "resource") + )) + + +(defun load-clx (&optional pathname-defaults) + (let ((*default-pathname-defaults* + (or pathname-defaults *default-pathname-defaults*))) + (declare (special *default-pathname-defaults*)) + (load "depdefs") + (load "clx") + (load "dependent") + (load "macros") + (load "bufmac") + (load "buffer") + (load "display") + (load "gcontext") + (load "input") + (load "requests") + (load "fonts") + (load "graphics") + (load "text") + (load "attributes") + (load "translate") + (load "keysyms") + (load "manager") + (load "image") + (load "resource") + )) diff --git a/excldep.c b/excldep.c new file mode 100644 index 0000000..c6fe25c --- /dev/null +++ b/excldep.c @@ -0,0 +1,73 @@ +/* + * Allegro CL dependent C helper routines for CLX + */ + +/* + * This code requires select and interval timers. + * This means you probably need BSD, or a version + * of Unix with select and interval timers added. + */ + +#include +#include +#include +#include + +#define ERROR -1 +#define INTERRUPT -2 +#define TIMEOUT 0 +#define SUCCESS 1 + +#ifdef FD_SETSIZE +#define NUMBER_OF_FDS FD_SETSIZE /* Highest possible file descriptor */ +#else +#define NUMBER_OF_FDS 32 +#endif + +/* Length of array needed to hold all file descriptor bits */ +#define CHECKLEN ((NUMBER_OF_FDS+8*sizeof(int)-1) / (8 * sizeof(int))) + +extern int errno; + +/* + * This function waits for input to become available on 'fd'. If timeout is + * 0, wait forever. Otherwise wait 'timeout' seconds. If input becomes + * available before the timer expires, return SUCCESS. If the timer expires + * return TIMEOUT. If an error occurs, return ERROR. If an interrupt occurs + * while waiting, return INTERRUPT. + */ +int fd_wait_for_input(fd, timeout) + register int fd; + register int timeout; +{ + struct timeval timer; + register int i; + int checkfds[CHECKLEN]; + + if (fd < 0 || fd >= NUMBER_OF_FDS) { + fprintf(stderr, "Bad file descriptor argument: %d to fd_wait_for_input\n", fd); + fflush(stderr); + } + + for (i = 0; i < CHECKLEN; i++) + checkfds[i] = 0; + checkfds[fd / (8 * sizeof(int))] |= 1 << (fd % (8 * sizeof(int))); + + if (timeout) { + timer.tv_sec = timeout; + timer.tv_usec = 0; + i = select(32, checkfds, (int *)0, (int *)0, &timer); + } else + i = select(32, checkfds, (int *)0, (int *)0, (struct timeval *)0); + + if (i < 0) + /* error condition */ + if (errno == EINTR) + return (INTERRUPT); + else + return (ERROR); + else if (i == 0) + return (TIMEOUT); + else + return (SUCCESS); +} diff --git a/excldep.lisp b/excldep.lisp new file mode 100644 index 0000000..e6e59d2 --- /dev/null +++ b/excldep.lisp @@ -0,0 +1,449 @@ +;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*- +;;; +;;; CLX -- excldep.cl +;;; +;;; Copyright (c) 1987, 1988, 1989 Franz Inc, Berkeley, Ca. +;;; +;;; 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. +;;; +;;; Franz Incorporated provides this software "as is" without +;;; express or implied warranty. +;;; + +(in-package :xlib) + +(eval-when (compile load eval) + (require :foreign) + (require :process) ; Needed even if scheduler is not + ; running. (Must be able to make + ; a process-lock.) + ) + +(eval-when (load) + (provide :clx)) + + +#-(or little-endian big-endian) +(eval-when (eval compile load) + (let ((x '#(1))) + (if (not (eq 0 (sys::memref x + #.(comp::mdparam 'comp::md-svector-data0-adj) + 0 :unsigned-byte))) + (pushnew :little-endian *features*) + (pushnew :big-endian *features*)))) + + +(defmacro correct-case (string) + ;; This macro converts the given string to the + ;; current preferred case, or leaves it alone in a case-sensitive mode. + (let ((str (gensym))) + `(let ((,str ,string)) + (case excl::*current-case-mode* + (:case-insensitive-lower + (string-downcase ,str)) + (:case-insensitive-upper + (string-upcase ,str)) + ((:case-sensitive-lower :case-sensitive-upper) + ,str))))) + + +(defconstant type-pred-alist + '(#-(version>= 4 1 devel 16) + (card8 . card8p) + #-(version>= 4 1 devel 16) + (card16 . card16p) + #-(version>= 4 1 devel 16) + (card29 . card29p) + #-(version>= 4 1 devel 16) + (card32 . card32p) + #-(version>= 4 1 devel 16) + (int8 . int8p) + #-(version>= 4 1 devel 16) + (int16 . int16p) + #-(version>= 4 1 devel 16) + (int32 . int32p) + #-(version>= 4 1 devel 16) + (mask16 . card16p) + #-(version>= 4 1 devel 16) + (mask32 . card32p) + #-(version>= 4 1 devel 16) + (pixel . card32p) + #-(version>= 4 1 devel 16) + (resource-id . card29p) + #-(version>= 4 1 devel 16) + (keysym . card32p) + (angle . anglep) + (color . color-p) + (bitmap-format . bitmap-format-p) + (pixmap-format . pixmap-format-p) + (display . display-p) + (drawable . drawable-p) + (window . window-p) + (pixmap . pixmap-p) + (visual-info . visual-info-p) + (colormap . colormap-p) + (cursor . cursor-p) + (gcontext . gcontext-p) + (screen . screen-p) + (font . font-p) + (image-x . image-x-p) + (image-xy . image-xy-p) + (image-z . image-z-p) + (wm-hints . wm-hints-p) + (wm-size-hints . wm-size-hints-p) + )) + +;; This (if (and ...) t nil) stuff has a purpose -- it lets the old +;; sun4 compiler opencode the `and'. + +#-(version>= 4 1 devel 16) +(defun card8p (x) + (declare (optimize (speed 3) (safety 0)) + (fixnum x)) + (if (and (excl:fixnump x) (> #.(expt 2 8) x) (>= x 0)) + t + nil)) + +#-(version>= 4 1 devel 16) +(defun card16p (x) + (declare (optimize (speed 3) (safety 0)) + (fixnum x)) + (if (and (excl:fixnump x) (> #.(expt 2 16) x) (>= x 0)) + t + nil)) + +#-(version>= 4 1 devel 16) +(defun card29p (x) + (declare (optimize (speed 3) (safety 0))) + (if (or (and (excl:fixnump x) (>= (the fixnum x) 0)) + (and (excl:bignump x) (> #.(expt 2 29) (the bignum x)) + (>= (the bignum x) 0))) + t + nil)) + +#-(version>= 4 1 devel 16) +(defun card32p (x) + (declare (optimize (speed 3) (safety 0))) + (if (or (and (excl:fixnump x) (>= (the fixnum x) 0)) + (and (excl:bignump x) (> #.(expt 2 32) (the bignum x)) + (>= (the bignum x) 0))) + t + nil)) + +#-(version>= 4 1 devel 16) +(defun int8p (x) + (declare (optimize (speed 3) (safety 0)) + (fixnum x)) + (if (and (excl:fixnump x) (> #.(expt 2 7) x) (>= x #.(expt -2 7))) + t + nil)) + +#-(version>= 4 1 devel 16) +(defun int16p (x) + (declare (optimize (speed 3) (safety 0)) + (fixnum x)) + (if (and (excl:fixnump x) (> #.(expt 2 15) x) (>= x #.(expt -2 15))) + t + nil)) + +#-(version>= 4 1 devel 16) +(defun int32p (x) + (declare (optimize (speed 3) (safety 0))) + (if (or (excl:fixnump x) + (and (excl:bignump x) (> #.(expt 2 31) (the bignum x)) + (>= (the bignum x) #.(expt -2 31)))) + t + nil)) + +;; This one can be handled better by knowing a little about what we're +;; testing for. Plus this version can handle (single-float pi), which +;; is otherwise larger than pi! +(defun anglep (x) + (declare (optimize (speed 3) (safety 0))) + (if (or (and (excl::fixnump x) (>= (the fixnum x) #.(truncate (* -2 pi))) + (<= (the fixnum x) #.(truncate (* 2 pi)))) + (and (excl::single-float-p x) + (>= (the single-float x) #.(float (* -2 pi) 0.0s0)) + (<= (the single-float x) #.(float (* 2 pi) 0.0s0))) + (and (excl::double-float-p x) + (>= (the double-float x) #.(float (* -2 pi) 0.0d0)) + (<= (the double-float x) #.(float (* 2 pi) 0.0d0)))) + t + nil)) + +(eval-when (load eval) + #+(version>= 4 1 devel 16) + (mapcar #'(lambda (elt) (excl:add-typep-transformer (car elt) (cdr elt))) + type-pred-alist) + #-(version>= 4 1 devel 16) + (nconc excl::type-pred-alist type-pred-alist)) + + +;; Return t if there is a character available for reading or on error, +;; otherwise return nil. +(defun fd-char-avail-p (fd) + (multiple-value-bind (available-p errcode) + (comp::.primcall-sargs 'sys::filesys excl::fs-char-avail fd) + (excl:if* errcode + then t + else available-p))) + +(defmacro with-interrupt-checking-on (&body body) + `(locally (declare (optimize (safety 1))) + ,@body)) + +;; Read from the given fd into 'vector', which has element type card8. +;; Start storing at index 'start-index' and read exactly 'length' bytes. +;; Return t if an error or eof occurred, nil otherwise. +(defun fd-read-bytes (fd vector start-index length) + (declare (fixnum fd start-index length) + (type (simple-array (unsigned-byte 8) (*)) vector)) + (with-interrupt-checking-on + (do ((rest length)) + ((eq 0 rest) nil) + (declare (fixnum rest)) + (multiple-value-bind (numread errcode) + (comp::.primcall-sargs 'sys::filesys excl::fs-read-bytes fd vector + start-index rest) + (declare (fixnum numread)) + (excl:if* errcode + then (if (not (eq errcode + excl::*error-code-interrupted-system-call*)) + (return t)) + elseif (eq 0 numread) + then (return t) + else (decf rest numread) + (incf start-index numread)))))) + + +(when (plusp (ff:get-entry-points + (make-array 1 :initial-contents + (list (ff:convert-to-lang "fd_wait_for_input"))) + (make-array 1 :element-type '(unsigned-byte 32)))) + (ff:remove-entry-point (ff:convert-to-lang "fd_wait_for_input")) + (load "excldep.o")) + +(when (plusp (ff:get-entry-points + (make-array 1 :initial-contents + (list (ff:convert-to-lang "connect_to_server"))) + (make-array 1 :element-type '(unsigned-byte 32)))) + (ff:remove-entry-point (ff:convert-to-lang "connect_to_server" :language :c)) + (load "socket.o")) + +(ff:defforeign-list `((connect-to-server + :entry-point + ,(ff:convert-to-lang "connect_to_server") + :return-type :fixnum + :arg-checking nil + :arguments (string fixnum)) + (fd-wait-for-input + :entry-point ,(ff:convert-to-lang "fd_wait_for_input") + :return-type :fixnum + :arg-checking nil + :call-direct t + :callback nil + :allow-other-keys t + :arguments (fixnum fixnum)))) + + +;; special patch for CLX (various process fixes) +;; patch1000.2 + +(eval-when (compile load eval) + (unless (find-package :patch) + (make-package :patch :use '(:lisp :excl)))) + +(in-package :patch) + +(defvar *patches* nil) + +#+allegro +(eval-when (compile eval load) + (when (and (= excl::cl-major-version-number 3) + (or (= excl::cl-minor-version-number 0) + (and (= excl::cl-minor-version-number 1) + excl::cl-generation-number + (< excl::cl-generation-number 9)))) + (push :clx-r4-process-patches *features*))) + +#+clx-r4-process-patches +(push (cons 1000.2 "special patch for CLX (various process fixes)") + *patches*) + + +(in-package :mp) + +#+clx-r4-process-patches +(export 'wait-for-input-available) + + +#+clx-r4-process-patches +(defun with-timeout-event (seconds fnc args) + (unless *scheduler-stack-group* (start-scheduler)) ;[spr670] + (let ((clock-event (make-clock-event))) + (when (<= seconds 0) (setq seconds 0)) + (multiple-value-bind (secs msecs) (truncate seconds) + ;; secs is now a nonegative integer, and msecs is either fixnum zero + ;; or else something interesting. + (unless (eq 0 msecs) + (setq msecs (truncate (* 1000.0 msecs)))) + ;; Now msecs is also a nonnegative fixnum. + (multiple-value-bind (now mnow) (excl::cl-internal-real-time) + (incf secs now) + (incf msecs mnow) + (when (>= msecs 1000) + (decf msecs 1000) + (incf secs)) + (unless (excl:fixnump secs) (setq secs most-positive-fixnum)) + (setf (clock-event-secs clock-event) secs + (clock-event-msecs clock-event) msecs + (clock-event-function clock-event) fnc + (clock-event-args clock-event) args))) + clock-event)) + + +#+clx-r4-process-patches +(defmacro with-timeout ((seconds &body timeout-body) &body body) + `(let* ((clock-event (with-timeout-event ,seconds + #'process-interrupt + (cons *current-process* + '(with-timeout-internal)))) + (excl::*without-interrupts* t) + ret) + (unwind-protect + ;; Warning: Branch tensioner better not reorder this code! + (setq ret (catch 'with-timeout-internal + (add-to-clock-queue clock-event) + (let ((excl::*without-interrupts* nil)) + (multiple-value-list (progn ,@body))))) + (excl:if* (eq ret 'with-timeout-internal) + then (let ((excl::*without-interrupts* nil)) + (setq ret (multiple-value-list (progn ,@timeout-body)))) + else (remove-from-clock-queue clock-event))) + (values-list ret))) + + +#+clx-r4-process-patches +(defun process-lock (lock &optional (lock-value *current-process*) + (whostate "Lock") timeout) + (declare (optimize (speed 3))) + (unless (process-lock-p lock) + (error "First argument to PROCESS-LOCK must be a process-lock: ~s" lock)) + (without-interrupts + (excl:if* (null (process-lock-locker lock)) + then (setf (process-lock-locker lock) lock-value) + else (excl:if* timeout + then (excl:if* (or (eq 0 timeout) ;for speed + (zerop timeout)) + then nil + else (with-timeout (timeout) + (process-lock-1 lock lock-value whostate))) + else (process-lock-1 lock lock-value whostate))))) + + +#+clx-r4-process-patches +(defun process-lock-1 (lock lock-value whostate) + (declare (type process-lock lock) + (optimize (speed 3))) + (let ((process *current-process*)) + (declare (type process process)) + (unless process + (error + "PROCESS-LOCK may not be called on the scheduler's stack group.")) + (loop (unless (process-lock-locker lock) + (return (setf (process-lock-locker lock) lock-value))) + (push process (process-lock-waiting lock)) + (let ((saved-whostate (process-whostate process))) + (unwind-protect + (progn (setf (process-whostate process) whostate) + (process-add-arrest-reason process lock)) + (setf (process-whostate process) saved-whostate)))))) + + +#+clx-r4-process-patches +(defun process-wait (whostate function &rest args) + (declare (optimize (speed 3))) + ;; Run the wait function once here both for efficiency and as a + ;; first line check for errors in the function. + (unless (apply function args) + (process-wait-1 whostate function args))) + + +#+clx-r4-process-patches +(defun process-wait-1 (whostate function args) + (declare (optimize (speed 3))) + (let ((process *current-process*)) + (declare (type process process)) + (unless process + (error + "Process-wait may not be called within the scheduler's stack group.")) + (let ((saved-whostate (process-whostate process))) + (unwind-protect + (without-scheduling-internal + (without-interrupts + (setf (process-whostate process) whostate + (process-wait-function process) function + (process-wait-args process) args) + (chain-rem-q process) + (chain-ins-q process *waiting-processes*)) + (process-resume-scheduler nil)) + (setf (process-whostate process) saved-whostate + (process-wait-function process) nil + (process-wait-args process) nil))))) + + +#+clx-r4-process-patches +(defun process-wait-with-timeout (whostate seconds function &rest args) + ;; Now returns T upon completion, NIL upon timeout. -- 6Jun89 smh + ;; [spr1135] [rfe939] Timeout won't throw out of interrupt level code. + ;; -- 28Feb90 smh + ;; Run the wait function once here both for efficiency and as a + ;; first line check for errors in the function. + (excl:if* (apply function args) + then t + else (let ((ret (list nil))) + (without-interrupts + (let ((clock-event + (with-timeout-event seconds #'identity '(nil)))) + (add-to-clock-queue clock-event) + (process-wait-1 whostate + #'(lambda (clock-event function args ret) + (or (null (chain-next clock-event)) + (and (apply function args) + (setf (car ret) 't)))) + (list clock-event function args ret)))) + (car ret)))) + + +;; +;; Returns nil on timeout, otherwise t. +;; +#+clx-r4-process-patches +(defun wait-for-input-available + (stream-or-fd &key (wait-function #'listen) + (whostate "waiting for input") + timeout) + (let ((fd (excl:if* (excl:fixnump stream-or-fd) then stream-or-fd + elseif (streamp stream-or-fd) + then (excl::stream-input-fn stream-or-fd) + else (error "wait-for-input-available expects a stream or file descriptor: ~s" stream-or-fd)))) + ;; At this point fd could be nil, since stream-input-fn returns nil for + ;; streams that are output only, or for certain special purpose streams. + (if fd + (unwind-protect + (progn + (mp::mpwatchfor fd) + (excl:if* timeout + then (mp::process-wait-with-timeout + whostate timeout wait-function stream-or-fd) + else (mp::process-wait whostate wait-function stream-or-fd) + t)) + (mp::mpunwatchfor fd)) + (excl:if* timeout + then (mp::process-wait-with-timeout + whostate timeout wait-function stream-or-fd) + else (mp::process-wait whostate wait-function stream-or-fd) + t)))) diff --git a/fonts.lisp b/fonts.lisp new file mode 100644 index 0000000..c54a42a --- /dev/null +++ b/fonts.lisp @@ -0,0 +1,365 @@ +;;; -*- 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. +;;; + +(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/generalock.lisp b/generalock.lisp new file mode 100644 index 0000000..cbf95a3 --- /dev/null +++ b/generalock.lisp @@ -0,0 +1,72 @@ +;;; -*- Mode: LISP; Syntax: Common-lisp; Package: PROCESS; Base: 10; Lowercase: Yes -*- + +;;; Copyright (C) 1990 Symbolics, Inc. +;;; +;;; 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. +;;; +;;; Symbolics, Inc. provides this software "as is" without +;;; express or implied warranty. + +(defflavor xlib::clx-lock () (simple-recursive-normal-lock) + (:init-keywords :flavor)) + +(defwhopper (lock-internal xlib::clx-lock) (lock-argument) + (catch 'timeout + (continue-whopper lock-argument))) + +(defmethod (lock-block-internal xlib::clx-lock) (lock-argument) + (declare (dbg:locking-function describe-process-lock-for-debugger self)) + (when (null waiter-queue) + (setf waiter-queue (make-scheduler-queue :name name)) + (setf timer (create-timer-call #'lock-timer-expired `(,self) :name name))) + (let ((process (lock-argument-process lock-argument))) + (unwind-protect + (progn + (lock-map-over-conflicting-owners + self lock-argument + #'(lambda (other-lock-arg) + (add-promotion process lock-argument + (lock-argument-process other-lock-arg) other-lock-arg))) + (unless (timer-pending-p timer) + (when (and (safe-to-use-timers %real-current-process) + (not dbg:*debugger-might-have-system-problems*)) + (reset-timer-relative-timer-units timer *lock-timer-interval*))) + (assert (store-conditional (locf latch) process nil)) + (sys:with-aborts-enabled (lock-latch) + (let ((timeout (lock-argument-getf lock-argument :timeout nil))) + (cond ((null timeout) + (promotion-block waiter-queue name #'lock-lockable self lock-argument)) + ((and (plusp timeout) + (using-resource (timer process-block-timers) + ;; Yeah, we know about the internal representation + ;; of timers here. + (setf (car (timer-args timer)) %real-current-process) + (with-scheduler-locked + (reset-timer-relative timer timeout) + (flet ((lock-lockable-or-timeout (timer lock lock-argument) + (or (not (timer-pending-p timer)) + (lock-lockable lock lock-argument)))) + (let ((priority (process-process-priority *current-process*))) + (if (ldb-test %%scheduler-priority-preemption-field priority) + (promotion-block waiter-queue name + #'lock-lockable-or-timeout + timer self lock-argument) + ;; Change to preemptive priority so that when + ;; unlock-internal wakes us up so we can have the lock, + ;; we will really wake up right away + (with-process-priority + (dpb 1 %%scheduler-priority-preemption-field + priority) + (promotion-block waiter-queue name + #'lock-lockable-or-timeout + timer self lock-argument))))) + (lock-lockable self lock-argument))))) + (t (throw 'timeout nil)))))) + (unless (store-conditional (locf latch) nil process) + (lock-latch-wait-internal self)) + (remove-promotions process lock-argument)))) + +(compile-flavor-methods xlib::clx-lock) diff --git a/graphics.lisp b/graphics.lisp new file mode 100644 index 0000000..16c9918 --- /dev/null +++ b/graphics.lisp @@ -0,0 +1,447 @@ +;;; -*- 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. +;;; + +(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/input.lisp b/input.lisp new file mode 100644 index 0000000..449c773 --- /dev/null +++ b/input.lisp @@ -0,0 +1,1887 @@ +;;; -*- 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 + +(in-package :xlib) + +;; Event Resource +(defvar *event-free-list* nil) ;; List of unused (processed) events + +(eval-when (eval compile load) +(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 load eval) + (setq *extensions* (cons (list ',name-symbol ',event-list ',errors) + (delete ',name-symbol *extensions* :key #'car)))))) + +(eval-when (compile eval load) +(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 eval load) +(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) + #+clx-ansi-common-lisp + (dynamic-extent predicate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + (apply #'process-block "CLX Input Lock" + #'(lambda (display predicate &rest predicate-args) + (declare (type display display) + (dynamic-extent predicate-args) + (type function predicate) + #+clx-ansi-common-lisp + (dynamic-extent predicate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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 (eval compile load) + (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) + #+clx-ansi-common-lisp + (dynamic-extent handler) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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 (member :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) + ((member16 :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) + #+clx-ansi-common-lisp + (dynamic-extent handler) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg #+Genera * #-Genera 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 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 (eval compile load) +(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)))))) + +#-(or clx-ansi-common-lisp excl lcl3.0 CMU) +(define-condition request-error (x-error) + ((display :reader request-error-display) + (error-key :reader request-error-error-key) + (major :reader request-error-major) + (minor :reader request-error-minor) + (sequence :reader request-error-sequence) + (current-sequence :reader request-error-current-sequence) + (asynchronous :reader request-error-asynchronous)) + (:report report-request-error)) + +(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. +#+(or clx-ansi-common-lisp excl lcl3.0 CMU) +(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/keysyms.lisp b/keysyms.lisp new file mode 100644 index 0000000..96d160b --- /dev/null +++ b/keysyms.lisp @@ -0,0 +1,408 @@ +;;; -*- 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. +;;; + +(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 + ) + +#+(or lispm excl) +(progn ;; Nonstandard characters + (define-keysym #\escape (keysym 255 027)) ; :tty + ) + +#+ti +(progn + (define-keysym #\Inverted-exclamation-mark 161) + (define-keysym #\american-cent-sign 162) + (define-keysym #\british-pound-sign 163) + (define-keysym #\Currency-sign 164) + (define-keysym #\Japanese-yen-sign 165) + (define-keysym #\Yen 165) + (define-keysym #\Broken-bar 166) + (define-keysym #\Section-symbol 167) + (define-keysym #\Section 167) + (define-keysym #\Diaresis 168) + (define-keysym #\Umlaut 168) + (define-keysym #\Copyright-sign 169) + (define-keysym #\Copyright 169) + (define-keysym #\Feminine-ordinal-indicator 170) + (define-keysym #\Angle-quotation-left 171) + (define-keysym #\Soft-hyphen 173) + (define-keysym #\Shy 173) + (define-keysym #\Registered-trademark 174) + (define-keysym #\Macron 175) + (define-keysym #\Degree-sign 176) + (define-keysym #\Ring 176) + (define-keysym #\Plus-minus-sign 177) + (define-keysym #\Superscript-2 178) + (define-keysym #\Superscript-3 179) + (define-keysym #\Acute-accent 180) + (define-keysym #\Greek-mu 181) + (define-keysym #\Paragraph-symbol 182) + (define-keysym #\Paragraph 182) + (define-keysym #\Pilcrow-sign 182) + (define-keysym #\Middle-dot 183) + (define-keysym #\Cedilla 184) + (define-keysym #\Superscript-1 185) + (define-keysym #\Masculine-ordinal-indicator 186) + (define-keysym #\Angle-quotation-right 187) + (define-keysym #\Fraction-1/4 188) + (define-keysym #\One-quarter 188) + (define-keysym #\Fraction-1/2 189) + (define-keysym #\One-half 189) + (define-keysym #\Fraction-3/4 190) + (define-keysym #\Three-quarters 190) + (define-keysym #\Inverted-question-mark 191) + (define-keysym #\Multiplication-sign 215) + (define-keysym #\Eszet 223) + (define-keysym #\Division-sign 247) +) + +#+ti +(progn ;; There are no 7-bit ascii representations for the following + ;; European characters, so use int-char to create them to ensure + ;; nothing is lost while sending files through the mail. + (define-keysym (int-char 192) 192 :lowercase 224) + (define-keysym (int-char 193) 193 :lowercase 225) + (define-keysym (int-char 194) 194 :lowercase 226) + (define-keysym (int-char 195) 195 :lowercase 227) + (define-keysym (int-char 196) 196 :lowercase 228) + (define-keysym (int-char 197) 197 :lowercase 229) + (define-keysym (int-char 198) 198 :lowercase 230) + (define-keysym (int-char 199) 199 :lowercase 231) + (define-keysym (int-char 200) 200 :lowercase 232) + (define-keysym (int-char 201) 201 :lowercase 233) + (define-keysym (int-char 202) 202 :lowercase 234) + (define-keysym (int-char 203) 203 :lowercase 235) + (define-keysym (int-char 204) 204 :lowercase 236) + (define-keysym (int-char 205) 205 :lowercase 237) + (define-keysym (int-char 206) 206 :lowercase 238) + (define-keysym (int-char 207) 207 :lowercase 239) + (define-keysym (int-char 208) 208 :lowercase 240) + (define-keysym (int-char 209) 209 :lowercase 241) + (define-keysym (int-char 210) 210 :lowercase 242) + (define-keysym (int-char 211) 211 :lowercase 243) + (define-keysym (int-char 212) 212 :lowercase 244) + (define-keysym (int-char 213) 213 :lowercase 245) + (define-keysym (int-char 214) 214 :lowercase 246) + (define-keysym (int-char 215) 215) + (define-keysym (int-char 216) 216 :lowercase 248) + (define-keysym (int-char 217) 217 :lowercase 249) + (define-keysym (int-char 218) 218 :lowercase 250) + (define-keysym (int-char 219) 219 :lowercase 251) + (define-keysym (int-char 220) 220 :lowercase 252) + (define-keysym (int-char 221) 221 :lowercase 253) + (define-keysym (int-char 222) 222 :lowercase 254) + (define-keysym (int-char 223) 223) + (define-keysym (int-char 224) 224) + (define-keysym (int-char 225) 225) + (define-keysym (int-char 226) 226) + (define-keysym (int-char 227) 227) + (define-keysym (int-char 228) 228) + (define-keysym (int-char 229) 229) + (define-keysym (int-char 230) 230) + (define-keysym (int-char 231) 231) + (define-keysym (int-char 232) 232) + (define-keysym (int-char 233) 233) + (define-keysym (int-char 234) 234) + (define-keysym (int-char 235) 235) + (define-keysym (int-char 236) 236) + (define-keysym (int-char 237) 237) + (define-keysym (int-char 238) 238) + (define-keysym (int-char 239) 239) + (define-keysym (int-char 240) 240) + (define-keysym (int-char 241) 241) + (define-keysym (int-char 242) 242) + (define-keysym (int-char 243) 243) + (define-keysym (int-char 244) 244) + (define-keysym (int-char 245) 245) + (define-keysym (int-char 246) 246) + (define-keysym (int-char 247) 247) + (define-keysym (int-char 248) 248) + (define-keysym (int-char 249) 249) + (define-keysym (int-char 250) 250) + (define-keysym (int-char 251) 251) + (define-keysym (int-char 252) 252) + (define-keysym (int-char 253) 253) + (define-keysym (int-char 254) 254) + (define-keysym (int-char 255) 255) + ) + +#+lispm ;; Nonstandard characters +(progn + (define-keysym #\center-dot (keysym 183)) ; :latin-1 + (define-keysym #\down-arrow (keysym 008 254)) ; :technical + (define-keysym #\alpha (keysym 007 225)) ; :greek + (define-keysym #\beta (keysym 007 226)) ; :greek + (define-keysym #\and-sign (keysym 008 222)) ; :technical + (define-keysym #\not-sign (keysym 172)) ; :latin-1 + (define-keysym #\epsilon (keysym 007 229)) ; :greek + (define-keysym #\pi (keysym 007 240)) ; :greek + (define-keysym #\lambda (keysym 007 235)) ; :greek + (define-keysym #\gamma (keysym 007 227)) ; :greek + (define-keysym #\delta (keysym 007 228)) ; :greek + (define-keysym #\up-arrow (keysym 008 252)) ; :technical + (define-keysym #\plus-minus (keysym 177)) ; :latin-1 + (define-keysym #\infinity (keysym 008 194)) ; :technical + (define-keysym #\partial-delta (keysym 008 239)) ; :technical + (define-keysym #\left-horseshoe (keysym 011 218)) ; :apl + (define-keysym #\right-horseshoe (keysym 011 216)) ; :apl + (define-keysym #\up-horseshoe (keysym 011 195)) ; :apl + (define-keysym #\down-horseshoe (keysym 011 214)) ; :apl + (define-keysym #\double-arrow (keysym 008 205)) ; :technical + (define-keysym #\left-arrow (keysym 008 251)) ; :technical + (define-keysym #\right-arrow (keysym 008 253)) ; :technical + (define-keysym #\not-equals (keysym 008 189)) ; :technical + (define-keysym #\less-or-equal (keysym 008 188)) ; :technical + (define-keysym #\greater-or-equal (keysym 008 190)) ; :technical + (define-keysym #\equivalence (keysym 008 207)) ; :technical + (define-keysym #\or-sign (keysym 008 223)) ; :technical + (define-keysym #\integral (keysym 008 191)) ; :technical +;; break isn't null +;; (define-keysym #\null (keysym 255 107)) ; :function + (define-keysym #\clear-input (keysym 255 011)) ; :tty + (define-keysym #\help (keysym 255 106)) ; :function + (define-keysym #\refresh (keysym 255 097)) ; :function + (define-keysym #\abort (keysym 255 105)) ; :function + (define-keysym #\resume (keysym 255 098)) ; :function + (define-keysym #\end (keysym 255 087)) ; :cursor +;;#\universal-quantifier +;;#\existential-quantifier +;;#\circle-plus +;;#\circle-cross same as #\circle-x + ) + +#+genera +(progn +;;#\network +;;#\symbol-help + (define-keysym #\lozenge (keysym 009 224)) ; :special + (define-keysym #\suspend (keysym 255 019)) ; :tty + (define-keysym #\function (keysym 255 032)) ; :function + (define-keysym #\square (keysym 010 231)) ; :publishing + (define-keysym #\circle (keysym 010 230)) ; :publishing + (define-keysym #\triangle (keysym 010 232)) ; :publishing + (define-keysym #\scroll (keysym 255 086)) ; :cursor + (define-keysym #\select (keysym 255 096)) ; :function + (define-keysym #\complete (keysym 255 104)) ; :function + ) + +#+ti +(progn + (define-keysym #\terminal (keysym 255 032)) ; :function + (define-keysym #\system (keysym 255 096)) ; :function + (define-keysym #\center-arrow (keysym 255 80)) + (define-keysym #\left-arrow (keysym 255 081)) ; :cursor + (define-keysym #\up-arrow (keysym 255 082)) ; :cursor + (define-keysym #\right-arrow (keysym 255 083)) ; :cursor + (define-keysym #\down-arrow (keysym 255 084)) ; :cursor + (define-keysym #\end (keysym 255 087)) ; :cursor + (define-keysym #\undo (keysym 255 101)) ; :function + (define-keysym #\break (keysym 255 107)) + (define-keysym #\keypad-space (keysym 255 128)) ; :keypad + (define-keysym #\keypad-tab (keysym 255 137)) ; :keypad + (define-keysym #\keypad-enter (keysym 255 141)) ; :keypad + (define-keysym #\f1 (keysym 255 145)) ; :keypad + (define-keysym #\f2 (keysym 255 146)) ; :keypad + (define-keysym #\f3 (keysym 255 147)) ; :keypad + (define-keysym #\f4 (keysym 255 148)) ; :keypad + (define-keysym #\f1 (keysym 255 190)) ; :keypad + (define-keysym #\f2 (keysym 255 191)) ; :keypad + (define-keysym #\f3 (keysym 255 192)) ; :keypad + (define-keysym #\f4 (keysym 255 193)) ; :keypad + (define-keysym #\keypad-plus (keysym 255 171)) ; :keypad + (define-keysym #\keypad-comma (keysym 255 172)) ; :keypad + (define-keysym #\keypad-minus (keysym 255 173)) ; :keypad + (define-keysym #\keypad-period (keysym 255 174)) ; :keypad + (define-keysym #\keypad-0 (keysym 255 176)) ; :keypad + (define-keysym #\keypad-1 (keysym 255 177)) ; :keypad + (define-keysym #\keypad-2 (keysym 255 178)) ; :keypad + (define-keysym #\keypad-3 (keysym 255 179)) ; :keypad + (define-keysym #\keypad-4 (keysym 255 180)) ; :keypad + (define-keysym #\keypad-5 (keysym 255 181)) ; :keypad + (define-keysym #\keypad-6 (keysym 255 182)) ; :keypad + (define-keysym #\keypad-7 (keysym 255 183)) ; :keypad + (define-keysym #\keypad-8 (keysym 255 184)) ; :keypad + (define-keysym #\keypad-9 (keysym 255 185)) ; :keypad + (define-keysym #\keypad-equal (keysym 255 189)) ; :keypad + (define-keysym #\f1 (keysym 255 192)) ; :function + (define-keysym #\f2 (keysym 255 193)) ; :function + (define-keysym #\f3 (keysym 255 194)) ; :function + (define-keysym #\f4 (keysym 255 195)) ; :function + (define-keysym #\network (keysym 255 214)) + (define-keysym #\status (keysym 255 215)) + (define-keysym #\clear-screen (keysym 255 217)) + (define-keysym #\left (keysym 255 218)) + (define-keysym #\middle (keysym 255 219)) + (define-keysym #\right (keysym 255 220)) + (define-keysym #\resume (keysym 255 221)) + (define-keysym #\vt (keysym 009 233)) ; :special ;; same as #\delete + ) + +#+ti +(progn ;; Explorer specific characters + (define-keysym #\Call (keysym 131)) ; :latin-1 + (define-keysym #\Macro (keysym 133)) ; :latin-1 + (define-keysym #\Quote (keysym 142)) ; :latin-1 + (define-keysym #\Hold-output (keysym 143)) ; :latin-1 + (define-keysym #\Stop-output (keysym 144)) ; :latin-1 + (define-keysym #\Center (keysym 156)) ; :latin-1 + (define-keysym #\no-break-space (keysym 160)) ; :latin-1 + + (define-keysym #\circle-plus (keysym 13)) ; :latin-1 + (define-keysym #\universal-quantifier (keysym 20)) ; :latin-1 + (define-keysym #\existential-quantifier (keysym 21)) ; :latin-1 + (define-keysym #\circle-cross (keysym 22)) ; :latin-1 + ) + diff --git a/manager.lisp b/manager.lisp new file mode 100644 index 0000000..4aea40e --- /dev/null +++ b/manager.lisp @@ -0,0 +1,789 @@ +;;; -*- 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. +;;; + +(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))) + +;; Implement the following: +;; (defsetf cut-buffer (display &key (buffer 0) (type :string) (format 8) +;; (transform #'char->card8) (start 0) end) (data) +;; In order to avoid having to pass positional parameters to set-cut-buffer, +;; We've got to do the following. WHAT A PAIN... +#-clx-ansi-common-lisp +(define-setf-method cut-buffer (display &rest option-list) + (declare (dynamic-extent option-list)) + (do* ((options (copy-list option-list)) + (option options (cddr option)) + (store (gensym)) + (dtemp (gensym)) + (temps (list dtemp)) + (values (list display))) + ((endp option) + (values (nreverse temps) + (nreverse values) + (list store) + `(set-cut-buffer ,store ,dtemp ,@options) + `(cut-buffer ,@options))) + (unless (member (car option) '(:buffer :type :format :start :end :transform)) + (error "Keyword arg ~s isn't recognized" (car option))) + (let ((x (gensym))) + (push x temps) + (push (cadr option) values) + (setf (cadr option) x)))) + +(defun + #+clx-ansi-common-lisp (setf cut-buffer) + #-clx-ansi-common-lisp set-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/ms-patch.uu b/ms-patch.uu new file mode 100644 index 0000000..b84726c --- /dev/null +++ b/ms-patch.uu @@ -0,0 +1,57 @@ +begin 666 make-sequence-patch.lbin +M1D%33"!&24Q%.@I&05-,('9ET %682+6T &0 $*F[__$_N__@F5T[3L>T '6<& +ML>T (682+6T )0 $*F[__$_N__@F5T[3L>T *682+6T +0 $*F[__$_N__@F +M5T[3(&[_]+G(9PX@" ( <, !9@ #^B!N__0O* '0J)&T -;7N_^QF &X("[_Z R +M#& +M6(\@;O_T(F@ R1M $&UZ0 '9P @B!N__0B: #(FD R1M $&UZ0 '9RQ" +MIR\.+PU(>@ @+RT .2\N__1\ B1M #TJ:@ 3W/S_X"!M %.Z %3EY8CR)N +M__0B:0 #(&D !R)N__0B:0 #(FD R\I (&[_Y")M $E@!")I ,@"0( <, +M !9P0O#& (L>D !V;F+PE/[O_@N>[_X&<"8%P@;O_DN@ !R1,9P0D; W+PJY[O_<9P)@*D*G+PXO#4AZ " O +M+0 Y+R[_]'P")&T /2IJ !/<_/_4(&T 4[H 5.7D_N_^0@;O_T(F@ R)I +M ,C;O_D B N_^@,@ 1F +M$BUM $T !"IN__Q/[O_X)E=.TR N_^@,@ AG*@R #&D !V;F)$FYRF< (0@ +M+O_H#( (9RQ"IR\.+PU(>@ @+RT .2\N__1\ B1M #TJ:@ 3W/S_W"!M +M %.Z %3EY8CR!N_^RQ[0 59A(M;0 9 0J;O_\3^[_^"973M.Q[0 =9Q:Q +M[0 A9Q M2 $*F[__$_N__@F5T[3+6T )0 $*F[__$_N__@F5T[33^[_Z+GN +M__!G F X0J[_\&<"8#1"IR\.+PU(>@ <+R[_]'P!)&T 72IJ !/<_/_H(&T +M 4[H 5.7BU?__0M; W__!@ /LL+6[_]/_P+6T .?_T? (D;0 ]*FH $R!M +M %/[O_P3N@ !?X"!20N* A465!%4U!%0R@))D]05$E/3D%,* M.3U)-04Q) +M6D5$4#A,* 1,25-4* 1.54Q,3"@&5D5#5$]23 $U#"@-4TE-4$Q%+59%0U1/ +M4DPH#5-)35!,12U35%))3D=,*!)324U03$4M,4))5"U614-43U(H$E-)35!, +M12TR0DE4+59%0U1/4B@24TE-4$Q%+31"250M5D5#5$]2*!)324U03$4M.$)) +M5"U614-43U(H$U-)35!,12TQ-D))5"U614-43U(H$U-)35!,12TS,D))5"U6 +M14-43U(H&5-)35!,12U324=.140M.$))5"U614-43U(H&E-)35!,12U324=. +M140M,39"250M5D5#5$]2*!I324U03$4M4TE'3D5$+3,R0DE4+59%0U1/4B@: +M4TE-4$Q%+5-)3D=,12U&3$]!5"U614-43U),* 935%))3D?^"TPH"D))5"U6 +M14-43U),*!%324U03$4M0DE4+59%0U1/4OX,* A315%514Y#12Y,* )/4OX& +M_@@H"TQ)4U0M3$5.1U1(_AHB.7Y3(&ES(&%N(&EN=F%L:60@;W(@=6YR97-O +M;'9A8FQE(')E7!Echar 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 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 type-error 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 + )) + + +;;; The ANSI Common Lisp way + +#+(and Genera clx-ansi-common-lisp) +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *readtable* si:*ansi-common-lisp-readtable*)) + +#+clx-ansi-common-lisp +(common-lisp:in-package :common-lisp-user) + +#+clx-ansi-common-lisp +(defpackage xlib + (:use common-lisp) + (:size 3000) + #+(or kcl ibcl) (:shadow rational) + #+allegro (:use cltl1) + #+allegro (:import-from excl without-interrupts) + #+excl (:import-from excl arglist) + #+Genera (:import-from zwei indentation) + #+lcl3.0 (:import-from lcl arglist) + #+lispm (:import-from lisp char-bit) + #+lispm (:import-from sys arglist with-stack-list with-stack-list*) + (: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 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/provide.lisp b/provide.lisp new file mode 100644 index 0000000..bf6f3c7 --- /dev/null +++ b/provide.lisp @@ -0,0 +1,56 @@ +;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: Yes; Package: USER; -*- + +;;;; Module definition for CLX + +;;; This file is a Common Lisp Module description, but you will have to edit +;;; it to meet the needs of your site. + +;;; Ideally, this file (or a file that loads this file) should be +;;; located in the system directory that REQUIRE searches. Thus a user +;;; would say +;;; (require :clx) +;;; to load CLX. If there is no such registry, then the user must +;;; put in a site specific +;;; (require :clx ) +;;; + +#-clx-ansi-common-lisp +(in-package :user) + +#+clx-ansi-common-lisp +(in-package :common-lisp-user) + +#-clx-ansi-common-lisp +(provide :clx) + +(defvar *clx-source-pathname* + (pathname "/src/local/clx/*.l")) + +(defvar *clx-binary-pathname* + (let ((lisp + (or #+lucid "lucid" + #+akcl "akcl" + #+kcl "kcl" + #+ibcl "ibcl" + (error "Can't provide CLX for this lisp."))) + (architecture + (or #+(or sun3 (and sun (or mc68000 mc68020))) "sun3" + #+(or sun4 sparc) "sparc" + #+(and hp (or mc68000 mc68020)) "hp9000s300" + #+vax "vax" + #+prime "prime" + #+sunrise "sunrise" + #+ibm-rt-pc "ibm-rt-pc" + #+mips "mips" + #+prism "prism" + (error "Can't provide CLX for this architecture.")))) + (pathname (format nil "/src/local/clx/~A.~A/" lisp architecture)))) + +(defvar *compile-clx* + nil) + +(load (merge-pathnames "defsystem" *clx-source-pathname*)) + +(if *compile-clx* + (compile-clx *clx-source-pathname* *clx-binary-pathname*) + (load-clx *clx-binary-pathname*)) diff --git a/requests.lisp b/requests.lisp new file mode 100644 index 0000000..facb009 --- /dev/null +++ b/requests.lisp @@ -0,0 +1,1491 @@ +;;; -*- 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. +;;; + +(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 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 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 0)) + (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 (member :none :pointer-root) window) + (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/resource.lisp b/resource.lisp new file mode 100644 index 0000000..7526868 --- /dev/null +++ b/resource.lisp @@ -0,0 +1,700 @@ +;;; -*- Mode:Common-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. +;;; + +(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) + #+explorer (:callable-constructors nil) + ) + (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 (#-allegro string-upcase #+allegro correct-case + (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) + (symbol 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 symbol 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 symbol name)) + (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 symbol 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) + #+clx-ansi-common-lisp + (dynamic-extent function) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + #+clx-ansi-common-lisp + (dynamic-extent function) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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/sockcl.lisp b/sockcl.lisp new file mode 100644 index 0000000..26c0eda --- /dev/null +++ b/sockcl.lisp @@ -0,0 +1,163 @@ +;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- + +;;;; Server Connection for kcl and ibcl + +;;; Copyright (C) 1987, 1989 Massachussetts Institute of Technology +;;; +;;; 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. +;;; +;;; Massachussetts Institute of Technology provides this software "as is" +;;; without express or implied warranty. +;;; + +;;; Adapted from code by Roman Budzianowski - Project Athena/MIT + +;;; make-two-way-stream is probably not a reasonable thing to do. +;;; A close on a two way stream probably does not close the substreams. +;;; I presume an :io will not work (maybe because it uses 1 buffer?). +;;; There should be some fast io (writes and reads...). + +;;; Compile this file with compile-file. +;;; Load it with (si:faslink "sockcl.o" "socket.o -lc") + +(in-package :xlib) + +;;; The cmpinclude.h file does not have this type definition from +;;; /h/object.h. We include it here so the +;;; compile-file will work without figuring out where the distribution +;;; directory is located. +;;; +(CLINES " +enum smmode { /* stream mode */ + smm_input, /* input */ + smm_output, /* output */ + smm_io, /* input-output */ + smm_probe, /* probe */ + smm_synonym, /* synonym */ + smm_broadcast, /* broadcast */ + smm_concatenated, /* concatenated */ + smm_two_way, /* two way */ + smm_echo, /* echo */ + smm_string_input, /* string input */ + smm_string_output, /* string output */ + smm_user_defined /* for user defined */ +}; +") + +#-akcl +(CLINES " +struct stream { + short t, m; + FILE *sm_fp; /* file pointer */ + object sm_object0; /* some object */ + object sm_object1; /* some object */ + int sm_int0; /* some int */ + int sm_int1; /* some int */ + short sm_mode; /* stream mode */ + /* of enum smmode */ +}; +") + + +;;;; Connect to the server. + +;;; A lisp string is not a reasonable type for C, so copy the characters +;;; out and then call connect_to_server routine defined in socket.o + +(CLINES " +int +konnect_to_server(host,display) + object host; /* host name */ + int display; /* display number */ +{ + int fd; /* file descriptor */ + int i; + char hname[BUFSIZ]; + FILE *fout, *fin; + + if (host->st.st_fillp > BUFSIZ - 1) + too_long_file_name(host); + for (i = 0; i < host->st.st_fillp; i++) + hname[i] = host->st.st_self[i]; + hname[i] = '\\0'; /* doubled backslash for lisp */ + + fd = connect_to_server(hname,display); + + return(fd); +} +") + +(defentry konnect-to-server (object int) (int "konnect_to_server")) + + +;;;; Make a one-way stream from a file descriptor. + +(CLINES " +object +konnect_stream(host,fd,flag,elem) + object host; /* not really used */ + int fd; /* file descriptor */ + int flag; /* 0 input, 1 output */ + object elem; /* 'string-char */ +{ + struct stream *stream; + char *mode; /* file open mode */ + FILE *fp; /* file pointer */ + enum smmode smm; /* lisp mode (a short) */ + vs_mark; + + switch(flag){ + case 0: + smm = smm_input; + mode = \"r\"; + break; + case 1: + smm = smm_output; + mode = \"w\"; + break; + default: + FEerror(\"konnect_stream : wrong mode\"); + } + + fp = fdopen(fd,mode); + + if (fp == NULL) { + stream = Cnil; + vs_push(stream); + } else { + stream = alloc_object(t_stream); + stream->sm_mode = (short)smm; + stream->sm_fp = fp; + stream->sm_object0 = elem; + stream->sm_object1 = host; + stream->sm_int0 = stream->sm.sm_int1 = 0; + vs_push(stream); + setbuf(fp, alloc_contblock(BUFSIZ)); + } + vs_reset; + return(stream); +} +") + +(defentry konnect-stream (object int int object) (object "konnect_stream")) + + +;;;; Open an X stream + +(defun open-socket-stream (host display) + (when (not (and (typep host 'string) ; sanity check the arguments + (typep display 'fixnum))) + (error "Host ~s or display ~s are bad." host display)) + + (let ((fd (konnect-to-server host display))) ; get a file discriptor + (if (< fd 0) + NIL + (let ((stream-in (konnect-stream host fd 0 'string-char)) ; input + (stream-out (konnect-stream host fd 1 'string-char))) ; output + (if (or (null stream-in) (null stream-out)) + (error "Could not make i/o streams for fd ~d." fd)) + (make-two-way-stream stream-in stream-out)) + ))) diff --git a/socket.c b/socket.c new file mode 100644 index 0000000..b2eaf39 --- /dev/null +++ b/socket.c @@ -0,0 +1,153 @@ +/* Copyright Massachusetts Institute of Technology 1988 */ +/* + * THIS IS AN OS DEPENDENT FILE! It should work on 4.2BSD derived + * systems. VMS and System V should plan to have their own version. + * + * This code was cribbed from lib/X/XConnDis.c. + * Compile using + * % cc -c socket.c -DUNIXCONN + */ + +#include +#include +#include +#include +#include +#include +#include +#include +#ifndef hpux +#include +#endif + +extern int errno; /* Certain (broken) OS's don't have this */ + /* decl in errno.h */ + +#ifdef UNIXCONN +#include +#ifndef X_UNIX_PATH +#ifdef hpux +#define X_UNIX_PATH "/usr/spool/sockets/X11/" +#define OLD_UNIX_PATH "/tmp/.X11-unix/X" +#else /* hpux */ +#define X_UNIX_PATH "/tmp/.X11-unix/X" +#endif /* hpux */ +#endif /* X_UNIX_PATH */ +#endif /* UNIXCONN */ + +#ifndef hpux +void bcopy(); +#endif /* hpux */ + +/* + * Attempts to connect to server, given host and display. Returns file + * descriptor (network socket) or 0 if connection fails. + */ + +int connect_to_server (host, display) + char *host; + int display; +{ + struct sockaddr_in inaddr; /* INET socket address. */ + struct sockaddr *addr; /* address to connect to */ + struct hostent *host_ptr; + int addrlen; /* length of address */ +#ifdef UNIXCONN + struct sockaddr_un unaddr; /* UNIX socket address. */ +#endif + extern char *getenv(); + extern struct hostent *gethostbyname(); + int fd; /* Network socket */ + { +#ifdef UNIXCONN + if ((host[0] == '\0') || (strcmp("unix", host) == 0)) { + /* Connect locally using Unix domain. */ + unaddr.sun_family = AF_UNIX; + (void) strcpy(unaddr.sun_path, X_UNIX_PATH); + (void) sprintf(&unaddr.sun_path[strlen(unaddr.sun_path)], "%d", display); + addr = (struct sockaddr *) &unaddr; + addrlen = strlen(unaddr.sun_path) + 2; + /* + * Open the network connection. + */ + if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0) { +#ifdef hpux /* this is disgusting */ /* cribbed from X11R4 xlib source */ + if (errno == ENOENT) { /* No such file or directory */ + (void) sprintf(unaddr.sun_path, "%s%d", OLD_UNIX_PATH, display); + addrlen = strlen(unaddr.sun_path) + 2; + if ((fd = socket ((int) addr->sa_family, SOCK_STREAM, 0)) < 0) + return(-1); /* errno set by most recent system call. */ + } else +#endif /* hpux */ + return(-1); /* errno set by system call. */ + } + } else +#endif /* UNIXCONN */ + { + /* Get the statistics on the specified host. */ + if ((inaddr.sin_addr.s_addr = inet_addr(host)) == -1) + { + if ((host_ptr = gethostbyname(host)) == NULL) + { + /* No such host! */ + errno = EINVAL; + return(-1); + } + /* Check the address type for an internet host. */ + if (host_ptr->h_addrtype != AF_INET) + { + /* Not an Internet host! */ + errno = EPROTOTYPE; + return(-1); + } + /* Set up the socket data. */ + inaddr.sin_family = host_ptr->h_addrtype; +#ifdef hpux + (void) memcpy((char *)&inaddr.sin_addr, + (char *)host_ptr->h_addr, + sizeof(inaddr.sin_addr)); +#else /* hpux */ + (void) bcopy((char *)host_ptr->h_addr, + (char *)&inaddr.sin_addr, + sizeof(inaddr.sin_addr)); +#endif /* hpux */ + } + else + { + inaddr.sin_family = AF_INET; + } + addr = (struct sockaddr *) &inaddr; + addrlen = sizeof (struct sockaddr_in); + inaddr.sin_port = display + X_TCP_PORT; + inaddr.sin_port = htons(inaddr.sin_port); + /* + * Open the network connection. + */ + if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0){ + return(-1); /* errno set by system call. */} + /* make sure to turn off TCP coalescence */ +#ifdef TCP_NODELAY + { + int mi = 1; + setsockopt (fd, IPPROTO_TCP, TCP_NODELAY, &mi, sizeof (int)); + } +#endif + } + + /* + * Changed 9/89 to retry connection if system call was interrupted. This + * is necessary for multiprocessing implementations that use timers, + * since the timer results in a SIGALRM. -- jdi + */ + while (connect(fd, addr, addrlen) == -1) { + if (errno != EINTR) { + (void) close (fd); + return(-1); /* errno set by system call. */ + } + } + } + /* + * Return the id if the connection succeeded. + */ + return(fd); +} diff --git a/test/image.lisp b/test/image.lisp new file mode 100644 index 0000000..e375f01 --- /dev/null +++ b/test/image.lisp @@ -0,0 +1,153 @@ +;;; -*- 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))) + (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 (image-x-hot image) border-width)) + (y (- src-y (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/test/trapezoid.lisp b/test/trapezoid.lisp new file mode 100644 index 0000000..7b1a571 --- /dev/null +++ b/test/trapezoid.lisp @@ -0,0 +1,72 @@ +;;; -*- 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/text.lisp b/text.lisp new file mode 100644 index 0000000..56caf9b --- /dev/null +++ b/text.lisp @@ -0,0 +1,1084 @@ +;;; -*- 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. +;;; + +(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 () + #+explorer t + #-explorer + '(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 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. + ;; (returns values: ending-index + ;; (OR null horizontal-motion font) + ;; (OR null translated-width)) + (declare (type sequence src) + (type array-index src-start src-end dst-start) + (type (or null font) font) + (type vector dst) + (inline graphic-char-p)) + (declare (clx-values integer (or null integer font) (or null integer))) + font ;;not used + (if (stringp src) + (do ((i src-start (index+ i 1)) + (j dst-start (index+ j 1)) + (char)) + ((index>= i src-end) + i) + (declare (type array-index i j)) + (if (graphic-char-p (setq char (char src i))) + (setf (aref dst j) (char->card8 char)) + (return i))) + (do ((i src-start (index+ i 1)) + (j dst-start (index+ j 1)) + (elt)) + ((index>= i src-end) + i) + (declare (type array-index i j)) + (setq elt (elt src i)) + (cond ((and (characterp elt) (graphic-char-p elt)) + (setf (aref dst j) (char->card8 elt))) + ((integerp elt) + (setf (aref dst j) elt)) + (t + (return i)))))) + +;; 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) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg #+Genera * #-Genera 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) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg #+Genera * #-Genera 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) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg #+Genera * #-Genera 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) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg #+Genera * #-Genera 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) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg #+Genera * #-Genera 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) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg #+Genera * #-Genera 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) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg 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/translate.lisp b/translate.lisp new file mode 100644 index 0000000..e20ee51 --- /dev/null +++ b/translate.lisp @@ -0,0 +1,559 @@ +;;; -*- 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 eval load) ;; 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 eval load) ;; Required for Symbolics... +(defconstant character-set-switch-keysym (keysym 255 126)) +(defconstant left-shift-keysym (keysym 255 225)) +(defconstant right-shift-keysym (keysym 255 226)) +(defconstant left-control-keysym (keysym 255 227)) +(defconstant right-control-keysym (keysym 255 228)) +(defconstant caps-lock-keysym (keysym 255 229)) +(defconstant shift-lock-keysym (keysym 255 230)) +(defconstant left-meta-keysym (keysym 255 231)) +(defconstant right-meta-keysym (keysym 255 232)) +(defconstant left-alt-keysym (keysym 255 233)) +(defconstant right-alt-keysym (keysym 255 234)) +(defconstant left-super-keysym (keysym 255 235)) +(defconstant right-super-keysym (keysym 255 236)) +(defconstant left-hyper-keysym (keysym 255 237)) +(defconstant 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)))))