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)))))