From fd703282d2df84ad958b1b33128156a10768e021 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Mon, 14 May 1990 14:49:20 +0000 Subject: [PATCH] Initial revision --- clx/CHANGES | 51 + clx/README | 48 + clx/attributes.lisp | 671 ++++++++ clx/buffer.lisp | 1535 +++++++++++++++++ clx/bufmac.lisp | 174 ++ clx/clx.lisp | 1104 +++++++++++++ clx/defsystem.lisp | 603 +++++++ clx/depdefs.lisp | 654 ++++++++ clx/dependent.lisp | 3064 ++++++++++++++++++++++++++++++++++ clx/display.lisp | 533 ++++++ clx/doc.lisp | 3807 +++++++++++++++++++++++++++++++++++++++++++ clx/exclMakefile | 133 ++ clx/exclREADME | 59 + clx/exclcmac.lisp | 313 ++++ clx/excldefsys.lisp | 186 +++ clx/excldep.c | 73 + clx/excldep.lisp | 514 ++++++ clx/fonts.lisp | 373 +++++ clx/gcontext.lisp | 994 +++++++++++ clx/generalock.lisp | 62 + clx/graphics.lisp | 460 ++++++ clx/image.lisp | 2697 ++++++++++++++++++++++++++++++ clx/input.lisp | 1927 ++++++++++++++++++++++ clx/keysyms.lisp | 408 +++++ clx/macros.lisp | 1078 ++++++++++++ clx/manager.lisp | 851 ++++++++++ clx/ms-patch.uu | 57 + clx/provide.lisp | 41 + clx/requests.lisp | 1590 ++++++++++++++++++ clx/resource.lisp | 713 ++++++++ clx/sockcl.lisp | 163 ++ clx/socket.c | 144 ++ clx/text.lisp | 1083 ++++++++++++ clx/translate.lisp | 619 +++++++ 34 files changed, 26782 insertions(+) create mode 100644 clx/CHANGES create mode 100644 clx/README create mode 100644 clx/attributes.lisp create mode 100644 clx/buffer.lisp create mode 100644 clx/bufmac.lisp create mode 100644 clx/clx.lisp create mode 100644 clx/defsystem.lisp create mode 100644 clx/depdefs.lisp create mode 100644 clx/dependent.lisp create mode 100644 clx/display.lisp create mode 100644 clx/doc.lisp create mode 100644 clx/exclMakefile create mode 100644 clx/exclREADME create mode 100644 clx/exclcmac.lisp create mode 100644 clx/excldefsys.lisp create mode 100644 clx/excldep.c create mode 100644 clx/excldep.lisp create mode 100644 clx/fonts.lisp create mode 100644 clx/gcontext.lisp create mode 100644 clx/generalock.lisp create mode 100644 clx/graphics.lisp create mode 100644 clx/image.lisp create mode 100644 clx/input.lisp create mode 100644 clx/keysyms.lisp create mode 100644 clx/macros.lisp create mode 100644 clx/manager.lisp create mode 100644 clx/ms-patch.uu create mode 100644 clx/provide.lisp create mode 100644 clx/requests.lisp create mode 100644 clx/resource.lisp create mode 100644 clx/sockcl.lisp create mode 100644 clx/socket.c create mode 100644 clx/text.lisp create mode 100644 clx/translate.lisp diff --git a/clx/CHANGES b/clx/CHANGES new file mode 100644 index 000000000..def193673 --- /dev/null +++ b/clx/CHANGES @@ -0,0 +1,51 @@ +R4 changes: + +o Numerous bug fixes + +o Multiprocess locking and error reporting made more robust + +o Event queue consing reduced + +o ICCCM support + +R4.1 changes: + +o Fix reported bugs and to include the vendor-specific + bug-fixing and performance-improving patches that I recently received. + +o Code compiled with the R4 CLX will work with the R4.1X CLX, but code + compiled with the R4.1X CLX will NOT work with the R4 CLX. I made an effort + to ensure backward binary compatibility with R4 CLX so that old code doesn't + have to be recompiled to still work. It does have to be recompiled to fix + an event-queue bug, since the fix involved a change to the event-loop macro. + +R4.2 changes: + +o Atoms and visuals are now correctly maintained in a separate namespace from + windows, pixmaps, cursors, fonts, gcontexts, and colormaps. + +o I have made an attempt to make socket code work for kcl and ibcl. I have + akcl here, but not kcl and ibcl, so it's only guesswork that kcl and ibcl + works. + +o compile-clx and load-clx do more pathname merging to work around problems + in some lisp implementations. *default-pathname-defaults* is never bound + anymore. + +o Some ansi common lisp stuff. If you have :ansi-common-lisp on *features*, + CLX will: + + - Use the common-lisp package instead of the lisp package. + + - Use the common lisp condition system, being careful not to stomp on + define-condition and type-error. + + - Use declaim instead of proclaim. + + - Use the dynamic-extent declaration for rest args and closures. + + - Use print-unreadable-object. + +o Code compiled with the R4 and R4.1 CLX will work with the R4.2 CLX, provided + you don't have :ansi-common-lisp on your features list. Code compiled with + the R4.2 CLX will NOT work with the R4 CLX. diff --git a/clx/README b/clx/README new file mode 100644 index 000000000..61696276c --- /dev/null +++ b/clx/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 (xlib:compile-clx) function and loaded with the +(xlib: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 (xlib:compile-clx) function and loaded with the (xlib:load-clx) form. + + + +For more information, see defsystem.l and provide.l. + diff --git a/clx/attributes.lisp b/clx/attributes.lisp new file mode 100644 index 000000000..59be1388c --- /dev/null +++ b/clx/attributes.lisp @@ -0,0 +1,671 @@ +;;; -*- 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) + +(export '( + with-state + window-visual-info + window-visual + window-class + window-background ;; setf only + window-border + 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-cursor + window-colormap-installed-p + window-all-event-masks + window-map-state + + drawable-root + drawable-x + drawable-y + drawable-width + drawable-height + drawable-depth + drawable-border-width + + window-priority + )) + +(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 (values resource-id)) + (with-attributes (window :sizes 32) + (resource-id-get 8))) + +(defun window-visual-info (window) + (declare (type window window)) + (declare (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (values boolean)) + (with-attributes (window :sizes 8) + (boolean-get 25))) + +(defun window-all-event-masks (window) + (declare (type window window)) + (declare (values mask32)) + (with-attributes (window :sizes 32) + (card32-get 32))) + +(defun window-map-state (window) + (declare (type window window)) + (declare (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 (values window)) + (with-geometry (drawable :sizes 32) + (window-get 8 (drawable-display drawable)))) + +(defun drawable-x (drawable) + ;; setf'able + (declare (type drawable drawable)) + (declare (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 (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 (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 (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 (values card8)) + (with-geometry (drawable :sizes 8) + (card8-get 1))) + +(defun drawable-border-width (drawable) + ;; setf'able + (declare (type drawable drawable)) + (declare (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/clx/buffer.lisp b/clx/buffer.lisp new file mode 100644 index 000000000..f77b310ad --- /dev/null +++ b/clx/buffer.lisp @@ -0,0 +1,1535 @@ +;;; -*- 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)) + #+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) + (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) + (array-register buffer-bbuf)) + #+clx-overlapping-arrays + ,@(append + (when (member 8 sizes) + '((declare (type buffer-bytes buffer-bbuf) + (array-register buffer-bbuf)))) + (when (member 16 sizes) + '((declare (type array-index buffer-woffset)) + (declare (type buffer-words buffer-wbuf) + (array-register buffer-wbuf)))) + (when (member 32 sizes) + '((declare (type array-index buffer-loffset)) + (declare (type buffer-longs buffer-lbuf) + (array-register 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))) + (macrolet ((%buffer-sizes () ',sizes)) + ,@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) + (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) + (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 boolean multiple-reply)) + (declare (type function request-function reply-function) + (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 (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 (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 (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) + (downward-funarg transform)) + (if transform + (flet ((card8->char->transform (v) + (declare (type card8 v)) + (funcall transform (card8->char v)))) + #+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) + (type cons 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) + (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) + (type cons 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) + (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 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)) + (with-vector (data vector) + (with-buffer-input (reply-buffer :sizes (8)) + (buffer-replace data buffer-bbuf start (index+ start nitems) 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)) + (declare (type (function (card8) t) transform) + (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 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) + (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) + (downward-funarg transform)) + (if transform + (flet ((card8->int8->transform (v) + (declare (type card8 v)) + (funcall transform (card8->int8 v)))) + #+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) + (type cons 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) + (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) + (type cons 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 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) + (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 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)) + (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 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)) + (declare (type (function (card16) t) transform) + (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 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) + (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) + (downward-funarg transform)) + (if transform + (flet ((card16->int16->transform (v) + (declare (type card16 v)) + (funcall transform (card16->int16 v)))) + #+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) + (type cons 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) + (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) + (type cons 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 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) + (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 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)) + (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 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)) + (declare (type (function (card32) t) transform) + (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 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) + (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) + (downward-funarg transform)) + (if transform + (flet ((card32->int32->transform (v) + (declare (type card32 v)) + (funcall transform (card32->int32 v)))) + #+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) + (downward-funarg transform)) + (if transform + (flet ((transform->char->card8 (x) + (char->card8 (the character (funcall transform x))))) + #+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) + (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) + (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)) + (with-vector (data vector) + (writing-buffer-chunks card8 + ((index start (index+ index chunk))) + ((type array-index index)) + (buffer-replace buffer-bbuf data + buffer-boffset + (index+ buffer-boffset chunk) + index))) + nil) + +(defun write-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) + (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) + (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) + (downward-funarg transform)) + (if transform + (flet ((transform->int8->card8 (x) + (int8->card8 (the int8 (funcall transform x))))) + #+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) + (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) + (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)) + (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)) + (declare (type (function (t) card16) transform) + (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) + (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) + (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) + (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)) + (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)) + (declare (type (function (t) int16) transform) + (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) + (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) + (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) + (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)) + (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)) + (declare (type (function (t) card32) transform) + (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) + (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) + (downward-funarg transform)) + (if transform + (flet ((transform->int32->card32 (x) + (int32->card32 (the int32 (funcall transform x))))) + #+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) + (array-register 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))) + ((= k 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)))))))) diff --git a/clx/bufmac.lisp b/clx/bufmac.lisp new file mode 100644 index 000000000..bb811edf7 --- /dev/null +++ b/clx/bufmac.lisp @@ -0,0 +1,174 @@ +;;; -*- 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))) + +(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) + (array-register buffer-bbuf)) + #+clx-overlapping-arrays + ,@(append + (when (member 8 sizes) + '((declare (type buffer-bytes buffer-bbuf) + (array-register buffer-bbuf)))) + (when (member 16 sizes) + '((declare (type array-index buffer-woffset)) + (declare (type buffer-words buffer-wbuf) + (array-register buffer-wbuf)))) + (when (member 32 sizes) + '((declare (type array-index buffer-loffset)) + (declare (type buffer-longs buffer-lbuf) + (array-register 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))) + (macrolet ((%buffer-sizes () ',sizes)) + ,@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/clx/clx.lisp b/clx/clx.lisp new file mode 100644 index 000000000..c560354ea --- /dev/null +++ b/clx/clx.lisp @@ -0,0 +1,1104 @@ +;;; -*- 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. +;;; + +;; Primary Interface Author: +;; Robert W. Scheifler +;; MIT Laboratory for Computer Science +;; 545 Technology Square, Room 418 +;; Cambridge, MA 02139 +;; rws@zermatt.lcs.mit.edu + +;; Design Contributors: +;; Dan Cerys, Texas Instruments +;; Scott Fahlman, CMU +;; Charles Hornig, Symbolics +;; John Irwin, Franz +;; Kerry Kimbrough, Texas Instruments +;; Chris Lindblad, MIT +;; Rob MacLachlan, CMU +;; Mike McMahon, Symbolics +;; David Moon, Symbolics +;; LaMott Oren, Texas Instruments +;; Daniel Weinreb, Symbolics +;; John Wroclawski, MIT +;; Richard Zippel, Symbolics + +;; Primary Implementation Author: +;; LaMott Oren, Texas Instruments + +;; Implementation Contributors: +;; Charles Hornig, Symbolics +;; John Irwin, Franz +;; Chris Lindblad, MIT +;; Robert Scheifler, MIT + +;;; +;;; Change history: +;;; +;;; Date Author Description +;;; ------------------------------------------------------------------------------------- +;;; 04/07/87 R.Scheifler Created code stubs +;;; 04/08/87 L.Oren Started Implementation +;;; 05/11/87 L.Oren Included draft 3 revisions +;;; 07/07/87 L.Oren Untested alpha release to MIT +;;; 07/17/87 L.Oren Alpha release +;;; 08/**/87 C.Lindblad Rewrite of buffer code +;;; 08/**/87 et al Various random bug fixes +;;; 08/**/87 R.Scheifler General syntactic and portability cleanups +;;; 08/**/87 R.Scheifler Rewrite of gcontext caching and shadowing +;;; 09/02/87 L.Oren Change events from resource-ids to objects +;;; 12/24/87 R.Budzianowski KCL support +;;; 12/**/87 J.Irwin ExCL 2.0 support +;;; 01/20/88 L.Oren Add server extension mechanisms +;;; 01/20/88 L.Oren Only force output when blocking on input +;;; 01/20/88 L.Oren Uniform support for :event-window on events +;;; 01/28/88 L.Oren Add window manager property functions +;;; 01/28/88 L.Oren Add character translation facility +;;; 02/**/87 J.Irwin Allegro 2.2 support + +;;; This is considered a somewhat changeable interface. Discussion of better +;;; integration with CLOS, support for user-specified subclassess of basic +;;; objects, and the additional functionality to match the C Xlib is still in +;;; progress. Bug reports should be addressed to bug-clx@expo.lcs.mit.edu. + +;; Note: all of the following is in the package XLIB. + +(in-package :xlib) + +(export '( + *version* + card32 + card29 + int32 + card16 + int16 + card8 + int8 + rgb-val + angle + mask32 + mask16 + array-index + pixel + image-depth + display + display-p + display-host + display-display + display-after-function + display-protocol-major-version + display-protocol-minor-version + display-vendor-name + display-resource-id-base + display-resource-id-mask + display-xid + display-byte-order + display-release-number + display-max-request-length + display-default-screen + display-nscreens + display-roots + display-motion-buffer-size + display-xdefaults + display-image-lsb-first-p + display-bitmap-format + display-pixmap-formats + display-min-keycode + display-max-keycode + display-error-handler + display-authorization-name + display-authorization-data + display-plist + display-report-asynchronous-errors + color + color-p + color-red + color-green + color-blue + make-color + color-rgb + resource-id + drawable + drawable-p + drawable-equal + drawable-id + drawable-display + drawable-plist + window + window-p + window-equal + window-id + window-display + window-plist + pixmap + pixmap-p + pixmap-equal + pixmap-id + pixmap-display + pixmap-plist + colormap + colormap-p + colormap-equal + colormap-id + colormap-display + colormap-visual-info + cursor + cursor-p + cursor-equal + cursor-id + cursor-display + xatom + stringable + fontable + timestamp + bit-gravity + win-gravity + grab-status + boolean + alist + repeat-seq + point-seq + seg-seq + rect-seq + arc-seq + gcontext + gcontext-p + gcontext-equal + gcontext-id + gcontext-display + gcontext-plist + event-mask-class + event-mask + pointer-event-mask-class + pointer-event-mask + device-event-mask-class + device-event-mask + modifier-key + modifier-mask + state-mask-key + gcontext-key + event-key + error-key + draw-direction + boole-constant + bitmap-format + bitmap-format-p + bitmap-format-unit + bitmap-format-pad + bitmap-format-lsb-first-p + pixmap-format + pixmap-format-p + pixmap-format-depth + pixmap-format-bits-per-pixel + pixmap-format-scanline-pad + visual-info + visual-info-p + visual-info-id + visual-info-display + visual-info-class + visual-info-red-mask + visual-info-green-mask + visual-info-blue-mask + visual-info-bits-per-rgb + visual-info-colormap-entries + visual-info-plist + screen + screen-p + screen-root + screen-width + screen-height + screen-width-in-millimeters + screen-height-in-millimeters + screen-depths + screen-root-depth + screen-root-visual-info + screen-root-visual + screen-default-colormap + screen-white-pixel + screen-black-pixel + screen-min-installed-maps + screen-max-installed-maps + screen-backing-stores + screen-save-unders-p + screen-event-mask-at-open + screen-plist + font + font-p + font-equal + font-id + font-display + 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 + font-plist + char-left-bearing + max-char-left-bearing + min-char-left-bearing + char-right-bearing + max-char-right-bearing + min-char-right-bearing + char-width + max-char-width + min-char-width + char-ascent + max-char-ascent + min-char-ascent + char-descent + max-char-descent + min-char-descent + char-attributes + max-char-attributes + min-char-attributes + make-event-mask + make-event-keys + make-state-mask + make-state-keys + )) + +(pushnew :clx *features*) +(pushnew :xlib *features*) + +(defparameter *version* "MIT R4.2") +(pushnew :clx-mit-r4 *features*) + +(defparameter *protocol-major-version* 11.) +(defparameter *protocol-minor-version* 0) + +(defparameter *x-tcp-port* 6000) ;; add display number + +; Note: various perversions of the CL type system are used below. +; Examples: (list elt-type) (sequence elt-type) + +;; Note: if you have read the Version 11 protocol document or C Xlib manual, most of +;; the relationships should be fairly obvious. We have no intention of writing yet +;; another moby document for this interface. + +;; Types employed: display, window, pixmap, cursor, font, gcontext, colormap, color. +;; These types are defined solely by a functional interface; we do not specify +;; whether they are implemented as structures or flavors or ... Although functions +;; below are written using DEFUN, this is not an implementation requirement (although +;; it is a requirement that they be functions as opposed to macros or special forms). +;; It is unclear whether with-slots in the Common Lisp Object System must work on +;; them. + +;; Windows, pixmaps, cursors, fonts, gcontexts, and colormaps are all represented as +;; compound objects, rather than as integer resource-ids. This allows applications +;; to deal with multiple displays without having an explicit display argument in the +;; most common functions. Every function uses the display object indicated by the +;; first argument that is or contains a display; it is an error if arguments contain +;; different displays, and predictable results are not guaranteed. + +;; Each of window, pixmap, cursor, font, gcontext, and colormap have the following +;; five functions: + +;(defun make-<mumble> (display resource-id) +; ;; This function should almost never be called by applications, except in handling +; ;; events. To minimize consing in some implementations, this may use a cache in +; ;; the display. Make-gcontext creates with :cache-p nil. Make-font creates with +; ;; cache-p true. +; (declare (type display display) +; (type integer resource-id) +; (values <mumble>))) + +;(defun <mumble>-display (<mumble>) +; (declare (type <mumble> <mumble>) +; (values display))) + +;(defun <mumble>-id (<mumble>) +; (declare (type <mumble> <mumble>) +; (values integer))) + +;(defun <mumble>-equal (<mumble>-1 <mumble>-2) +; (declare (type <mumble> <mumble>-1 <mumble>-2))) + +;(defun <mumble>-p (<mumble>-1 <mumble>-2) +; (declare (type <mumble> <mumble>-1 <mumble>-2) +; (values boolean))) + +(deftype boolean () '(or null (not null))) + +(deftype card32 () '(unsigned-byte 32)) + +(deftype card29 () '(unsigned-byte 29)) + +(deftype card24 () '(unsigned-byte 24)) + +(deftype int32 () '(signed-byte 32)) + +(deftype card16 () '(unsigned-byte 16)) + +(deftype int16 () '(signed-byte 16)) + +(deftype card8 () '(unsigned-byte 8)) + +(deftype int8 () '(signed-byte 8)) + +(deftype card4 () '(unsigned-byte 4)) + +(deftype real (&optional (min '*) (max '*)) + (labels ((convert (limit floatp) + (typecase limit + (number (if floatp (float limit 0s0) (rational limit))) + (list (map 'list #'convert limit)) + (otherwise limit)))) + `(or (float ,(convert min t) ,(convert max t)) + (rational ,(convert min nil) ,(convert max nil))))) + +; Note that we are explicitly using a different rgb representation than what +; is actually transmitted in the protocol. + +(deftype rgb-val () '(real 0 1)) + +; Note that we are explicitly using a different angle representation than what +; is actually transmitted in the protocol. + +(deftype angle () '(real #.(* -2 pi) #.(* 2 pi))) + +(deftype mask32 () 'card32) + +(deftype mask16 () 'card16) + +(deftype pixel () '(unsigned-byte 32)) +(deftype image-depth () '(integer 0 32)) + +(deftype resource-id () 'card29) + +(deftype keysym () 'card32) + +; The following functions are provided by color objects: + +; The intention is that IHS and YIQ and CYM interfaces will also exist. +; Note that we are explicitly using a different spectrum representation +; than what is actually transmitted in the protocol. + +(def-clx-class (color (:constructor make-color-internal (red green blue)) + (:copier nil) (:print-function print-color)) + (red 0.0 :type rgb-val) + (green 0.0 :type rgb-val) + (blue 0.0 :type rgb-val)) + +(defun print-color (color stream depth) + (declare (type color color) + (ignore depth)) + (print-unreadable-object (color stream :type t) + (prin1 (color-red color) stream) + (princ " " stream) + (prin1 (color-green color) stream) + (princ " " stream) + (prin1 (color-blue color) stream))) + +(defun make-color (&key (red 1.0) (green 1.0) (blue 1.0) &allow-other-keys) + (declare (type rgb-val red green blue)) + (declare (values color)) + (make-color-internal red green blue)) + +(defun color-rgb (color) + (declare (type color color)) + (declare (values red green blue)) + (values (color-red color) (color-green color) (color-blue color))) + +(def-clx-class (bitmap-format (:copier nil)) + (unit 8 :type (member 8 16 32)) + (pad 8 :type (member 8 16 32)) + (lsb-first-p nil :type boolean)) + +(def-clx-class (pixmap-format (:copier nil)) + (depth 0 :type image-depth) + (bits-per-pixel 8 :type (member 1 4 8 16 24 32)) + (scanline-pad 8 :type (member 8 16 32))) + +(defparameter *atom-cache-size* 200) +(defparameter *resource-id-map-size* 500) + +(def-clx-class (display (:include buffer) + (:constructor make-display-internal) + (:print-function print-display) + (:copier nil)) + (host) ; Server Host + (display 0 :type integer) ; Display number on host + (after-function nil) ; Function to call after every request + (event-lock + (make-process-lock "CLX Event Lock")) ; with-event-queue lock + (event-queue-lock + (make-process-lock "CLX Event Queue Lock")) ; new-events/event-queue lock + (event-queue-tail ; last event in the event queue + nil :type (or null reply-buffer)) + (event-queue-head ; Threaded queue of events + nil :type (or null reply-buffer)) + (atom-cache (make-hash-table :test #'eq :size *atom-cache-size*) + :type hash-table) ; Hash table relating atoms keywords + ; to atom id's + (font-cache nil) ; list of font + (protocol-major-version 0 :type card16) ; Major version of server's X protocol + (protocol-minor-version 0 :type card16) ; minor version of servers X protocol + (vendor-name "" :type string) ; vendor of the server hardware + (resource-id-base 0 :type resource-id) ; resouce ID base + (resource-id-mask 0 :type resource-id) ; resource ID mask bits + (resource-id-byte nil) ; resource ID mask field (used with DPB & LDB) + (resource-id-count 0 :type resource-id) ; resource ID mask count + ; (used for allocating ID's) + (resource-id-map (make-hash-table :test (resource-id-map-test) + :size *resource-id-map-size*) + :type hash-table) ; hash table maps resource-id's to + ; objects (used in lookup functions) + (xid 'resourcealloc) ; allocator function + (byte-order #+clx-little-endian :lsbfirst ; connection byte order + #-clx-little-endian :msbfirst) + (release-number 0 :type card32) ; release of the server + (max-request-length 0 :type card16) ; maximum number 32 bit words in request + (default-screen) ; default screen for operations + (roots nil :type list) ; List of screens + (motion-buffer-size 0 :type card32) ; size of motion buffer + (xdefaults) ; contents of defaults from server + (image-lsb-first-p nil :type boolean) + (bitmap-format (make-bitmap-format) ; Screen image info + :type bitmap-format) + (pixmap-formats nil :type sequence) ; list of pixmap formats + (min-keycode 0 :type card8) ; minimum key-code + (max-keycode 0 :type card8) ; maximum key-code + (error-handler 'default-error-handler) ; Error handler function + (close-down-mode :destroy) ; Close down mode saved by Set-Close-Down-Mode + (authorization-name "" :type string) + (authorization-data "" :type string) + (last-width nil :type (or null card29)) ; Accumulated width of last string + (keysym-mapping nil ; Keysym mapping cached from server + :type (or null (array * (* *)))) + (modifier-mapping nil :type list) ; ALIST of (keysym . state-mask) for all modifier keysyms + (keysym-translation nil :type list) ; An alist of (keysym object function) + ; for display-local keysyms + (extension-alist nil :type list) ; extension alist, which has elements: + ; (name major-opcode first-event first-error) + (event-extensions '#() :type vector) ; Vector mapping X event-codes to event keys + (performance-info) ; Hook for gathering performance info + (trace-history) ; Hook for debug trace + (plist) ; hook for extension to hang data + ;; These slots are used to manage multi-process input. + (input-in-progress nil) ; Some process reading from the stream. + ; Updated with CONDITIONAL-STORE. + (pending-commands nil) ; Threaded list of PENDING-COMMAND objects + ; for all commands awaiting replies. + ; Protected by WITH-EVENT-QUEUE-INTERNAL. + (asynchronous-errors nil) ; Threaded list of REPLY-BUFFER objects + ; containing error messages for commands + ; which did not expect replies. + ; Protected by WITH-EVENT-QUEUE-INTERNAL. + (report-asynchronous-errors ; When to report asynchronous errors + '(:immediately) :type list) ; The keywords that can be on this list + ; are :IMMEDIATELY, :BEFORE-EVENT-HANDLING, + ; and :AFTER-FINISH-OUTPUT + (event-process nil) ; Process ID of process awaiting events. + ; Protected by WITH-EVENT-QUEUE. + (new-events nil :type (or null reply-buffer)) ; Pointer to the first new event in the + ; event queue. + ; Protected by WITH-EVENT-QUEUE. + (current-event-symbol ; Bound with PROGV by event handling macros + (list (gensym) (gensym)) :type cons) + (atom-id-map (make-hash-table :test (resource-id-map-test) + :size *atom-cache-size*) + :type hash-table) + ) + +(defun print-display (display stream depth) + (declare (type display display) + (ignore depth)) + (print-unreadable-object (display stream :type t) + (princ (display-host display) stream) + (princ ":" stream) + (princ (display-display display) stream) + (princ " (" stream) + (princ (display-vendor-name display) stream) + (princ " R" stream) + (prin1 (display-release-number display) stream) + (princ ")" stream))) + +;;(deftype drawable () '(or window pixmap)) + +(def-clx-class (drawable (:copier nil) (:print-function print-drawable)) + (id 0 :type resource-id) + (display nil :type (or null display)) + (plist nil :type list) ; Extension hook + ) + +(defun print-drawable (drawable stream depth) + (declare (type drawable drawable) + (ignore depth)) + (print-unreadable-object (drawable stream :type t) + (princ (display-host (drawable-display drawable)) stream) + (princ ":" stream) + (princ (display-display (drawable-display drawable)) stream) + (princ " " stream) + (prin1 (drawable-id drawable) stream))) + +(def-clx-class (window (:include drawable) (:copier nil) + (:print-function print-drawable)) + ) + +(def-clx-class (pixmap (:include drawable) (:copier nil) + (:print-function print-drawable)) + ) + +(def-clx-class (visual-info (:copier nil) (:print-function print-visual-info)) + (id 0 :type resource-id) + (display nil :type (or null display)) + (class :static-gray :type (member :static-gray :static-color :true-color + :gray-scale :pseudo-color :direct-color)) + (red-mask 0 :type pixel) + (green-mask 0 :type pixel) + (blue-mask 0 :type pixel) + (bits-per-rgb 1 :type card8) + (colormap-entries 0 :type card16) + (plist nil :type list) ; Extension hook + ) + +(defun print-visual-info (visual-info stream depth) + (declare (type visual-info visual-info) + (ignore depth)) + (print-unreadable-object (visual-info stream :type t) + (prin1 (visual-info-bits-per-rgb visual-info) stream) + (princ "-bit " stream) + (princ (visual-info-class visual-info) stream) + (princ " " stream) + (princ (display-host (visual-info-display visual-info)) stream) + (princ ":" stream) + (princ (display-display (visual-info-display visual-info)) stream) + (princ " " stream) + (prin1 (visual-info-id visual-info) stream))) + +(def-clx-class (colormap (:copier nil) (:print-function print-colormap)) + (id 0 :type resource-id) + (display nil :type (or null display)) + (visual-info nil :type (or null visual-info)) + ) + +(defun print-colormap (colormap stream depth) + (declare (type colormap colormap) + (ignore depth)) + (print-unreadable-object (colormap stream :type t) + (when (colormap-visual-info colormap) + (princ (visual-info-class (colormap-visual-info colormap)) stream) + (princ " " stream)) + (princ (display-host (colormap-display colormap)) stream) + (princ ":" stream) + (princ (display-display (colormap-display colormap)) stream) + (princ " " stream) + (prin1 (colormap-id colormap) stream))) + +(def-clx-class (cursor (:copier nil) (:print-function print-cursor)) + (id 0 :type resource-id) + (display nil :type (or null display)) + ) + +(defun print-cursor (cursor stream depth) + (declare (type cursor cursor) + (ignore depth)) + (print-unreadable-object (cursor stream :type t) + (princ (display-host (cursor-display cursor)) stream) + (princ ":" stream) + (princ (display-display (cursor-display cursor)) stream) + (princ " " stream) + (prin1 (cursor-id cursor) stream))) + +; Atoms are accepted as strings or symbols, and are always returned as keywords. +; Protocol-level integer atom ids are hidden, using a cache in the display object. + +(deftype xatom () '(or string symbol)) + +(defconstant *predefined-atoms* + '#(nil :PRIMARY :SECONDARY :ARC :ATOM :BITMAP + :CARDINAL :COLORMAP :CURSOR + :CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 + :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7 + :DRAWABLE :FONT :INTEGER :PIXMAP :POINT :RECTANGLE + :RESOURCE_MANAGER :RGB_COLOR_MAP :RGB_BEST_MAP + :RGB_BLUE_MAP :RGB_DEFAULT_MAP + :RGB_GRAY_MAP :RGB_GREEN_MAP :RGB_RED_MAP :STRING + :VISUALID :WINDOW :WM_COMMAND :WM_HINTS + :WM_CLIENT_MACHINE :WM_ICON_NAME :WM_ICON_SIZE + :WM_NAME :WM_NORMAL_HINTS :WM_SIZE_HINTS + :WM_ZOOM_HINTS :MIN_SPACE :NORM_SPACE :MAX_SPACE + :END_SPACE :SUPERSCRIPT_X :SUPERSCRIPT_Y + :SUBSCRIPT_X :SUBSCRIPT_Y + :UNDERLINE_POSITION :UNDERLINE_THICKNESS + :STRIKEOUT_ASCENT :STRIKEOUT_DESCENT + :ITALIC_ANGLE :X_HEIGHT :QUAD_WIDTH :WEIGHT + :POINT_SIZE :RESOLUTION :COPYRIGHT :NOTICE + :FONT_NAME :FAMILY_NAME :FULL_NAME :CAP_HEIGHT + :WM_CLASS :WM_TRANSIENT_FOR)) + +(deftype stringable () '(or string symbol)) + +(deftype fontable () '(or stringable font)) + +; Nil stands for CurrentTime. + +(deftype timestamp () '(or null card32)) + +(defconstant *bit-gravity-vector* + '#(:forget :north-west :north :north-east :west + :center :east :south-west :south + :south-east :static)) + +(deftype bit-gravity () + '(member :forget :north-west :north :north-east :west + :center :east :south-west :south :south-east :static)) + +(defconstant *win-gravity-vector* + '#(:unmap :north-west :north :north-east :west + :center :east :south-west :south :south-east + :static)) + +(deftype win-gravity () + '(member :unmap :north-west :north :north-east :west + :center :east :south-west :south :south-east :static)) + +(deftype grab-status () + '(member :success :already-grabbed :invalid-time :not-viewable)) + +; An association list. + +(deftype alist (key-type-and-name datum-type-and-name) + (declare (ignore key-type-and-name datum-type-and-name)) + 'list) + +; A sequence, containing zero or more repetitions of the given elements, +; with the elements expressed as (type name). + +(deftype repeat-seq (&rest elts) elts 'sequence) + +(deftype point-seq () '(repeat-seq (int16 x) (int16 y))) + +(deftype seg-seq () '(repeat-seq (int16 x1) (int16 y1) (int16 x2) (int16 y2))) + +(deftype rect-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height))) + +(deftype arc-seq () + '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height) + (angle angle1) (angle angle2))) + +(deftype gcontext-state () 'simple-vector) + +(def-clx-class (gcontext (:copier nil) (:print-function print-gcontext)) + ;; The accessors convert to CLX data types. + (id 0 :type resource-id) + (display nil :type (or null display)) + (drawable nil :type (or null drawable)) + (cache-p t :type boolean) + (server-state (allocate-gcontext-state) :type gcontext-state) + (local-state (allocate-gcontext-state) :type gcontext-state) + (plist nil :type list) ; Extension hook + (next nil #-explorer :type #-explorer (or null gcontext)) + ) + +(defun print-gcontext (gcontext stream depth) + (declare (type gcontext gcontext) + (ignore depth)) + (print-unreadable-object (gcontext stream :type t) + (princ (display-host (gcontext-display gcontext)) stream) + (princ ":" stream) + (princ (display-display (gcontext-display gcontext)) stream) + (princ " " stream) + (prin1 (gcontext-id gcontext) stream))) + +(defconstant *event-mask-vector* + '#(:key-press :key-release :button-press :button-release + :enter-window :leave-window :pointer-motion :pointer-motion-hint + :button-1-motion :button-2-motion :button-3-motion :button-4-motion + :button-5-motion :button-motion :keymap-state :exposure :visibility-change + :structure-notify :resize-redirect :substructure-notify :substructure-redirect + :focus-change :property-change :colormap-change :owner-grab-button)) + +(deftype event-mask-class () + '(member :key-press :key-release :owner-grab-button :button-press :button-release + :enter-window :leave-window :pointer-motion :pointer-motion-hint + :button-1-motion :button-2-motion :button-3-motion :button-4-motion + :button-5-motion :button-motion :exposure :visibility-change + :structure-notify :resize-redirect :substructure-notify :substructure-redirect + :focus-change :property-change :colormap-change :keymap-state)) + +(deftype event-mask () + '(or mask32 list)) ;; (OR integer (LIST event-mask-class)) + +(defconstant *pointer-event-mask-vector* + '#(%error %error :button-press :button-release + :enter-window :leave-window :pointer-motion :pointer-motion-hint + :button-1-motion :button-2-motion :button-3-motion :button-4-motion + :button-5-motion :button-motion :keymap-state)) + +(deftype pointer-event-mask-class () + '(member :button-press :button-release + :enter-window :leave-window :pointer-motion :pointer-motion-hint + :button-1-motion :button-2-motion :button-3-motion :button-4-motion + :button-5-motion :button-motion :keymap-state)) + +(deftype pointer-event-mask () + '(or mask32 list)) ;; '(or integer (list pointer-event-mask-class))) + +(defconstant *device-event-mask-vector* + '#(:key-press :key-release :button-press :button-release :pointer-motion + :button-1-motion :button-2-motion :button-3-motion :button-4-motion + :button-5-motion :button-motion)) + +(deftype device-event-mask-class () + '(member :key-press :key-release :button-press :button-release :pointer-motion + :button-1-motion :button-2-motion :button-3-motion :button-4-motion + :button-5-motion :button-motion)) + +(deftype device-event-mask () + '(or mask32 list)) ;; '(or integer (list device-event-mask-class))) + +(defconstant *state-mask-vector* + '#(:shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5 + :button-1 :button-2 :button-3 :button-4 :button-5)) + +(deftype modifier-key () + '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5)) + +(deftype modifier-mask () + '(or (member :any) mask16 list)) ;; '(or (member :any) integer (list modifier-key))) + +(deftype state-mask-key () + '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5))) + +(defconstant *gcontext-components* + '(:function :plane-mask :foreground :background + :line-width :line-style :cap-style :join-style :fill-style + :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode + :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes + :arc-mode)) + +(deftype gcontext-key () + '(member :function :plane-mask :foreground :background + :line-width :line-style :cap-style :join-style :fill-style + :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode + :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes + :arc-mode)) + +(deftype event-key () + '(member :key-press :key-release :button-press :button-release :motion-notify + :enter-notify :leave-notify :focus-in :focus-out :keymap-notify + :exposure :graphics-exposure :no-exposure :visibility-notify + :create-notify :destroy-notify :unmap-notify :map-notify :map-request + :reparent-notify :configure-notify :gravity-notify :resize-request + :configure-request :circulate-notify :circulate-request :property-notify + :selection-clear :selection-request :selection-notify + :colormap-notify :client-message :mapping-notify)) + +(deftype error-key () + '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice + :illegal-request :implementation :length :match :name :pixmap :value :window)) + +(deftype draw-direction () + '(member :left-to-right :right-to-left)) + +(defconstant *boole-vector* + '#(#.boole-clr #.boole-and #.boole-andc2 #.boole-1 + #.boole-andc1 #.boole-2 #.boole-xor #.boole-ior + #.boole-nor #.boole-eqv #.boole-c2 #.boole-orc2 + #.boole-c1 #.boole-orc1 #.boole-nand #.boole-set)) + +(deftype boole-constant () + `(member ,boole-clr ,boole-and ,boole-andc2 ,boole-1 + ,boole-andc1 ,boole-2 ,boole-xor ,boole-ior + ,boole-nor ,boole-eqv ,boole-c2 ,boole-orc2 + ,boole-c1 ,boole-orc1 ,boole-nand ,boole-set)) + +(def-clx-class (screen (:copier nil) (:print-function print-screen)) + (root nil :type (or null window)) + (width 0 :type card16) + (height 0 :type card16) + (width-in-millimeters 0 :type card16) + (height-in-millimeters 0 :type card16) + (depths nil :type (alist (image-depth depth) ((list visual-info) visuals))) + (root-depth 1 :type image-depth) + (root-visual-info nil :type (or null visual-info)) + (default-colormap nil :type (or null colormap)) + (white-pixel 0 :type pixel) + (black-pixel 1 :type pixel) + (min-installed-maps 1 :type card16) + (max-installed-maps 1 :type card16) + (backing-stores :never :type (member :never :when-mapped :always)) + (save-unders-p nil :type boolean) + (event-mask-at-open 0 :type mask32) + (plist nil :type list) ; Extension hook + ) + +(defun print-screen (screen stream depth) + (declare (type screen screen) + (ignore depth)) + (print-unreadable-object (screen stream :type t) + (let ((display (drawable-display (screen-root screen)))) + (princ (display-host display) stream) + (princ ":" stream) + (princ (display-display display) stream) + (princ "." stream) + (princ (position screen (display-roots display)) stream)) + (princ " " stream) + (prin1 (screen-width screen) stream) + (princ "x" stream) + (prin1 (screen-height screen) stream) + (princ "x" stream) + (prin1 (screen-root-depth screen) stream) + (when (screen-root-visual-info screen) + (princ " " stream) + (princ (visual-info-class (screen-root-visual-info screen)) stream)))) + +(defun screen-root-visual (screen) + (declare (type screen screen) + (values resource-id)) + (visual-info-id (screen-root-visual-info screen))) + +;; The list contains alternating keywords and integers. +(deftype font-props () 'list) + +(def-clx-class (font-info (:copier nil) (:predicate nil)) + (direction :left-to-right :type draw-direction) + (min-char 0 :type card16) ;; First character in font + (max-char 0 :type card16) ;; Last character in font + (min-byte1 0 :type card8) ;; The following are for 16 bit fonts + (max-byte1 0 :type card8) ;; and specify min&max values for + (min-byte2 0 :type card8) ;; the two character bytes + (max-byte2 0 :type card8) + (all-chars-exist-p nil :type boolean) + (default-char 0 :type card16) + (min-bounds nil :type (or null vector)) + (max-bounds nil :type (or null vector)) + (ascent 0 :type int16) + (descent 0 :type int16) + (properties nil :type font-props)) + +(def-clx-class (font (:constructor make-font-internal) (:copier nil) + (:print-function print-font)) + (id-internal nil :type (or null resource-id)) ;; NIL when not opened + (display nil :type (or null display)) + (reference-count 0 :type fixnum) + (name "" :type (or null string)) ;; NIL when ID is for a GContext + (font-info-internal nil :type (or null font-info)) + (char-infos-internal nil :type (or null (simple-array int16 (*)))) + (local-only-p t :type boolean) ;; When T, always calculate text extents locally + (plist nil :type list) ; Extension hook + ) + +(defun print-font (font stream depth) + (declare (type font font) + (ignore depth)) + (print-unreadable-object (font stream :type t) + (if (font-name font) + (princ (font-name font) stream) + (princ "(gcontext)" stream)) + (princ " " stream) + (princ (display-host (font-display font)) stream) + (princ ":" stream) + (princ (display-display (font-display font)) stream) + (when (font-id-internal font) + (princ " " stream) + (prin1 (font-id font) stream)))) + +(defun font-id (font) + ;; Get font-id, opening font if needed + (or (font-id-internal font) + (open-font-internal font))) + +(defun font-font-info (font) + (or (font-font-info-internal font) + (query-font font))) + +(defun font-char-infos (font) + (or (font-char-infos-internal font) + (progn (query-font font) + (font-char-infos-internal font)))) + +(defun make-font (&key id + display + (reference-count 0) + (name "") + (local-only-p t) + font-info-internal) + (make-font-internal :id-internal id + :display display + :reference-count reference-count + :name name + :local-only-p local-only-p + :font-info-internal font-info-internal)) + +; For each component (<name> <unspec> :type <type>) of font-info, +; there is a corresponding function: + +;(defun font-<name> (font) +; (declare (type font font) +; (values <type>))) + +(macrolet ((make-font-info-accessors (useless-name &body fields) + `(within-definition (,useless-name make-font-info-accessors) + ,@(mapcar + #'(lambda (field) + (let* ((type (second field)) + (n (string (first field))) + (name (xintern 'font- n)) + (accessor (xintern 'font-info- n))) + `(defun ,name (font) + (declare (type font font)) + (declare (values ,type)) + (,accessor (font-font-info font))))) + fields)))) + (make-font-info-accessors ignore + (direction draw-direction) + (min-char card16) + (max-char card16) + (min-byte1 card8) + (max-byte1 card8) + (min-byte2 card8) + (max-byte2 card8) + (all-chars-exist-p boolean) + (default-char card16) + (min-bounds vector) + (max-bounds vector) + (ascent int16) + (descent int16) + (properties font-props))) + +(defun font-property (font name) + (declare (type font font) + (type keyword name)) + (declare (values (or null int32))) + (getf (font-properties font) name)) + +(macrolet ((make-mumble-equal (type) + ;; When cached, EQ works fine, otherwise test resource id's and displays + (let ((predicate (xintern type '-equal)) + (id (xintern type '-id)) + (dpy (xintern type '-display))) + (if (member type *clx-cached-types*) + `(within-definition (,type make-mumble-equal) + (declaim (inline ,predicate)) + (defun ,predicate (a b) (eq a b))) + `(within-definition (,type make-mumble-equal) + (defun ,predicate (a b) + (declare (type ,type a b)) + (and (= (,id a) (,id b)) + (eq (,dpy a) (,dpy b))))))))) + (make-mumble-equal window) + (make-mumble-equal pixmap) + (make-mumble-equal cursor) + (make-mumble-equal font) + (make-mumble-equal gcontext) + (make-mumble-equal colormap) + (make-mumble-equal drawable)) + +;;; +;;; Event-mask encode/decode functions +;;; Converts from keyword-lists to integer and back +;;; +(defun encode-mask (key-vector key-list key-type) + ;; KEY-VECTOR is a vector containg bit-position keywords. The position of the + ;; keyword in the vector indicates its bit position in the resulting mask + ;; KEY-LIST is either a mask or a list of KEY-TYPE + ;; Returns NIL when KEY-LIST is not a list or mask. + (declare (type (simple-array keyword (*)) key-vector) + (type (or mask32 list) key-list)) + (declare (values (or mask32 nil))) + (typecase key-list + (mask32 key-list) + (list (let ((mask 0)) + (dolist (key key-list mask) + (let ((bit (position key (the vector key-vector) :test #'eq))) + (unless bit + (x-type-error key key-type)) + (setq mask (logior mask (ash 1 bit))))))))) + +(defun decode-mask (key-vector mask) + (declare (type (simple-array keyword (*)) key-vector) + (type mask32 mask)) + (declare (values list)) + (do ((m mask (ash m -1)) + (bit 0 (1+ bit)) + (len (length key-vector)) + (result nil)) + ((or (zerop m) (>= bit len)) result) + (declare (type mask32 m) + (fixnum bit len) + (list result)) + (when (oddp m) + (push (aref key-vector bit) result)))) + +(defun encode-event-mask (event-mask) + (declare (type event-mask event-mask)) + (declare (values mask32)) + (or (encode-mask *event-mask-vector* event-mask 'event-mask-class) + (x-type-error event-mask 'event-mask))) + +(defun make-event-mask (&rest keys) + ;; This is only defined for core events. + ;; Useful for constructing event-mask, pointer-event-mask, device-event-mask. + (declare (type list keys)) ;; (list event-mask-class) + (declare (values mask32)) + (encode-mask *event-mask-vector* keys 'event-mask-class)) + +(defun make-event-keys (event-mask) + ;; This is only defined for core events. + (declare (type mask32 event-mask)) + (declare (values (list event-mask-class))) + (decode-mask *event-mask-vector* event-mask)) + +(defun encode-device-event-mask (device-event-mask) + (declare (type device-event-mask device-event-mask)) + (declare (values mask32)) + (or (encode-mask *device-event-mask-vector* device-event-mask + 'device-event-mask-class) + (x-type-error device-event-mask 'device-event-mask))) + +(defun encode-modifier-mask (modifier-mask) + (declare (type modifier-mask modifier-mask)) ;; (list state-mask-key) + (declare (values mask16)) + (or (encode-mask *state-mask-vector* modifier-mask 'modifier-key) + (and (eq modifier-mask :any) #x8000) + (x-type-error modifier-mask 'modifier-mask))) + +(defun encode-state-mask (state-mask) + (declare (type (or mask16 list) state-mask)) ;; (list state-mask-key) + (declare (values mask16)) + (or (encode-mask *state-mask-vector* state-mask 'state-mask-key) + (x-type-error state-mask '(or mask16 (list state-mask-key))))) + +(defun make-state-mask (&rest keys) + ;; Useful for constructing modifier-mask, state-mask. + (declare (type list keys)) ;; (list state-mask-key) + (declare (values mask16)) + (encode-mask *state-mask-vector* keys 'state-mask-key)) + +(defun make-state-keys (state-mask) + (declare (type mask16 state-mask)) + (declare (values (list state-mask-key))) + (decode-mask *state-mask-vector* state-mask)) + +(defun encode-pointer-event-mask (pointer-event-mask) + (declare (type pointer-event-mask pointer-event-mask)) + (declare (values mask32)) + (or (encode-mask *pointer-event-mask-vector* pointer-event-mask + 'pointer-event-mask-class) + (x-type-error pointer-event-mask 'pointer-event-mask))) diff --git a/clx/defsystem.lisp b/clx/defsystem.lisp new file mode 100644 index 000000000..b711c5950 --- /dev/null +++ b/clx/defsystem.lisp @@ -0,0 +1,603 @@ +;;; -*- Mode: LISP; 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. +;;; + +;;; #+ features used in this file +;;; ansi-common-lisp +;;; lispm +;;; genera +;;; lucid +;;; lcl3.0 +;;; apollo +;;; kcl +;;; ibcl +;;; excl + +#-ansi-common-lisp +(lisp:in-package :xlib :use '(:lisp)) + +#+ansi-common-lisp +(common-lisp:in-package :common-lisp-user) + +#+ansi-common-lisp +(common-lisp:defpackage xlib + (:use common-lisp) + (:size 3000) + #+Genera + (:import-from + (system + arglist downward-funarg array-register) + (zwei + indentation)) + (: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-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 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-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 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)) + +#+ansi-common-lisp +(common-lisp:in-package :xlib) + +#-lispm +(export '( + compile-clx + load-clx)) + +#+excl (error "Use excldefsys") + + +;;;; Lisp Machines + +;;; Lisp machines have their own defsystems, so we use them to define +;;; the CLX load. + +#+(and lispm (not genera)) +(global:defsystem CLX + (:pathname-default "clx:clx;") + (:patchable "clx:patch;" clx-ti) + (:initial-status :experimental) + + (:module depdefs "depdefs") + (:module clx "clx") + (:module dependent "dependent") + (:module macros "macros") + (:module bufmac "bufmac") + (:module buffer "buffer") + (:module display "display") + (:module gcontext "gcontext") + (:module requests "requests") + (:module input "input") + (:module fonts "fonts") + (:module graphics "graphics") + (:module text "text") + (:module attributes "attributes") + (:module translate "translate") + (:module keysyms "keysyms") + (:module manager "manager") + (:module image "image") + (:module resource "resource") + (:module doc "doc") + + (:compile-load depdefs) + (:compile-load clx + (:fasload depdefs)) + (:compile-load dependent + (:fasload depdefs clx)) + ;; Macros only needed for compilation + (:skip :compile-load macros + (:fasload depdefs clx dependent)) + ;; Bufmac only needed for compilation + (:skip :compile-load bufmac + (:fasload depdefs clx dependent macros)) + (:compile-load buffer + (:fasload depdefs clx dependent macros bufmac)) + (:compile-load display + (:fasload depdefs clx dependent macros bufmac buffer)) + (:compile-load gcontext + (:fasload depdefs clx dependent macros bufmac buffer display)) + (:compile-load input + (:fasload depdefs clx dependent macros bufmac buffer display)) + (:compile-load requests + (:fasload depdefs clx dependent macros bufmac buffer display input)) + (:compile-load fonts + (:fasload depdefs clx dependent macros bufmac buffer display)) + (:compile-load graphics + (:fasload depdefs clx dependent macros fonts bufmac buffer display fonts)) + (:compile-load text + (:fasload depdefs clx dependent macros fonts bufmac buffer display gcontext fonts)) + (:compile-load-init attributes + (dependent) ;<- There may be other modules needed here. + (:fasload depdefs clx dependent macros bufmac buffer display)) + (:compile-load translate + (:fasload depdefs clx dependent macros bufmac buffer display)) + (:compile-load keysyms + (:fasload depdefs clx dependent macros bufmac buffer display translate)) + (:compile-load manager + (:fasload depdefs clx dependent macros bufmac buffer display)) + (:compile-load image + (:fasload depdefs clx dependent macros bufmac buffer display)) + (:compile-load resource) + (:auxiliary doc) + ) + + +#+Genera +(scl:defsystem CLX + (:default-pathname "SYS:X11;CLX;" + :default-package "XLIB" + :pretty-name "CLX" + :maintaining-sites (:scrc) + :distribute-sources t + :distribute-binaries t + :source-category :basic) + (:module doc ("doc") + (:type :lisp-example)) + (:module depdefs ("depdefs" "generalock")) + (:module clx ("clx") + (:uses-definitions-from depdefs)) + (:module dependent ("dependent") + (:uses-definitions-from clx)) + (:module macros ("macros") + (:uses-definitions-from dependent)) + (:module bufmac ("bufmac") + (:uses-definitions-from dependent macros)) + (:module buffer ("buffer") + (:uses-definitions-from dependent macros bufmac)) + (:module display ("display") + (:uses-definitions-from dependent macros bufmac buffer)) + (:module gcontext ("gcontext") + (:uses-definitions-from dependent macros bufmac display)) + (:module input ("input") + (:uses-definitions-from dependent macros bufmac display)) + (:module requests ("requests") + (:uses-definitions-from dependent macros bufmac display input)) + (:module fonts ("fonts") + (:uses-definitions-from dependent macros bufmac display)) + (:module graphics ("graphics") + (:uses-definitions-from dependent macros bufmac fonts)) + (:module text ("text") + (:uses-definitions-from dependent macros bufmac gcontext fonts)) + (:module attributes ("attributes") + (:uses-definitions-from dependent macros bufmac display)) + (:module translate ("translate") + (:uses-definitions-from dependent macros bufmac display)) + (:module keysyms ("keysyms") + (:uses-definitions-from translate)) + (:module manager ("manager") + (:uses-definitions-from dependent macros bufmac display)) + (:module image ("image") + (:uses-definitions-from dependent macros bufmac display)) + (:module resource ("resource")) + ) + + +;;;; Non Lisp Machines + +#+lucid +(defvar *foreign-libraries* '("-lc")) ; '("-lresolv" "-lc") for some sites + +#+lucid +(defun clx-foreign-files (binary-path) + + ;; apply a patch to 2.0 systems + #+(and (not lcl3.0) (or mc68000 mc68020)) + (load (merge-pathnames "make-sequence-patch" binary-path)) + + ;; Link lisp to the C function connect_to_server + #+(and apollo (not lcl3.0)) + (lucid::define-foreign-function '(xlib::connect-to-server "connect_to_server") + '((:val host :string) + (:val display :integer32)) + :integer32) + #+(and (not apollo) (not lcl3.0)) + (lucid::define-c-function xlib::connect-to-server + (host display) + :result-type :integer) + #+lcl3.0 + (lucid::def-foreign-function (xlib::connect-to-server + (:language :c) + (:return-type :signed-32bit)) + (host :simple-string) (display :signed-32bit)) + (unintern 'display) + + ;; Load the definition of connect_to_server + #+apollo + (lucid::load-foreign-file (merge-pathnames "socket" binary-path) + :preserve-pathname t) + #-apollo + (lucid::load-foreign-files (list (merge-pathnames "socket.o" binary-path)) + *foreign-libraries*)) + + +;; socket interface for kcl and ibcl +;; defines the function (open-socket-stream host display) +;; +;; You must first compile file socket.c +#+(or kcl ibcl) +(defun kcl-socket-init (binary-path) + (let ((sockcl (namestring (merge-pathnames "sockcl.o" binary-path))) + (socket (namestring (merge-pathnames "socket.o" binary-path)))) + (si:faslink sockcl (format nil "~a -lc" socket)) + )) + + +;;;; Compile CLX + +;;; COMPILE-CLX compiles the lisp source files and loads the binaries. +;;; It goes to some trouble to let the source files be in one directory +;;; and the binary files in another. Thus the same set of sources can +;;; be used for different machines and/or lisp systems. It also allows +;;; you to supply explicit extensions, so source files do not have to +;;; be renamed to fit into the naming conventions of an implementation. + +;;; For example, +;;; (compile-clx "*.lisp" "machine/") +;;; compiles source files from the connected directory and puts them +;;; into the "machine" subdirectory. You can then load CLX out of the +;;; machine directory. + +;;; The code has no knowledge of the source file types (eg, ".l" or +;;; ".lisp") or of the binary file types (eg, ".b" or ".sbin"). Calling +;;; compile-file and load with a file type of NIL usually sorts things +;;; out correctly, but you may have to explicitly give the source and +;;; binary file types. + +;;; An attempt at compiling the C language sources is also made, +;;; but you may have to set different compiler switches +;;; should be. If it doesn't do the right thing, then do +;;; (compile-clx "" "" :compile-c NIL) +;;; to prevent the compilation. + +;;; compilation notes +;;; lucid2.0/hp9000 +;;; must uudecode the file make-sequence-patch.uu + +#-lispm +(defun compile-clx (&optional + (source-pathname-defaults "") + (binary-pathname-defaults "") + &key + (compile-c t)) + + ;; The pathname-defaults above might only be strings, so coerce them + ;; to pathnames. Build a default binary path with every component + ;; of the source except the file type. This should prevent + ;; (compile-clx "*.lisp") from destroying source files. + (let* ((source-path (pathname source-pathname-defaults)) + (path (make-pathname + :host (pathname-host source-path) + :device (pathname-device source-path) + :directory (pathname-directory source-path) + :name (pathname-name source-path) + :type nil + :version (pathname-version source-path))) + (binary-path (merge-pathnames binary-pathname-defaults + path))) + + ;; Make sure source-path and binary-path file types are distinct so + ;; we don't accidently overwrite the source files. NIL should be an + ;; ok type, but anything else spells trouble. + (if (and (equal (pathname-type source-path) + (pathname-type binary-path)) + (not (null (pathname-type binary-path)))) + (error "Source and binary pathname defaults have same type ~s ~s" + source-path binary-path)) + + (format t ";;; Default paths: ~s ~s~%" source-path binary-path) + + ;; In lucid make sure we're using the compiler in production mode. + #+lcl3.0 + (progn + #-pqc + (cerror "Go ahead anyway." + "Lucid's production mode compiler must be loaded to compile CLX.") + (proclaim '(optimize (speed 3) + (safety 1) + (space 0) + (compilation-speed 0)))) + + (flet ((compile-and-load (filename) + (let ((source (merge-pathnames filename source-path)) + (binary (merge-pathnames filename binary-path))) + ;; If the source and binary pathnames are the same, + ;; then don't supply an output file just to be sure + ;; compile-file defaults correctly. + #+(or kcl ibcl) (load source) + (if (equal source binary) + (compile-file source) + (compile-file source :output-file binary)) + (load binary)))) + + ;; Now compile and load all the files. + ;; Defer compiler warnings until everything's compiled, if possible. + (#.(if (fboundp 'with-compilation-unit) + 'with-compilation-unit + #+lcl3.0 'lucid::with-deferred-warnings + #-lcl3.0 'progn) + () + + #+lucid + (progn + (when compile-c ; compile the C files + #+(and (not lcl3.0) (or mc68000 mc68020)) + (progn ; sequence patch + (format t "You may need to uudecode ms-patch.uu and copy~%") + (format t "the result to the binary directory.~%") + (format t "You also must rename the file to have the canonical~%") + (format t "binary file type in order for lisp to realize it's a~%") + (format t "binary file.~%")) + ;; compile socket.c + (let* ((src (merge-pathnames "socket.c" source-path)) + (obj (merge-pathnames "socket.o" binary-path)) + (args (list "-c" (namestring src) + "-o" (namestring obj) + "-DUNIXCONN"))) + (format t ";;; cc~{ ~a~}~%" args) + (multiple-value-bind (iostream estream exitstatus pid) + ;; in 2.0, run-program is exported from system: + ;; in 3.0, run-program is exported from lcl: + ;; system inheirits lcl + (system::run-program "cc" :arguments args) + (declare (ignore iostream estream pid)) + (if (/= 0 exitstatus) + (error "Exit status of socket.c compile is ~d" exitstatus))))) + (format t ";;; Loading foreign files~%") + (clx-foreign-files binary-path)) + + #+(or kcl ibcl) + (progn + (when compile-c ; compile the C files + (let* ((src (merge-pathnames "socket.c" source-path)) + (obj (merge-pathnames "socket.o" binary-path)) + (arg (format nil "cc -c ~a -o ~a -DUNIXCONN" + (namestring src) + (namestring obj)))) + (format t ";;; ~a~%" arg) + (if (/= 0 (system arg)) + (error "bad exit status for ~s" src)))) + ;; compile the lisp interface to the c code + (let ((src (merge-pathnames "sockcl" source-path)) + (obj (merge-pathnames "sockcl.o" binary-path))) + (compile-file src :output-file obj)) + (kcl-socket-init binary-path)) + + (compile-and-load "depdefs") + (compile-and-load "clx") + (compile-and-load "dependent") + (compile-and-load "macros") ; these are just macros + (compile-and-load "bufmac") ; these are just macros + (compile-and-load "buffer") + (compile-and-load "display") + (compile-and-load "gcontext") + (compile-and-load "input") + (compile-and-load "requests") + (compile-and-load "fonts") + (compile-and-load "graphics") + (compile-and-load "text") + (compile-and-load "attributes") + (compile-and-load "translate") + (compile-and-load "keysyms") + (compile-and-load "manager") + (compile-and-load "image") + (compile-and-load "resource") + )))) + + +;;;; Load CLX + +;;; This procedure loads the binaries for CLX. All of the binaries +;;; should be in the same directory, so setting the default pathname +;;; should point load to the right place. + +;;; You should have a module definition somewhere so the require/provide +;;; mechanism can avoid reloading CLX. In an ideal world, somebody would +;;; just put +;;; (REQUIRE 'CLX) +;;; in their file (some implementations don't have a central registry for +;;; modules, so a pathname needs to be supplied). + +;;; The REQUIRE should find a file that does +;;; (IN-PACKAGE 'XLIB :USE '(LISP)) +;;; (PROVIDE 'CLX) +;;; (LOAD <clx-defsystem-file>) +;;; (LOAD-CLX <binary-specific-clx-directory>) + +#-lispm +(defun load-clx (&optional (binary-pathname-defaults "") + &key (macros-p nil)) + + (let* ((source-path (pathname "")) + (path (make-pathname + :host (pathname-host source-path) + :device (pathname-device source-path) + :directory (pathname-directory source-path) + :name (pathname-name source-path) + :type nil + :version (pathname-version source-path))) + (binary-path (merge-pathnames binary-pathname-defaults + path))) + + (flet ((load-binary (filename) + (let ((binary (merge-pathnames filename binary-path))) + (load binary)))) + + #+lucid + (clx-foreign-files binary-path) + + #+(or kcl ibcl) + (kcl-socket-init binary-path) + + (load-binary "depdefs") + (load-binary "clx") + (load-binary "dependent") + (when macros-p + (load-binary "macros") + (load-binary "bufmac")) + (load-binary "buffer") + (load-binary "display") + (load-binary "gcontext") + (load-binary "input") + (load-binary "requests") + (load-binary "fonts") + (load-binary "graphics") + (load-binary "text") + (load-binary "attributes") + (load-binary "translate") + (load-binary "keysyms") + (load-binary "manager") + (load-binary "image") + (load-binary "resource") + ))) diff --git a/clx/depdefs.lisp b/clx/depdefs.lisp new file mode 100644 index 000000000..1f86c22d6 --- /dev/null +++ b/clx/depdefs.lisp @@ -0,0 +1,654 @@ +;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- + +;; This file contains some of the system dependent code for CLX + +;;; +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 +;;; +;;; Copyright (C) 1987 Texas Instruments Incorporated. +;;; +;;; Permission is granted to any individual or institution to use, copy, modify, +;;; and distribute this software, provided that this complete copyright and +;;; permission notice is maintained, intact, in all copies and supporting +;;; documentation. +;;; +;;; Texas Instruments Incorporated provides this software "as is" without +;;; express or implied warranty. +;;; + +(in-package :xlib) + +;;;------------------------------------------------------------------------- +;;; Declarations +;;;------------------------------------------------------------------------- + +;;; fix a bug in kcl's RATIONAL... +;;; redefine both the function and the type. + +#+(or kcl ibcl) +(shadow 'rational) + +#+(or kcl ibcl) +(progn + (defun rational (x) + (if (rationalp x) + x + (lisp:rational x))) + (deftype rational () 'lisp:rational)) + +;;; DECLAIM + +#-ansi-common-lisp +(defmacro declaim (&rest decl-specs) + (if (cdr decl-specs) + `(progn + ,@(mapcar #'(lambda (decl-spec) `(proclaim ',decl-spec)) + decl-specs)) + `(proclaim ',(car decl-specs)))) + +;;; VALUES value1 value2 ... -- Documents the values returned by the function. + +#-lispm +(declaim (declaration values)) + +;;; ARGLIST arg1 arg2 ... -- Documents the arglist of the function. Overrides +;;; the documentation that might get generated by the real arglist of the +;;; function. + +#+lispm +(import '(sys:arglist)) + +#+lcl3.0 +(import '(lcl:arglist)) + +#-(or lispm lcl3.0) +(declaim (declaration arglist)) + +;;; DOWNWARD-FUNARG name1 name2 ... -- Tells callers of this function that +;;; closures passed in as the argument named by name can be consed on the +;;; stack, as they have dynamic extent. In Genera keyword args can't be named +;;; this way. Instead use * to specify all functional args have dynamic +;;; extent. + +#+lispm +(import '(sys:downward-funarg)) + +#-lispm +(declaim (declaration downward-funarg)) + +;;; DYNAMIC-EXTENT var -- Tells the compiler that the rest arg var has +;;; dynamic extent and therefore can be kept on the stack and not copied to +;;; the heap, even though the value is passed out of the function. + +#+lcl3.0 +(import '(lcl:dynamic-extent)) + +#-(or ansi-common-lisp lcl3.0) +(declaim (declaration dynamic-extent)) + +;;; ARRAY-REGISTER var1 var2 ... -- The variables mentioned are locals (not +;;; args) that hold vectors. + +#+Genera +(import '(sys:array-register)) + +#-Genera +(declaim (declaration array-register)) + +;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to +;;; indent calls to the function or macro containing the declaration. + +#+genera +(import '(zwei:indentation)) + +#-genera +(declaim (declaration indentation)) + +;;;------------------------------------------------------------------------- +;;; Declaration macros +;;;------------------------------------------------------------------------- + +;;; WITH-VECTOR (variable type) &body body --- ensures the variable is a local +;;; and then does a type declaration and array register declaration +(defmacro with-vector ((var type) &body body) + `(let ((,var ,var)) + (declare (type ,type ,var) + (array-register ,var)) + ,@body)) + +;;; WITHIN-DEFINITION (name type) &body body --- Includes definitions for +;;; Meta-. + +#+lispm +(defmacro within-definition ((name type) &body body) + `(zl:local-declare + ((sys:function-parent ,name ,type)) + (sys:record-source-file-name ',name ',type) + ,@body)) + +#-lispm +(defmacro within-definition ((name type) &body body) + (declare (ignore name type)) + `(progn ,@body)) + + +;;;------------------------------------------------------------------------- +;;; CLX can maintain a mapping from X server ID's to local data types. If +;;; one takes the view that CLX objects will be instance variables of +;;; objects at the next higher level, then PROCESS-EVENT will typically map +;;; from resource-id to higher-level object. In that case, the lower-level +;;; CLX mapping will almost never be used (except in rare cases like +;;; query-tree), and only serve to consume space (which is difficult to +;;; GC), in which case always-consing versions of the make-<mumble>s will +;;; be better. Even when maps are maintained, it isn't clear they are +;;; useful for much beyond xatoms and windows (since almost nothing else +;;; ever comes back in events). +;;;-------------------------------------------------------------------------- +(defconstant *clx-cached-types* + '( drawable + window + pixmap +; gcontext + cursor + colormap + font)) + +(defmacro resource-id-map-test () + #+excl '#'equal + #-excl '#'eql) ; (eq fixnum fixnum) is not guaranteed. + +(defmacro keysym->character-map-test () + #+excl '#'equal + #-excl '#'eql) + +;;; You must define this to match the real byte order. It is used by +;;; overlapping array and image code. + +#+(or lispm vax little-endian) +(eval-when (eval compile load) + (pushnew :clx-little-endian *features*)) + +#+lcl3.0 +(eval-when (compile eval load) + (ecase lucid::machine-endian + (:big) + (:little (pushnew :clx-little-endian *features*)))) + +;;; Steele's Common-Lisp states: "It is an error if the array specified +;;; as the :displaced-to argument does not have the same :element-type +;;; as the array being created" If this is the case on your lisp, then +;;; leave the overlapping-arrays feature turned off. Lisp machines +;;; (Symbolics TI and LMI) don't have this restriction, and allow arrays +;;; with different element types to overlap. CLX will take advantage of +;;; this to do fast array packing/unpacking when the overlapping-arrays +;;; feature is enabled. + +#+(and clx-little-endian lispm) +(eval-when (eval compile load) + (pushnew :clx-overlapping-arrays *features*)) + +#+(and clx-overlapping-arrays genera) +(progn +(deftype overlap16 () '(unsigned-byte 16)) +(deftype overlap32 () '(signed-byte 32)) +) + +#+(and clx-overlapping-arrays (or explorer lambda cadr)) +(progn +(deftype overlap16 () '(unsigned-byte 16)) +(deftype overlap32 () '(unsigned-byte 32)) +) + +(deftype buffer-bytes () `(simple-array (unsigned-byte 8) (*))) + +#+clx-overlapping-arrays +(progn +(deftype buffer-words () `(vector overlap16)) +(deftype buffer-longs () `(vector overlap32)) +) + +;;; This defines a type which is a subtype of the integers. +;;; This type is used to describe all variables that can be array indices. +;;; It is here because it is used below. +;;; This is inclusive because start/end can be 1 past the end. +(deftype array-index () `(integer 0 ,array-dimension-limit)) + + +;; this is the best place to define these? + +#-Genera +(progn + +(defun make-index-typed (form) + (if (constantp form) form `(the array-index ,form))) + +(defun make-index-op (operator args) + `(the array-index + (values + ,(case (length args) + (0 `(,operator)) + (1 `(,operator + ,(make-index-typed (first args)))) + (2 `(,operator + ,(make-index-typed (first args)) + ,(make-index-typed (second args)))) + (otherwise + `(,operator + ,(make-index-op operator (subseq args 0 (1- (length args)))) + ,(make-index-typed (first (last args))))))))) + +(defmacro index+ (&rest numbers) (make-index-op '+ numbers)) +(defmacro index-logand (&rest numbers) (make-index-op 'logand numbers)) +(defmacro index-logior (&rest numbers) (make-index-op 'logior numbers)) +(defmacro index- (&rest numbers) (make-index-op '- numbers)) +(defmacro index* (&rest numbers) (make-index-op '* numbers)) + +(defmacro index1+ (number) (make-index-op '1+ (list number))) +(defmacro index1- (number) (make-index-op '1- (list number))) + +(defmacro index-incf (place &optional (delta 1)) + (make-index-op 'incf (list place delta))) +(defmacro index-decf (place &optional (delta 1)) + (make-index-op 'decf (list place delta))) + +(defmacro index-min (&rest numbers) (make-index-op 'min numbers)) +(defmacro index-max (&rest numbers) (make-index-op 'max numbers)) + +(defmacro index-floor (number divisor) + (make-index-op 'floor (list number divisor))) +(defmacro index-ceiling (number divisor) + (make-index-op 'ceiling (list number divisor))) +(defmacro index-truncate (number divisor) + (make-index-op 'truncate (list number divisor))) + +(defmacro index-mod (number divisor) + (make-index-op 'mod (list number divisor))) + +(defmacro index-ash (number count) + (make-index-op 'ash (list number count))) + +(defmacro index-plusp (number) `(plusp (the array-index ,number))) +(defmacro index-zerop (number) `(zerop (the array-index ,number))) +(defmacro index-evenp (number) `(evenp (the array-index ,number))) +(defmacro index-oddp (number) `(oddp (the array-index ,number))) + +(defmacro index> (&rest numbers) + `(> ,@(mapcar #'make-index-typed numbers))) +(defmacro index= (&rest numbers) + `(= ,@(mapcar #'make-index-typed numbers))) +(defmacro index< (&rest numbers) + `(< ,@(mapcar #'make-index-typed numbers))) +(defmacro index>= (&rest numbers) + `(>= ,@(mapcar #'make-index-typed numbers))) +(defmacro index<= (&rest numbers) + `(<= ,@(mapcar #'make-index-typed numbers))) + +) + +#+Genera +(progn + +(defmacro index+ (&rest numbers) `(+ ,@numbers)) +(defmacro index-logand (&rest numbers) `(logand ,@numbers)) +(defmacro index-logior (&rest numbers) `(logior ,@numbers)) +(defmacro index- (&rest numbers) `(- ,@numbers)) +(defmacro index* (&rest numbers) `(* ,@numbers)) + +(defmacro index1+ (number) `(1+ ,number)) +(defmacro index1- (number) `(1- ,number)) + +(defmacro index-incf (place &optional (delta 1)) `(setf ,place (index+ ,place ,delta))) +(defmacro index-decf (place &optional (delta 1)) `(setf ,place (index- ,place ,delta))) + +(defmacro index-min (&rest numbers) `(min ,@numbers)) +(defmacro index-max (&rest numbers) `(max ,@numbers)) + +(defun positive-power-of-two-p (x) + (and (typep x 'fixnum) (plusp x) (zerop (logand x (1- x))))) + +(defmacro index-floor (number divisor) + (cond ((eql divisor 1) number) + ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor)) + `(si:%fixnum-floor ,number ,divisor)) + (t `(floor ,number ,divisor)))) + +(defmacro index-ceiling (number divisor) + (cond ((eql divisor 1) number) + ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-ceiling)) + `(si:%fixnum-ceiling ,number ,divisor)) + (t `(ceiling ,number ,divisor)))) + +(defmacro index-truncate (number divisor) + (cond ((eql divisor 1) number) + ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor)) + `(si:%fixnum-floor ,number ,divisor)) + (t `(truncate ,number ,divisor)))) + +(defmacro index-mod (number divisor) + (cond ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-mod)) + `(si:%fixnum-mod ,number ,divisor)) + (t `(mod ,number ,divisor)))) + +(defmacro index-ash (number count) + (cond ((eql count 0) number) + ((and (typep count 'fixnum) (minusp count) (fboundp 'si:%fixnum-floor)) + `(si:%fixnum-floor ,number ,(expt 2 (- count)))) + ((and (typep count 'fixnum) (plusp count) (fboundp 'si:%fixnum-multiply)) + `(si:%fixnum-multiply ,number ,(expt 2 count))) + (t `(ash ,number ,count)))) + +(defmacro index-plusp (number) `(plusp ,number)) +(defmacro index-zerop (number) `(zerop ,number)) +(defmacro index-evenp (number) `(evenp ,number)) +(defmacro index-oddp (number) `(oddp ,number)) + +(defmacro index> (&rest numbers) `(> ,@numbers)) +(defmacro index= (&rest numbers) `(= ,@numbers)) +(defmacro index< (&rest numbers) `(< ,@numbers)) +(defmacro index>= (&rest numbers) `(>= ,@numbers)) +(defmacro index<= (&rest numbers) `(<= ,@numbers)) + +) + +;;;; Stuff for BUFFER definition + +(defconstant *replysize* 32.) + +;; used in defstruct initializations to avoid compiler warnings +(defvar *empty-bytes* (make-sequence 'buffer-bytes 0)) +(declaim (type buffer-bytes *empty-bytes*)) +#+clx-overlapping-arrays +(progn +(defvar *empty-words* (make-sequence 'buffer-words 0)) +(declaim (type buffer-words *empty-words*)) +) +#+clx-overlapping-arrays +(progn +(defvar *empty-longs* (make-sequence 'buffer-longs 0)) +(declaim (type buffer-longs *empty-longs*)) +) + +(defstruct (reply-buffer (:conc-name reply-) (:constructor make-reply-buffer-internal) + (:copier nil) (:predicate nil)) + (size 0 :type array-index) ;Buffer size + ;; Byte (8 bit) input buffer + (ibuf8 *empty-bytes* :type buffer-bytes) + ;; Word (16bit) input buffer + #+clx-overlapping-arrays + (ibuf16 *empty-words* :type buffer-words) + ;; Long (32bit) input buffer + #+clx-overlapping-arrays + (ibuf32 *empty-longs* :type buffer-longs) + (next nil #-explorer :type #-explorer (or null reply-buffer)) + (data-size 0 :type array-index) + ) + +(defconstant *buffer-text16-size* 256) +(deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,*buffer-text16-size*))) + +;; These are here because. + +(defparameter *xlib-package* (find-package 'xlib)) + +(defun xintern (&rest parts) + (intern (apply #'concatenate 'string (mapcar #'string parts)) *xlib-package*)) + +(defparameter *keyword-package* (find-package 'keyword)) + +(defun kintern (name) + (intern (string name) *keyword-package*)) + +;;; Pseudo-class mechanism. + +(defmacro def-clx-class ((name &rest options) &body slots) + (let ((clos-package (or (find-package 'clos) + (find-package 'pcl) + (let ((lisp-pkg (find-package 'lisp))) + (and (find-symbol (string 'defclass) lisp-pkg) + lisp-pkg))))) + (if clos-package + (let ((constructor t) + (constructor-args t) + (include nil) + (print-function nil) + (copier t) + (predicate t)) + (dolist (option options) + (ecase (pop option) + (:constructor + (setf constructor (pop option)) + (setf constructor-args (if (null option) t (pop option)))) + (:include + (setf include (pop option))) + (:print-function + (setf print-function (pop option))) + (:copier + (setf copier (pop option))) + (:predicate + (setf predicate (pop option))))) + (flet ((cintern (&rest symbols) + (intern (apply #'concatenate 'simple-string + (mapcar #'symbol-name symbols)) + *package*)) + (kintern (symbol) + (intern (symbol-name symbol) (find-package 'keyword))) + (closintern (symbol) + (intern (symbol-name symbol) clos-package))) + (when (eq constructor t) + (setf constructor (cintern 'make- name))) + (when (eq copier t) + (setf copier (cintern 'copy- name))) + (when (eq predicate t) + (setf predicate (cintern name '-p))) + (when include + (setf slots (append (get include 'def-clx-class) slots))) + (let* ((n-slots (length slots)) + (slot-names (make-list n-slots)) + (slot-initforms (make-list n-slots)) + (slot-types (make-list n-slots))) + (dotimes (i n-slots) + (let ((slot (elt slots i))) + (setf (elt slot-names i) (pop slot)) + (setf (elt slot-initforms i) (pop slot)) + (setf (elt slot-types i) (getf slot :type t)))) + `(progn + + (eval-when (compile load eval) + (setf (get ',name 'def-clx-class) ',slots)) + + ;; From here down are the system-specific expansions: + + ,(cond (clos-package + `(within-definition (,name def-clx-class) + (,(closintern 'defclass) + ,name ,(and include `(,include)) + (,@(map 'list + #'(lambda (slot-name slot-initform slot-type) + `(,slot-name + :initform ,slot-initform :type ,slot-type + :accessor ,(cintern name '- slot-name) + ,@(when (and constructor + (or (eq constructor-args t) + (member slot-name + constructor-args))) + `(:initarg ,(kintern slot-name))) + )) + slot-names slot-initforms slot-types))) + ,(when constructor + (if (eq constructor-args t) + `(defun ,constructor (&rest args) + (apply #',(closintern 'make-instance) + ',name args)) + `(defun ,constructor ,constructor-args + (,(closintern 'make-instance) ',name + ,@(mapcan #'(lambda (slot-name) + (and (member slot-name slot-names) + `(,(kintern slot-name) ,slot-name))) + constructor-args))))) + ,(when predicate + `(defun ,predicate (object) + (typep object ',name))) + ,(when copier + `(,(closintern 'defmethod) ,copier ((.object. ,name)) + (,(closintern 'with-slots) ,slot-names .object. + (,(closintern 'make-instance) ',name + ,@(mapcan #'(lambda (slot-name) + `(,(kintern slot-name) ,slot-name)) + slot-names))))) + ,(when print-function + `(,(closintern 'defmethod) + ,(closintern 'print-object) + ((object ,name) stream) + (,print-function object stream 0))))) + + #+Genera + (t + `(within-definition (,name def-clx-class) + (flavor:defflavor ,name + (,@(map 'list + #'(lambda (slot-name slot-initform) + `(,slot-name ,slot-initform)) + slot-names slot-initforms)) + ,(and include `(,include)) + :initable-instance-variables + :locatable-instance-variables + :readable-instance-variables + :writable-instance-variables + ,(if constructor + `(:constructor ,constructor + ,(if (eq constructor-args t) + `(&key ,@slot-names) + constructor-args)) + :abstract-flavor)) + ,(when predicate + `(defun ,predicate (object) + (typep object ',name))) + ,(when copier + (error ":COPIER not supported.")) + ,(when print-function + `(flavor:defmethod (sys:print-self ,name) + (stream depth *print-escape*) + (,print-function sys:self stream depth))) + (flavor:compile-flavor-methods ,name)))))))) + `(within-definition (,name def-clx-class) + (defstruct (,name ,@options) + ,@slots))))) + +#+Genera +(progn + (scl:defprop def-clx-class "CLX Class" si:definition-type-name) + (scl:defprop def-clx-class zwei:defselect-function-spec-finder + zwei:definition-function-spec-finder)) + + +;; We need this here so we can define DISPLAY for CLX. +;; +;; This structure is :INCLUDEd in the DISPLAY structure. +;; Overlapping (displaced) arrays are provided for byte +;; half-word and word access on both input and output. +;; +(def-clx-class (buffer (:constructor nil) (:copier nil) (:predicate nil)) + ;; Lock for multi-processing systems + (lock (make-process-lock "CLX Buffer Lock")) + #-excl (output-stream nil :type (or null stream)) + #+excl (output-stream -1 :type fixnum) + ;; Buffer size + (size 0 :type array-index) + (request-number 0 :type (unsigned-byte 16)) + ;; Byte position of start of last request + ;; used for appending requests and error recovery + (last-request nil :type (or null array-index)) + ;; Byte position of start of last flushed request + (last-flushed-request nil :type (or null array-index)) + ;; Current byte offset + (boffset 0 :type array-index) + ;; Byte (8 bit) output buffer + (obuf8 *empty-bytes* :type buffer-bytes) + ;; Word (16bit) output buffer + #+clx-overlapping-arrays + (obuf16 *empty-words* :type buffer-words) + ;; Long (32bit) output buffer + #+clx-overlapping-arrays + (obuf32 *empty-longs* :type buffer-longs) + ;; Holding buffer for 16-bit text + (tbuf16 (make-sequence 'buffer-text16 *buffer-text16-size* :initial-element 0)) + ;; Probably EQ to Output-Stream + #-excl (input-stream nil :type (or null stream)) + #+excl (input-stream -1 :type fixnum) + ;; T when the host connection has gotten errors + (dead nil :type (or null (not null))) + ;; T makes buffer-flush a noop. Manipulated with with-buffer-flush-inhibited. + (flush-inhibit nil :type (or null (not null))) + + ;; Change these functions when using shared memory buffers to the server + ;; Function to call when writing the buffer + (write-function 'buffer-write-default) + ;; Function to call when flushing the buffer + (force-output-function 'buffer-force-output-default) + ;; Function to call when closing a connection + (close-function 'buffer-close-default) + ;; Function to call when reading the buffer + (input-function 'buffer-read-default) + ;; Function to call to wait for data to be input + (input-wait-function 'buffer-input-wait-default) + ;; Function to call to listen for input data + (listen-function 'buffer-listen-default) + + #+Genera (debug-io nil :type (or null stream)) + ) + +;;----------------------------------------------------------------------------- +;; Printing routines. +;;----------------------------------------------------------------------------- + +#+(and (not ansi-common-lisp) Genera) +(import 'future-common-lisp:print-unreadable-object) + +#-(or ansi-common-lisp Genera) +(defun print-unreadable-object-function (object stream type identity function) + (princ "#<" stream) + (when type + (let ((type (type-of object)) + (pcl-package (find-package 'pcl))) + ;; Handle pcl type-of lossage + (when (and pcl-package + (symbolp type) + (eq (symbol-package type) pcl-package) + (string-equal (symbol-name type) "STD-INSTANCE")) + (setq type + (funcall (intern (symbol-name 'class-name) pcl-package) + (funcall (intern (symbol-name 'class-of) pcl-package) + object)))) + (prin1 type stream))) + (when (and type function) (princ " " stream)) + (when function (funcall function)) + (when (and (or type function) identity) (princ " " stream)) + (when identity (princ "???" stream)) + (princ ">" stream) + nil) + +#-(or ansi-common-lisp Genera) +(defmacro print-unreadable-object + ((object stream &key type identity) &body body) + `(print-unreadable-object-function + ,object ,stream ,type ,identity + ,(and body `#'(lambda () ,@body)))) + + +;;----------------------------------------------------------------------------- +;; Image stuff +;;----------------------------------------------------------------------------- + +(defconstant *image-bit-lsb-first-p* + #+clx-little-endian t + #-clx-little-endian nil) + +(defconstant *image-byte-lsb-first-p* + #+clx-little-endian t + #-clx-little-endian nil) + +(defconstant *image-unit* 32) + +(defconstant *image-pad* 32) diff --git a/clx/dependent.lisp b/clx/dependent.lisp new file mode 100644 index 000000000..b8e5a3d75 --- /dev/null +++ b/clx/dependent.lisp @@ -0,0 +1,3064 @@ +;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- + +;; This file contains some of the system dependent code for CLX + +;;; +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 +;;; +;;; Copyright (C) 1987 Texas Instruments Incorporated. +;;; +;;; Permission is granted to any individual or institution to use, copy, modify, +;;; and distribute this software, provided that this complete copyright and +;;; permission notice is maintained, intact, in all copies and supporting +;;; documentation. +;;; +;;; Texas Instruments Incorporated provides this software "as is" without +;;; express or implied warranty. +;;; + +(in-package :xlib) + +#+lcl3.0 +(import '( + lcl:define-condition + lcl:type-error + lucid::type-error-datum + lucid::type-error-expected-type + sys:underlying-simple-vector)) + +(export '( + char->card8 + card8->char + default-error-handler + #-ansi-common-lisp define-condition)) + +#+explorer +(zwei:define-indentation event-case (1 1)) + +;;; Number of seconds to wait for a reply to a server request +(defparameter *reply-timeout* nil) + +#-(or clx-overlapping-arrays (not clx-little-endian)) +(progn + (defconstant *word-0* 0) + (defconstant *word-1* 1) + + (defconstant *long-0* 0) + (defconstant *long-1* 1) + (defconstant *long-2* 2) + (defconstant *long-3* 3)) + +#-(or clx-overlapping-arrays clx-little-endian) +(progn + (defconstant *word-0* 1) + (defconstant *word-1* 0) + + (defconstant *long-0* 3) + (defconstant *long-1* 2) + (defconstant *long-2* 1) + (defconstant *long-3* 0)) + +;;; Set some compiler-options for often used code + +(eval-when (eval compile load) + +(defconstant *buffer-speed* 3 + "Speed compiler option for buffer code.") +(defconstant *buffer-safety* #+clx-debugging 3 #-clx-debugging 0 + "Safety compiler option for buffer code.") + +(defun declare-bufmac () + `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*)))) + +;;; It's my impression that in lucid there's some way to make a declaration +;;; called fast-entry or something that causes a function to not do some +;;; checking on args. Sadly, we have no lucid manuals here. If such a +;;; declaration is available, it would be a good idea to make it here when +;;; *buffer-speed* is 3 and *buffer-safety* is 0. +(defun declare-buffun () + `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*)))) + +) + +(declaim (inline card8->int8 int8->card8 + card16->int16 int16->card16 + card32->int32 int32->card32)) + +#-Genera +(progn + +(defun card8->int8 (x) + (declare (type card8 x)) + (declare (values int8)) + #.(declare-buffun) + (the int8 (if (logbitp 7 x) + (the int8 (- x #x100)) + x))) + +(defun int8->card8 (x) + (declare (type int8 x)) + (declare (values card8)) + #.(declare-buffun) + (the card8 (ldb (byte 8 0) x))) + +(defun card16->int16 (x) + (declare (type card16 x)) + (declare (values int16)) + #.(declare-buffun) + (the int16 (if (logbitp 15 x) + (the int16 (- x #x10000)) + x))) + +(defun int16->card16 (x) + (declare (type int16 x)) + (declare (values card16)) + #.(declare-buffun) + (the card16 (ldb (byte 16 0) x))) + +(defun card32->int32 (x) + (declare (type card32 x)) + (declare (values int32)) + #.(declare-buffun) + (the int32 (if (logbitp 31 x) + (the int32 (- x #x100000000)) + x))) + +(defun int32->card32 (x) + (declare (type int32 x)) + (declare (values card32)) + #.(declare-buffun) + (the card32 (ldb (byte 32 0) x))) + +) + +#+Genera +(progn + +(defun card8->int8 (x) + (declare lt:(side-effects simple reducible)) + (if (logbitp 7 x) (- x #x100) x)) + +(defun int8->card8 (x) + (declare lt:(side-effects simple reducible)) + (ldb (byte 8 0) x)) + +(defun card16->int16 (x) + (declare lt:(side-effects simple reducible)) + (if (logbitp 15 x) (- x #x10000) x)) + +(defun int16->card16 (x) + (declare lt:(side-effects simple reducible)) + (ldb (byte 16 0) x)) + +(defun card32->int32 (x) + (declare lt:(side-effects simple reducible)) + (sys:%logldb (byte 32 0) x)) + +(defun int32->card32 (x) + (declare lt:(side-effects simple reducible)) + (ldb (byte 32 0) x)) + +) + +(declaim (inline aref-card8 aset-card8 aref-int8 aset-int8)) + +#-(or Genera lcl3.0) +(progn + +(defun aref-card8 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values card8)) + #.(declare-buffun) + (the card8 (aref a i))) + +(defun aset-card8 (v a i) + (declare (type card8 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (aref a i) v)) + +(defun aref-int8 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values int8)) + #.(declare-buffun) + (card8->int8 (aref a i))) + +(defun aset-int8 (v a i) + (declare (type int8 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (aref a i) (int8->card8 v))) + +) + +#+Genera +(progn + +(defun aref-card8 (a i) + (aref a i)) + +(defun aset-card8 (v a i) + (zl:aset v a i)) + +(defun aref-int8 (a i) + (card8->int8 (aref a i))) + +(defun aset-int8 (v a i) + (zl:aset (int8->card8 v) a i)) + +) + +#+lcl3.0 ;in lcl2.1 these symbols are in different packages and making too + ;many conditionalizations makes my brain hurt. +(progn + +(defun aref-card8 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values card8)) + #.(declare-buffun) + (the card8 (sys:svref-8bit a i))) + +(defun aset-card8 (v a i) + (declare (type card8 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:svref-8bit a i) v)) + +(defun aref-int8 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values int8)) + #.(declare-buffun) + (the int8 (sys:svref-signed-8bit a i))) + +(defun aset-int8 (v a i) + (declare (type int8 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:svref-signed-8bit a i) v)) + +) + +#+clx-overlapping-arrays +(declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29 + aset-card16 aset-int16 aset-card32 aset-int32 aset-card29)) + +#+(and clx-overlapping-arrays Genera) +(progn + +(defun aref-card16 (a i) + (aref a i)) + +(defun aset-card16 (v a i) + (zl:aset v a i)) + +(defun aref-int16 (a i) + (card16->int16 (aref a i))) + +(defun aset-int16 (v a i) + (zl:aset (int16->card16 v) a i) + v) + +(defun aref-card32 (a i) + (int32->card32 (aref a i))) + +(defun aset-card32 (v a i) + (zl:aset (card32->int32 v) a i)) + +(defun aref-int32 (a i) (aref a i)) + +(defun aset-int32 (v a i) + (zl:aset v a i)) + +(defun aref-card29 (a i) + (aref a i)) + +(defun aset-card29 (v a i) + (zl:aset v a i)) + +) + +#+(and clx-overlapping-arrays (not Genera)) +(progn + +(defun aref-card16 (a i) + (aref a i)) + +(defun aset-card16 (v a i) + (setf (aref a i) v)) + +(defun aref-int16 (a i) + (card16->int16 (aref a i))) + +(defun aset-int16 (v a i) + (setf (aref a i) (int16->card16 v)) + v) + +(defun aref-card32 (a i) + (aref a i)) + +(defun aset-card32 (v a i) + (setf (aref a i) v)) + +(defun aref-int32 (a i) + (card32->int32 (aref a i))) + +(defun aset-int32 (v a i) + (setf (aref a i) (int32->card32 v)) + v) + +(defun aref-card29 (a i) + (aref a i)) + +(defun aset-card29 (v a i) + (setf (aref a i) v)) + +) + +#+excl +(progn + + (defun aref-card16 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values card16)) + #.(declare-buffun) + (the card16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :unsigned-word))) + + (defun aset-card16 (v a i) + (declare (type card16 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :unsigned-word) v)) + + (defun aref-int16 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values int16)) + #.(declare-buffun) + (the int16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :signed-word))) + + (defun aset-int16 (v a i) + (declare (type int16 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :signed-word) v)) + + (defun aref-card32 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values card32)) + #.(declare-buffun) + (the card32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :unsigned-long))) + + (defun aset-card32 (v a i) + (declare (type card32 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :unsigned-long) v)) + + (defun aref-int32 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values int32)) + #.(declare-buffun) + (the int32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :signed-long))) + + (defun aset-int32 (v a i) + (declare (type int32 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :signed-long) v)) + + (defun aref-card29 (a i) + ;; Do I need to mask off a few bits here? XXX + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values card29)) + #.(declare-buffun) + (the card29 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :unsigned-long))) + + (defun aset-card29 (v a i) + (declare (type card29 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :unsigned-long) v)) + + +) + +#+lcl3.0 +(progn ;; all these lucid optimizations need to be compiled to work. + +(defun aref-card16 (a i) + #.(declare-buffun) + (the card16 (sys:svref-16bit (the buffer-bytes a) + (lucid:ash& (the array-index i) -1)))) + +(defun aset-card16 (v a i) + #.(declare-buffun) + (setf (sys:svref-16bit (the buffer-bytes a) + (lucid:ash& (the array-index i) -1)) + (the card16 v))) + +(defun aref-int16 (a i) + #.(declare-buffun) + (the int16 + (sys:svref-signed-16bit (the buffer-bytes a) + (lucid:ash& (the array-index i) -1)))) + +(defun aset-int16 (v a i) + #.(declare-buffun) + (setf (sys:svref-signed-16bit (the buffer-bytes a) + (lucid:ash& (the array-index i) -1)) + (the int16 v))) + +(defun aref-card32 (a i) + #.(declare-buffun) + (the card32 + (sys:svref-32bit (the buffer-bytes a) + (lucid:ash& (the array-index i) -2)))) + +(defun aset-card32 (v a i) + #.(declare-buffun) + (setf (sys:svref-32bit (the buffer-bytes a) + (lucid:ash& (the array-index i) -2)) + (the card32 v))) + +(defun aref-int32 (a i) + #.(declare-buffun) + (the int32 + (sys:svref-signed-32bit (the buffer-bytes a) + (lucid:ash& (the array-index i) -2)))) + +(defun aset-int32 (v a i) + #.(declare-buffun) + (setf (sys:svref-signed-32bit (the buffer-bytes a) + (lucid:ash& (the array-index i) -2)) + (the int32 v))) + +(defun aref-card29 (a i) + ;; Don't need to mask bits here since X protocol guarantees top bits zero + #.(declare-buffun) + (the card29 + (sys:svref-32bit (the buffer-bytes a) + (lucid:ash& (the array-index i) -2)))) + +(defun aset-card29 (v a i) + ;; I also assume here Lisp is passing a number that fits in 29 bits. + #.(declare-buffun) + (setf (sys:svref-32bit (the buffer-bytes a) + (lucid:ash& (the array-index i) -2)) + (the card29 v))) +) + + + +#-(or excl lcl3.0 clx-overlapping-arrays) +(progn + +(defun aref-card16 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values card16)) + #.(declare-buffun) + (the card16 + (logior (the card16 + (ash (the card8 (aref a (index+ i *word-1*))) 8)) + (the card8 + (aref a (index+ i *word-0*)))))) + +(defun aset-card16 (v a i) + (declare (type card16 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (aref a (index+ i *word-1*)) (the card8 (ldb (byte 8 8) v)) + (aref a (index+ i *word-0*)) (the card8 (ldb (byte 8 0) v))) + v) + +(defun aref-int16 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values int16)) + #.(declare-buffun) + (the int16 + (logior (the int16 + (ash (the int8 (aref-int8 a (index+ i *word-1*))) 8)) + (the card8 + (aref a (index+ i *word-0*)))))) + +(defun aset-int16 (v a i) + (declare (type int16 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (aref a (index+ i *word-1*)) (the card8 (ldb (byte 8 8) v)) + (aref a (index+ i *word-0*)) (the card8 (ldb (byte 8 0) v))) + v) + +(defun aref-card32 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values card32)) + #.(declare-buffun) + (the card32 + (logior (the card32 + (ash (the card8 (aref a (index+ i *long-3*))) 24)) + (the card29 + (ash (the card8 (aref a (index+ i *long-2*))) 16)) + (the card16 + (ash (the card8 (aref a (index+ i *long-1*))) 8)) + (the card8 + (aref a (index+ i *long-0*)))))) + +(defun aset-card32 (v a i) + (declare (type card32 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v)) + (aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v)) + (aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v)) + (aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v))) + v) + +(defun aref-int32 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values int32)) + #.(declare-buffun) + (the int32 + (logior (the int32 + (ash (the int8 (aref-int8 a (index+ i *long-3*))) 24)) + (the card29 + (ash (the card8 (aref a (index+ i *long-2*))) 16)) + (the card16 + (ash (the card8 (aref a (index+ i *long-1*))) 8)) + (the card8 + (aref a (index+ i *long-0*)))))) + +(defun aset-int32 (v a i) + (declare (type int32 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v)) + (aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v)) + (aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v)) + (aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v))) + v) + +(defun aref-card29 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values card29)) + #.(declare-buffun) + (the card29 + (logior (the card29 + (ash (the card8 (aref a (index+ i *long-3*))) 24)) + (the card29 + (ash (the card8 (aref a (index+ i *long-2*))) 16)) + (the card16 + (ash (the card8 (aref a (index+ i *long-1*))) 8)) + (the card8 + (aref a (index+ i *long-0*)))))) + +(defun aset-card29 (v a i) + (declare (type card29 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v)) + (aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v)) + (aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v)) + (aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v))) + v) + +) + +(defsetf aref-card8 (a i) (v) + `(aset-card8 ,v ,a ,i)) + +(defsetf aref-int8 (a i) (v) + `(aset-int8 ,v ,a ,i)) + +(defsetf aref-card16 (a i) (v) + `(aset-card16 ,v ,a ,i)) + +(defsetf aref-int16 (a i) (v) + `(aset-int16 ,v ,a ,i)) + +(defsetf aref-card32 (a i) (v) + `(aset-card32 ,v ,a ,i)) + +(defsetf aref-int32 (a i) (v) + `(aset-int32 ,v ,a ,i)) + +(defsetf aref-card29 (a i) (v) + `(aset-card29 ,v ,a ,i)) + +;;; Other random conversions + +(defun rgb-val->card16 (value) + ;; Short floats are good enough + (declare (type rgb-val value)) + (declare (values card16)) + #.(declare-buffun) + ;; Convert VALUE from float to card16 + (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff))))) + +(defun card16->rgb-val (value) + ;; Short floats are good enough + (declare (type card16 value)) + (declare (values short-float)) + #.(declare-buffun) + ;; Convert VALUE from card16 to float + (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff)))) + +(defun radians->int16 (value) + ;; Short floats are good enough + (declare (type angle value)) + (declare (values int16)) + #.(declare-buffun) + (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0))))) + +(defun int16->radians (value) + ;; Short floats are good enough + (declare (type int16 value)) + (declare (values short-float)) + #.(declare-buffun) + (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float)))) + + +;;----------------------------------------------------------------------------- +;; Character transformation +;;----------------------------------------------------------------------------- + + +;;; This stuff transforms chars to ascii codes in card8's and back. +;;; You might have to hack it a little to get it to work for your machine. + +(declaim (inline char->card8 card8->char)) + +(macrolet ((char-translators () + (let ((alist + `(#-lispm + ;; The normal ascii codes for the control characters. + ,@`((#\Return . 13) + (#\Linefeed . 10) + (#\Rubout . 127) + (#\Page . 12) + (#\Tab . 9) + (#\Backspace . 8) + (#\Newline . 10) + (#\Space . 32)) + ;; One the lispm, #\Newline is #\Return, but we'd really like + ;; #\Newline to translate to ascii code 10, so we swap the + ;; Ascii codes for #\Return and #\Linefeed. We also provide + ;; mappings from the counterparts of these control characters + ;; so that the character mapping from the lisp machine + ;; character set to ascii is invertible. + #+lispm + ,@`((#\Return . 10) (,(code-char 10) . ,(char-code #\Return)) + (#\Linefeed . 13) (,(code-char 13) . ,(char-code #\Linefeed)) + (#\Rubout . 127) (,(code-char 127) . ,(char-code #\Rubout)) + (#\Page . 12) (,(code-char 12) . ,(char-code #\Page)) + (#\Tab . 9) (,(code-char 9) . ,(char-code #\Tab)) + (#\Backspace . 8) (,(code-char 8) . ,(char-code #\Backspace)) + (#\Newline . 10) (,(code-char 10) . ,(char-code #\Newline)) + (#\Space . 32) (,(code-char 32) . ,(char-code #\Space))) + ;; The rest of the common lisp charater set with the normal + ;; ascii codes for them. + (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) + (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) + (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) + (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) + (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) + (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) + (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) + (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) + (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) + (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) + (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) + (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) + (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) + (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) + (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) + (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) + (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) + (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) + (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) + (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) + (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) + (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) + (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) + (#\} . 125) (#\~ . 126)))) + (cond ((dolist (pair alist nil) + (when (not (= (char-code (car pair)) (cdr pair))) + (return t))) + `(progn + (defconstant *char-to-card8-translation-table* + ',(let ((array (make-array + (let ((max-char-code 255)) + (dolist (pair alist) + (setq max-char-code + (max max-char-code + (char-code (car pair))))) + (1+ max-char-code)) + :element-type 'card8))) + (dotimes (i (length array)) + (setf (aref array i) (mod i 256))) + (dolist (pair alist) + (setf (aref array (char-code (car pair))) + (cdr pair))) + array)) + (defconstant *card8-to-char-translation-table* + ',(let ((array (make-string 256))) + (dotimes (i (length array)) + (setf (aref array i) (code-char i))) + (dolist (pair alist) + (setf (aref array (cdr pair)) (car pair))) + array)) + #-Genera + (progn + (defun char->card8 (char) + (declare (type string-char char)) + #.(declare-buffun) + (the card8 (aref (the (simple-array card8 (*)) + *char-to-card8-translation-table*) + (the array-index (char-code char))))) + (defun card8->char (card8) + (declare (type card8 card8)) + #.(declare-buffun) + (the string-char + (aref (the simple-string *card8-to-char-translation-table*) + card8))) + ) + #+Genera + (progn + (defun char->card8 (char) + (declare lt:(side-effects reader reducible)) + (aref *char-to-card8-translation-table* (char-code char))) + (defun card8->char (card8) + (declare lt:(side-effects reader reducible)) + (aref *card8-to-char-translation-table* card8)) + ) + (dotimes (i 256) + (unless (= i (char->card8 (card8->char i))) + (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" + (list i + (card8->char i) + (char->card8 (card8->char i)))) + (return nil))) + (dotimes (i (length *char-to-card8-translation-table*)) + (let ((char (code-char i))) + (unless (eql char (card8->char (char->card8 char))) + (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S" + (list char + (char->card8 char) + (card8->char (char->card8 char)))) + (return nil)))))) + (t + `(progn + (defun char->card8 (char) + (declare (type string-char char)) + #.(declare-buffun) + (the card8 (char-code char))) + (defun card8->char (card8) + (declare (type card8 card8)) + #.(declare-buffun) + (the string-char (code-char card8))) + )))))) + (char-translators)) + +;;----------------------------------------------------------------------------- +;; Process Locking +;; +;; Common-Lisp doesn't provide process locking primitives, so we define +;; our own here, based on Zetalisp primitives. Holding-Lock is very +;; similar to with-lock on The TI Explorer, and a little more efficient +;; than with-process-lock on a Symbolics. +;;----------------------------------------------------------------------------- + +;;; MAKE-PROCESS-LOCK: Creating a process lock. + +#-(or LispM excl) +(defun make-process-lock (name) + (declare (ignore name)) + nil) + +#+excl +(defun make-process-lock (name) + (mp:make-process-lock :name name)) + +#+(and LispM (not Genera)) +(defun make-process-lock (name) + (vector nil name)) + +#+Genera +(defun make-process-lock (name) + (process:make-lock name :flavor 'clx-lock)) + +;;; HOLDING-LOCK: Execute a body of code with a lock held. + +;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN +;;; passes its timeout to the holding-lock macro, so any timeout you want to +;;; work for event-listen you should do for holding-lock. + +;; If you're not sharing DISPLAY objects within a multi-processing +;; shared-memory environment, this is sufficient +#-(or lispm excl lcl3.0) +(defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) + (declare (ignore locator display whostate timeout)) + `(progn ,@body)) + +#+Genera +(defmacro holding-lock ((locator display &optional whostate &key timeout) + &body body) + (declare (ignore whostate)) + `(process:with-lock (,locator :timeout ,timeout) + (let ((.debug-io. (buffer-debug-io ,display))) + (scl:let-if .debug-io. ((*debug-io* .debug-io.)) + ,@body)))) + +#+(and lispm (not Genera)) +(defmacro holding-lock ((locator display &optional whostate &key timeout) + &body body) + (declare (ignore display)) + ;; This macro is for use in a multi-process environment. + (let ((lock (gensym)) + (have-lock (gensym)) + (timeo (gensym))) + `(let* ((,lock (zl:locf (svref ,locator 0))) + (,have-lock (eq (car ,lock) sys:current-process)) + (,timeo ,timeout)) + (unwind-protect + (when (cond (,have-lock) + ((#+explorer si:%store-conditional + #-explorer sys:store-conditional + ,lock nil sys:current-process)) + ((null ,timeo) + (sys:process-lock ,lock nil ,(or whostate "CLX Lock"))) + ((sys:process-wait-with-timeout + ,(or whostate "CLX Lock") (round (* ,timeo 60.)) + #'(lambda (lock process) + (#+explorer si:%store-conditional + #-explorer sys:store-conditional + lock nil process)) + ,lock sys:current-process))) + ,@body) + (unless ,have-lock + (#+explorer si:%store-conditional + #-explorer sys:store-conditional + ,lock sys:current-process nil)))))) + +;; Lucid has a process locking mechanism as well under release 3.0 +#+lcl3.0 +(defmacro holding-lock ((locator display &optional whostate &key timeout) + &body body) + (declare (ignore display)) + (if timeout + ;; Hair to support timeout. + `(let ((.have-lock. (eq ,locator lcl:*current-process*)) + (.timeout. ,timeout)) + (unwind-protect + (when (cond (.have-lock.) + ((conditional-store ,locator nil lcl:*current-process*)) + ((null .timeout.) + (lcl:process-lock ,locator) + t) + ((lcl:process-wait-with-timeout ,whostate .timeout. + #'(lambda () + (conditional-store ,locator nil lcl:*current-process*))))) + ,@body) + (unless .have-lock. + (lcl:process-unlock ,locator)))) + `(lcl:with-process-lock (,locator) + ,@body))) + + +#+excl +(defmacro holding-lock ((locator display &optional whostate &key timeout) + &body body) + (declare (ignore display)) + `(let (.hl-lock. .hl-obtained-lock. .hl-curproc.) + (unwind-protect + (block .hl-doit. + (when mp::*scheduler-stack-group* ; fast test for scheduler running + (setq .hl-lock. ,locator + .hl-curproc. mp::*current-process*) + (when (and .hl-curproc. ; nil if in process-wait fun + (not (eq (mp::process-lock-locker .hl-lock.) + .hl-curproc.))) + ;; Then we need to grab the lock. + ,(if timeout + `(if (not (mp::process-lock .hl-lock. .hl-curproc. + ,whostate ,timeout)) + (return-from .hl-doit. nil)) + `(mp::process-lock .hl-lock. .hl-curproc. + ,@(when whostate `(,whostate)))) + (setq .hl-obtained-lock. t))) + ,@body) + (if (and .hl-obtained-lock. + ;; Note -- next form added to allow error handler inside + ;; body to unlock the lock prematurely if it knows that + ;; the current process cannot possibly continue but will + ;; throw out (or is it throw up?). + (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.)) + (mp::process-unlock .hl-lock. .hl-curproc.))))) + + +;;; WITHOUT-ABORTS + +;;; If you can inhibit asynchronous keyboard aborts inside the body of this +;;; macro, then it is a good idea to do this. This macro is wrapped around +;;; request writing and reply reading to ensure that requests are atomically +;;; written and replies are atomically read from the stream. + +#-(or Genera excl lcl3.0) +(defmacro without-aborts (&body body) + `(progn ,@body)) + +#+Genera +(defmacro without-aborts (&body body) + `(sys:without-aborts (clx "CLX is in the middle of an operation that should be atomic.") + ,@body)) + +#+excl +(defmacro without-aborts (&body body) + `(without-interrupts ,@body)) + +#+lcl3.0 +(defmacro without-aborts (&body body) + `(lcl:with-interruptions-inhibited ,@body)) + +;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value. +;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's +;;; value changes. + +#-(or lispm excl lcl3.0) +(defun process-block (whostate predicate &rest predicate-args) + (declare (ignore whostate)) + (or (apply predicate predicate-args) + (error "Program tried to wait with no scheduler."))) + +#+Genera +(defun process-block (whostate predicate &rest predicate-args) + (declare (type function predicate) + (downward-funarg predicate)) + (apply #'process:block-process whostate predicate predicate-args)) + +#+(and lispm (not Genera)) +(defun process-block (whostate predicate &rest predicate-args) + (declare (type function predicate) + (downward-funarg predicate)) + (apply #'global:process-wait whostate predicate predicate-args)) + +#+excl +(defun process-block (whostate predicate &rest predicate-args) + (if mp::*scheduler-stack-group* + (apply #'mp::process-wait whostate predicate predicate-args) + (or (apply predicate predicate-args) + (error "Program tried to wait with no scheduler.")))) + +#+lcl3.0 +(defun process-block (whostate predicate &rest predicate-args) + (declare (dynamic-extent predicate-args)) + (apply #'lcl:process-wait whostate predicate predicate-args)) + +;;; PROCESS-WAKEUP: Check some other process' wait function. + +(declaim (inline process-wakeup)) + +#-(or excl Genera) +(defun process-wakeup (process) + (declare (ignore process)) + nil) + +#+excl +(defun process-wakeup (process) + (let ((curproc mp::*current-process*)) + (when (and curproc process) + (unless (mp::process-p curproc) + (error "~s is not a process" curproc)) + (unless (mp::process-p process) + (error "~s is not a process" process)) + (if (> (mp::process-priority process) (mp::process-priority curproc)) + (mp::process-allow-schedule process))))) + +#+Genera +(defun process-wakeup (process) + (process:wakeup process)) + +;;; CURRENT-PROCESS: Return the current process object for input locking and +;;; for calling PROCESS-WAKEUP. + +(declaim (inline current-process)) + +;;; Default return NIL, which is acceptable even if there is a scheduler. + +#-(or lispm excl lcl3.0) +(defun current-process () + nil) + +#+lispm +(defun current-process () + sys:current-process) + +#+excl +(defun current-process () + (and mp::*scheduler-stack-group* + mp::*current-process*)) + +#+lcl3.0 +(defun current-process () + lcl:*current-process*) + +;;; WITHOUT-INTERRUPTS -- provide for atomic operations. + +#-(or lispm excl lcl3.0) +(defmacro without-interrupts (&body body) + `(progn ,@body)) + +#+(and lispm (not Genera)) +(defmacro without-interrupts (&body body) + `(sys:without-interrupts ,@body)) + +#+Genera +(defmacro without-interrupts (&body body) + `(process:with-no-other-processes ,@body)) + +#+LCL3.0 +(defmacro without-interrupts (&body body) + `(lcl:with-scheduling-inhibited ,@body)) + +;;; CONDITIONAL-STORE: + +;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times. +;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD. +(defmacro conditional-store (place old-value new-value) + `(without-interrupts + (cond ((eq ,place ,old-value) + (setf ,place ,new-value) + t)))) + +;;;---------------------------------------------------------------------------- +;;; IO Error Recovery +;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro. +;;; It prevents multiple mindless errors when the network craters. +;;; +;;;---------------------------------------------------------------------------- + +#-Genera +(defmacro wrap-buf-output ((buffer) &body body) + ;; Error recovery wrapper + `(unless (buffer-dead ,buffer) + ,@body)) + +#+Genera +(defmacro wrap-buf-output ((buffer) &body body) + ;; Error recovery wrapper + `(let ((.buffer. ,buffer)) + (unless (buffer-dead .buffer.) + (scl:condition-bind + (((sys:network-error) + #'(lambda (error) + (scl:condition-case () + (funcall (buffer-close-function .buffer.) .buffer. :abort t) + (sys:network-error)) + (setf (buffer-dead .buffer.) error) + (setf (buffer-output-stream .buffer.) nil) + (setf (buffer-input-stream .buffer.) nil) + nil))) + ,@body)))) + +#-Genera +(defmacro wrap-buf-input ((buffer) &body body) + (declare (ignore buffer)) + ;; Error recovery wrapper + `(progn ,@body)) + +#+Genera +(defmacro wrap-buf-input ((buffer) &body body) + ;; Error recovery wrapper + `(let ((.buffer. ,buffer)) + (scl:condition-bind + (((sys:network-error) + #'(lambda (error) + (scl:condition-case () + (funcall (buffer-close-function .buffer.) .buffer. :abort t) + (sys:network-error)) + (setf (buffer-dead .buffer.) error) + (setf (buffer-output-stream .buffer.) nil) + (setf (buffer-input-stream .buffer.) nil) + nil))) + ,@body))) + + +;;;---------------------------------------------------------------------------- +;;; System dependent IO primitives +;;; Functions for opening, reading writing forcing-output and closing +;;; the stream to the server. +;;;---------------------------------------------------------------------------- + +;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X +;;; server + +#-(or explorer Genera lucid kcl ibcl excl) +(defun open-x-stream (host display protocol) + host display protocol ;; unused + (error "OPEN-X-STREAM not implemented yet.")) + +;;; Genera: + +;;; TCP and DNA are both layered products, so try to work with either one. + +#+Genera +(when (fboundp 'tcp:add-tcp-port-for-protocol) + (tcp:add-tcp-port-for-protocol :x-window-system 6000)) + +#+Genera +(when (fboundp 'dna:add-dna-contact-id-for-protocol) + (dna:add-dna-contact-id-for-protocol :x-window-system "X$X0")) + +#+Genera +(net:define-protocol :x-window-system (:x-window-system :byte-stream) + (:invoke-with-stream ((stream :characters nil :ascii-translation nil)) + stream)) + +#+Genera +(eval-when (compile) + (compiler:function-defined 'tcp:open-tcp-stream) + (compiler:function-defined 'dna:open-dna-bidirectional-stream)) + +#+Genera +(defun open-x-stream (host display protocol) + (let ((host (net:parse-host host))) + (if (or protocol (plusp display)) + ;; The protocol was specified or the display isn't 0, so we + ;; can't use the Generic Network System. If the protocol was + ;; specified, then use that protocol, otherwise, blindly use + ;; TCP. + (ccase protocol + ((:tcp nil) + (tcp:open-tcp-stream + host (+ *x-tcp-port* display) nil + :direction :io + :characters nil + :ascii-translation nil)) + ((:dna) + (dna:open-dna-bidirectional-stream + host (format nil "X$X~D" display) + :characters nil + :ascii-translation nil))) + (let ((neti:*invoke-service-automatic-retry* t)) + (net:invoke-service-on-host :x-window-system host))))) + +#+explorer +(defun open-x-stream (host display protocol) + (declare (ignore protocol)) + (net:open-connection-on-medium + (net:parse-host host) ;Host + :byte-stream ;Medium + "X11" ;Logical contact name + :stream-type :character-stream + :direction :bidirectional + :timeout-after-open nil + :remote-port (+ *x-tcp-port* display))) + +#+explorer +(net:define-logical-contact-name + "X11" + `((:local "X11") + (:chaos "X11") + (:nsp-stream "X11") + (:tcp ,*x-tcp-port*))) + +#+lucid +(defun open-x-stream (host display protocol) + protocol ;; unused + (let ((fd (connect-to-server host display))) + (when (minusp fd) + (error "Failed to connect to server: ~A ~D" host display)) + (user::make-lisp-stream :input-handle fd + :output-handle fd + :element-type 'unsigned-byte + #-lcl3.0 :stream-type #-lcl3.0 :ephemeral))) + +#+(or kcl ibcl) +(defun open-x-stream (host display protocol) + protocol ;; unused + (let ((stream (open-socket-stream host display))) + (if (streamp stream) + stream + (error "Cannot connect to server: ~A:~D" host display)))) + +#+excl +;; +;; Note that since we don't use the CL i/o facilities to do i/o, the display +;; input and output "stream" is really a file descriptor (fixnum). +;; +(defun open-x-stream (host display protocol) + (declare (ignore protocol));; unused + (let ((fd (connect-to-server (string host) display))) + (when (minusp fd) + (error "Failed to connect to server: ~A ~D" host display)) + fd)) + +;;; BUFFER-READ-DEFAULT - read data from the X stream + +#+(or Genera explorer) +(defun buffer-read-default (display vector start end timeout) + ;; returns non-NIL if EOF encountered + ;; Returns :TIMEOUT when timeout exceeded + (declare (type display display) + (type buffer-bytes vector) + (type array-index start end) + (type (or null number) timeout)) + #.(declare-buffun) + (let ((stream (display-input-stream display))) + (or (cond ((null stream)) + ((funcall stream :listen) nil) + ((eql timeout 0) :timeout) + ((buffer-input-wait-default display timeout))) + (multiple-value-bind (ignore eofp) + (funcall stream :string-in nil vector start end) + eofp)))) + + +#+excl +;; +;; Rewritten 10/89 to not use foreign function interface to do I/O. +;; +(defun buffer-read-default (display vector start end timeout) + (declare (type display display) + (type buffer-bytes vector) + (type array-index start end) + (type (or null number) timeout)) + #.(declare-buffun) + + (let* ((howmany (- end start)) + (fd (display-input-stream display))) + (declare (type array-index howmany) + (fixnum fd)) + + (or (cond ((fd-char-avail-p fd) nil) + ((eql timeout 0) :timeout) + ((buffer-input-wait-default display timeout))) + (fd-read-bytes fd vector start howmany)))) + + +#+lcl3.0 +(defmacro extract-underlying-stream (stream display direction) + ;;;Our job is to quickly get at the underlying stream for this display's + ;;;input stream structure. + `(or (getf (display-plist ,display) ,direction) + (setf (getf (display-plist ,display) ,direction) + (lucid::underlying-stream + ,stream (if (eq ,direction 'input) :input :output))))) + +#+lcl3.0 +(defun buffer-read-default (display vector start end timeout) + ;;Note that LISTEN must still be done on "slow stream" or the I/O system + ;;gets confused. But reading should be done from "fast stream" for speed. + ;;We used to inhibit scheduling because there were races in Lucid's + ;;multitasking system. Empirical evidence suggests they may be gone now. + ;;Should you decide you need to inhibit scheduling, do it around the do*. + (declare (type display display) + (type buffer-bytes vector) + (type array-index start end) + (type (or null number) timeout) + (optimize (speed 3) + (safety 0))) + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + (or (cond ((null stream)) + ((listen stream) nil) + ((eql timeout 0) :timeout) + ((buffer-input-wait-default display timeout))) + (let ((stream (extract-underlying-stream stream display 'input))) + (do* ((index start (index1+ index))) + ((index>= index end) nil) + (declare (type array-index index)) + (let ((c (lcl:fast-read-byte stream (unsigned-byte 8) nil nil))) + (declare (type (or null card8) c)) + (if (null c) + (return t) + (setf (aref vector index) (the card8 c))))))))) + + + +;;; WARNING: +;;; CLX performance will suffer if your lisp uses read-byte for +;;; receiving all data from the X Window System server. +;;; You are encouraged to write a specialized version of +;;; buffer-read-default that does block transfers. +#-(or Genera explorer excl lcl3.0) +(defun buffer-read-default (display vector start end timeout) + (declare (type display display) + (type buffer-bytes vector) + (type array-index start end) + (type (or null (rational 0 *) (float 0.0 *)) timeout)) + #.(declare-buffun) + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + (or (cond ((null stream)) + ((listen stream) nil) + ((eql timeout 0) :timeout) + ((buffer-input-wait-default display timeout))) + (do* ((index start (index1+ index))) + ((index>= index end) nil) + (declare (type array-index index)) + (let ((c (read-byte stream nil nil))) + (declare (type (or null card8) c)) + (if (null c) + (return t) + (setf (aref vector index) (the card8 c)))))))) + +;;; BUFFER-WRITE-DEFAULT - write data to the X stream + +#+(or Genera explorer) +(defun buffer-write-default (vector display start end) + ;; The default buffer write function for use with common-lisp streams + (declare (type buffer-bytes vector) + (type display display) + (type array-index start end)) + #.(declare-buffun) + (let ((stream (display-output-stream display))) + (declare (type (or null stream) stream)) + (unless (null stream) + (write-string vector stream :start start :end end)))) + +#+excl +(defun buffer-write-default (vector display start end) + (declare (type buffer-bytes vector) + (type display display) + (type array-index start end)) + #.(declare-buffun) + (excl::filesys-write-bytes (display-output-stream display) vector start + (- end start))) + +#+lcl3.0 +(defun buffer-write-default (vector display start end) + ;;We inhibit scheduling here because there seem to be races in Lucid's + ;;multitasking implementation. Anyway, when we take it out we get bugs! + (declare (type display display) + (type buffer-bytes vector) + (type array-index start end) + (optimize (:tail-merge nil) + (speed 3) + (safety 0))) + (let ((stream (display-output-stream display))) + (declare (type (or null stream) stream)) + (unless (null stream) + (let ((stream (extract-underlying-stream stream display 'output))) + (lcl:with-scheduling-inhibited + (lcl:write-array stream vector start end)))))) + +;;; WARNING: +;;; CLX performance will be severely degraded if your lisp uses +;;; write-byte to send all data to the X Window System server. +;;; You are STRONGLY encouraged to write a specialized version +;;; of buffer-write-default that does block transfers. + +#-(or Genera explorer excl lcl3.0) +(defun buffer-write-default (vector display start end) + ;; The default buffer write function for use with common-lisp streams + (declare (type buffer-bytes vector) + (type display display) + (type array-index start end)) + #.(declare-buffun) + (let ((stream (display-output-stream display))) + (declare (type (or null stream) stream)) + (unless (null stream) + (with-vector (vector buffer-bytes) + (do ((index start (index1+ index))) + ((index>= index end)) + (declare (type array-index index)) + (write-byte (aref vector index) stream)))))) + +;;; buffer-force-output-default - force output to the X stream + +#+excl +(defun buffer-force-output-default (display) + ;; buffer-write-default does the actual writing. + (declare (ignore display))) + +#-excl +(defun buffer-force-output-default (display) + ;; The default buffer force-output function for use with common-lisp streams + (declare (type display display)) + (let ((stream (display-output-stream display))) + (declare (type (or null stream) stream)) + (unless (null stream) + (force-output stream)))) + +;;; BUFFER-CLOSE-DEFAULT - close the X stream + +#+excl +(defun buffer-close-default (display &key abort) + ;; The default buffer close function for use with common-lisp streams + (declare (type display display) + (ignore abort)) + #.(declare-buffun) + (excl::filesys-checking-close (display-output-stream display))) + +#-excl +(defun buffer-close-default (display &key abort) + ;; The default buffer close function for use with common-lisp streams + (declare (type display display)) + #.(declare-buffun) + (let ((stream (display-output-stream display))) + (declare (type (or null stream) stream)) + (unless (null stream) + (close stream :abort abort)))) + +;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the +;;; buffer. This is called in read-input between requests, so that a process +;;; waiting for input is abortable when between requests. Should return +;;; :TIMEOUT if it times out, NIL otherwise. + +;;; The default implementation + +;; Poll for input every *buffer-read-polling-time* SECONDS. +#-(or Genera explorer excl lcl3.0) +(defparameter *buffer-read-polling-time* 0.5) + +#-(or Genera explorer excl lcl3.0) +(defun buffer-input-wait-default (display timeout) + (declare (type display display) + (type (or null number) timeout)) + (declare (values timeout)) + + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + (cond ((null stream)) + ((listen stream) nil) + ((eql timeout 0) :timeout) + ((not (null timeout)) + (multiple-value-bind (npoll fraction) + (truncate timeout *buffer-read-polling-time*) + (dotimes (i npoll) ; Sleep for a time, then listen again + (sleep *buffer-read-polling-time*) + (when (listen stream) + (return-from buffer-input-wait-default nil))) + (when (plusp fraction) + (sleep fraction) ; Sleep a fraction of a second + (when (listen stream) ; and listen one last time + (return-from buffer-input-wait-default nil))) + :timeout))))) + +#+Genera +(defun buffer-input-wait-default (display timeout) + (declare (type display display) + (type (or null number) timeout)) + (declare (values timeout)) + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + (cond ((null stream)) + ((scl:send stream :listen) nil) + ((eql timeout 0) :timeout) + ((null timeout) (si:stream-input-block stream "CLX Input")) + (t + (scl:condition-bind ((neti:protocol-timeout + #'(lambda (error) + (when (eq stream (scl:send error :stream)) + (return-from buffer-input-wait-default :timeout))))) + (neti:with-stream-timeout (stream :input timeout) + (si:stream-input-block stream "CLX Input"))))) + nil)) + +#+explorer +(defun buffer-input-wait-default (display timeout) + (declare (type display display) + (type (or null number) timeout)) + (declare (values timeout)) + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + (cond ((null stream)) + ((zl:send stream :listen) nil) + ((eql timeout 0) :timeout) + ((null timeout) + (si:process-wait "CLX Input" stream :listen)) + (t + (unless (si:process-wait-with-timeout + "CLX Input" (round (* timeout 60.)) stream :listen) + (return-from buffer-input-wait-default :timeout)))) + nil)) + +#+excl +;; +;; This is used so an 'eq' test may be used to find out whether or not we can +;; safely throw this process out of the CLX read loop. +;; +(defparameter *read-whostate* "blocked on read from X server") + +;; +;; Note that this function returns nil on error if the scheduler is running, +;; t on error if not. This is ok since buffer-read will detect the error. +;; +#+excl +(defun buffer-input-wait-default (display timeout) + (declare (type display display) + (type (or null number) timeout)) + (declare (values timeout)) + (let ((fd (display-input-stream display))) + (declare (fixnum fd)) + (when (>= fd 0) + (cond ((fd-char-avail-p fd) + nil) + + ;; Otherwise no bytes were available on the socket + ((and timeout (zerop timeout)) + ;; If there aren't enough and timeout == 0, timeout. + :timeout) + + ;; If the scheduler is running let it do timeouts. + (mp::*scheduler-stack-group* + #+allegro + (if (not + (mp:wait-for-input-available fd :whostate *read-whostate* + :wait-function #'fd-char-avail-p + :timeout timeout)) + (return-from buffer-input-wait-default :timeout)) + #-allegro + (mp::wait-for-input-available fd :whostate *read-whostate* + :wait-function #'fd-char-avail-p)) + + ;; Otherwise we have to handle timeouts by hand, and call select() + ;; to block until input is available. Note we don't really handle + ;; the interaction of interrupts and (numberp timeout) here. XX + (t + (let ((res 0)) + (declare (fixnum res)) + (with-interrupt-checking-on + (loop + (setq res (fd-wait-for-input fd (if (null timeout) 0 + (truncate timeout)))) + (cond ((plusp res) ; success + (return nil)) + ((eq res 0) ; timeout + (return :timeout)) + ((eq res -1) ; error + (return t)) + ;; Otherwise we got an interrupt -- go around again. + ))))))))) + + +#+lcl3.0 +(defun buffer-input-wait-default (display timeout) + (declare (type display display) + (type (or null number) timeout) + (optimize (speed 3) (safety 0))) + (declare (values timeout)) + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + (cond ((null stream)) + ((listen stream) nil) + ((eql timeout 0) :timeout) + ((let ((stream (extract-underlying-stream stream display 'input))) + (lucid::waiting-for-input-from-stream stream + (lucid::with-io-unlocked + (if (null timeout) + (lcl:process-wait "CLX Input" #'listen stream) + (lcl:process-wait-with-timeout + "CLX Input" timeout #'listen stream))))) + nil) + (:timeout)))) + + +;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the +;;; buffer. This should never block, so it can be called from the scheduler. + +;;; The default implementation is to just use listen. +#-excl +(defun buffer-listen-default (display) + (declare (type display display)) + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + (if (null stream) + t + (listen stream)))) + +#+excl +(defun buffer-listen-default (display) + (declare (type display display)) + (let ((fd (display-input-stream display))) + (declare (type fixnum fd)) + (if (= fd -1) + t + (fd-char-avail-p fd)))) + + +;;;---------------------------------------------------------------------------- +;;; System dependent speed hacks +;;;---------------------------------------------------------------------------- + +;; +;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature. +;; If your lisp doesn't have stack-lists, and you're worried about +;; consing garbage, you may want to re-write this to allocate and +;; initialize lists from a resource. +;; +#+lispm +(defmacro with-stack-list ((var &rest elements) &body body) + `(sys:with-stack-list (,var ,@elements) ,@body)) + +#+lispm +(defmacro with-stack-list* ((var &rest elements) &body body) + `(sys:with-stack-list* (,var ,@elements) ,@body)) + +#-lispm +(defmacro with-stack-list ((var &rest elements) &body body) + ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body) + ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body) + ;; except that the list produced by MAPCAR resides on the stack and + ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. + `(let ((,var (list ,@elements))) ,@body)) + +#-lispm +(defmacro with-stack-list* ((var &rest elements) &body body) + ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body) + ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body) + ;; except that the list produced by MAPCAR resides on the stack and + ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. + `(let ((,var (list* ,@elements))) ,@body)) + +(declaim (inline buffer-replace)) + +#+lispm +(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) + (declare (type vector buf1 buf2) + (type array-index start1 end1 start2)) + (sys:copy-array-portion buf2 start2 (length buf2) buf1 start1 end1)) + +#+excl +(defun buffer-replace (target-sequence source-sequence target-start + target-end &optional (source-start 0)) + (declare (type buffer-bytes target-sequence source-sequence) + (type array-index target-start target-end source-start) + (optimize (speed 3) (safety 0))) + + (let ((source-end (length source-sequence))) + (declare (type array-index source-end)) + + (if* (and (eq target-sequence source-sequence) + (> target-start source-start)) + then (let ((nelts (min (- target-end target-start) + (- source-end source-start)))) + (do ((target-index (+ target-start nelts -1) (1- target-index)) + (source-index (+ source-start nelts -1) (1- source-index))) + ((= target-index (1- target-start)) target-sequence) + (declare (type array-index target-index source-index)) + + (setf (aref target-sequence target-index) + (aref source-sequence source-index)))) + else (do ((target-index target-start (1+ target-index)) + (source-index source-start (1+ source-index))) + ((or (= target-index target-end) (= source-index source-end)) + target-sequence) + (declare (type array-index target-index source-index)) + + (setf (aref target-sequence target-index) + (aref source-sequence source-index)))))) + +#+lucid +;;;The compiler is *supposed* to optimize calls to replace, but in actual +;;;fact it does not. +(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) + (declare (type buffer-bytes buf1 buf2) + (type array-index start1 end1 start2)) + #.(declare-buffun) + (let ((end2 (lucid::%simple-8bit-vector-length buf2))) + (declare (type array-index end2)) + (lucid::simple-8bit-vector-replace-internal + buf1 buf2 start1 end1 start2 end2))) + +#+(and clx-overlapping-arrays (not (or lispm excl))) +(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) + (declare (type vector buf1 buf2) + (type array-index start1 end1 start2)) + (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) + +#-(or lispm lucid excl clx-overlapping-arrays) +(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) + (declare (type buffer-bytes buf1 buf2) + (type array-index start1 end1 start2)) + (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) + +#+ti +(defun with-location-bindings (sys:"e bindings &rest body) + (do ((bindings bindings (cdr bindings))) + ((null bindings) + (sys:eval-body-as-progn body)) + (sys:bind (sys:*eval `(sys:locf ,(caar bindings))) + (sys:*eval (cadar bindings))))) + +#+ti +(compiler:defoptimizer with-location-bindings with-l-b-compiler nil (form) + (let ((bindings (cadr form)) + (body (cddr form))) + `(let () + ,@(loop for (accessor value) in bindings + collect `(si:bind (si:locf ,accessor) ,value)) + ,@body))) + +#+ti +(defun (:property with-location-bindings compiler::cw-handler) (exp) + (let* ((bindlist (mapcar #'compiler::cw-clause (second exp))) + (body (compiler::cw-clause (cddr exp)))) + (and compiler::cw-return-expansion-flag + (list* (first exp) bindlist body)))) + +#+(and lispm (not ti)) +(defmacro with-location-bindings (bindings &body body) + `(sys:letf* ,bindings ,@body)) + +#+lispm +(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) + &body body) + ;; don't use svref on LHS because Symbolics didn't define locf for it + (let* ((local-state (gensym)) + (bindings `(((aref ,local-state ,ts-index) 0)))) ; will become zero anyway + (dolist (index indexes) + (push `((aref ,local-state ,index) (svref ,saved-state ,index)) + bindings)) + `(let ((,local-state (gcontext-local-state ,gc))) + (declare (type gcontext-state ,local-state)) + (unwind-protect + (with-location-bindings ,bindings + ,@body) + (setf (svref ,local-state ,ts-index) 0) + (when ,temp-gc + (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) + (deallocate-gcontext-state ,saved-state))))) + +#-lispm +(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) + &body body) + (let ((local-state (gensym)) + (resets nil)) + (dolist (index indexes) + (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index)) + resets)) + `(unwind-protect + (progn + ,@body) + (let ((,local-state (gcontext-local-state ,gc))) + (declare (type gcontext-state ,local-state)) + ,@resets + (setf (svref ,local-state ,ts-index) 0)) + (when ,temp-gc + (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) + (deallocate-gcontext-state ,saved-state)))) + +;;;---------------------------------------------------------------------------- +;;; How error detection should CLX do? +;;; Several levels are possible: +;;; +;;; 1. Do the equivalent of check-type on every argument. +;;; +;;; 2. Simply report TYPE-ERROR. This eliminates overhead of all the format +;;; strings generated by check-type. +;;; +;;; 3. Do error checking only on arguments that are likely to have errors +;;; (like keyword names) +;;; +;;; 4. Do error checking only where not doing so may dammage the envirnment +;;; on a non-tagged machine (i.e. when storing into a structure that has +;;; been passed in) +;;; +;;; 5. No extra error detection code. On lispm's, ASET may barf trying to +;;; store a non-integer into a number array. +;;; +;;; How extensive should the error checking be? For example, if the server +;;; expects a CARD16, is is sufficient for CLX to check for integer, or +;;; should it also check for non-negative and less than 65536? +;;;---------------------------------------------------------------------------- + +;; The *TYPE-CHECK?* constant controls how much error checking is done. +;; Possible values are: +;; NIL - Don't do any error checking +;; t - Do the equivalent of checktype on every argument +;; :minimal - Do error checking only where errors are likely + +;;; This controls macro expansion, and isn't changable at run-time You will +;;; probably want to set this to nil if you want good performance at +;;; production time. +(defconstant *type-check?* #+Genera nil #-Genera t) + +;; TYPE? is used to allow the code to do error checking at a different level from +;; the declarations. It also does some optimizations for systems that don't have +;; good compiler support for TYPEP. The definitions for CARD32, CARD16, INT16, etc. +;; include range checks. You can modify TYPE? to do less extensive checking +;; for these types if you desire. + +(defmacro type? (object type) + (if (not (constantp type)) + `(typep ,object ,type) + (progn + (setq type (eval type)) + #+(or Genera explorer) + (if *type-check?* + `(locally (declare (optimize safety)) (typep ,object ',type)) + `(typep ,object ',type)) + #-(or Genera explorer) + (let ((predicate (assoc type + '((drawable drawable-p) (window window-p) + (pixmap pixmap-p) (cursor cursor-p) + (font font-p) (gcontext gcontext-p) + (colormap colormap-p) (null null) + (integer integerp))))) + (cond (predicate + `(,(second predicate) ,object)) + ((eq type 'boolean) + 't) ; Everything is a boolean. + (*type-check?* + `(locally (declare (optimize safety)) (typep ,object ',type))) + (t + `(typep ,object ',type))))))) + +;; X-TYPE-ERROR is the function called for type errors. +;; If you want lots of checking, but are concerned about code size, +;; this can be made into a macro that ignores some parameters. + +(defun x-type-error (object type &optional error-string) + (x-error 'x-type-error + :datum object + :expected-type type + :error-string error-string)) + + +;;----------------------------------------------------------------------------- +;; Error handlers +;; Hack up KMP error signaling using zetalisp until the real thing comes +;; along +;;----------------------------------------------------------------------------- + +(defun default-error-handler (display error-key &rest key-vals + &key asynchronous &allow-other-keys) + (declare (type boolean asynchronous) + (dynamic-extent key-vals)) + ;; The default display-error-handler. + ;; It signals the conditions listed in the DISPLAY file. + (if asynchronous + (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals) + (apply #'x-error error-key :display display :error-key error-key key-vals))) + +#+(and lispm (not Genera) (not ansi-common-lisp)) +(defun x-error (condition &rest keyargs) + (apply #'sys:signal condition keyargs)) + +#+(and lispm (not Genera) (not ansi-common-lisp)) +(defun x-cerror (proceed-format-string condition &rest keyargs) + (sys:signal (apply #'zl:make-condition condition keyargs) + :proceed-types proceed-format-string)) + +#+(and Genera (not ansi-common-lisp)) +(defun x-error (condition &rest keyargs) + (declare (dbg:error-reporter)) + (apply #'sys:signal condition keyargs)) + +#+(and Genera (not ansi-common-lisp)) +(defun x-cerror (proceed-format-string condition &rest keyargs) + (declare (dbg:error-reporter)) + (apply #'sys:signal condition :continue-format-string proceed-format-string keyargs)) + +#+(or ansi-common-lisp excl lcl3.0) +(defun x-error (condition &rest keyargs) + (declare (dynamic-extent keyargs)) + (apply #'error condition keyargs)) + +#+(or ansi-common-lisp excl lcl3.0) +(defun x-cerror (proceed-format-string condition &rest keyargs) + (declare (dynamic-extent keyargs)) + (apply #'cerror proceed-format-string condition keyargs)) + +#-(or lispm ansi-common-lisp excl lcl3.0) +(defun x-error (condition &rest keyargs) + (error "X-Error: ~a" + (princ-to-string (apply #'make-condition condition keyargs)))) + +#-(or lispm ansi-common-lisp excl lcl3.0) +(defun x-cerror (proceed-format-string condition &rest keyargs) + (cerror proceed-format-string "X-Error: ~a" + (princ-to-string (apply #'make-condition condition keyargs)))) + +;; version 15 of Pitman error handling defines the syntax for define-condition to be: +;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*] +;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string) +;; or (:report exp) + +#+(and lispm (not ansi-common-lisp)) +(defmacro define-condition (name parents &body options) + (let ((slots (pop options)) + (documentation nil) + (conc-name (concatenate 'string (string name) "-")) + (reporter nil)) + (dolist (item options) + (ecase (first item) + (:documentation (setq documentation (second item))) + (:conc-name (setq conc-name (string (second item)))) + (:report (setq reporter (second item))))) + `(within-definition (,name define-condition) + (zl:defflavor ,name ,slots ,parents + :initable-instance-variables + #-Genera + (:accessor-prefix ,conc-name) + #+Genera + (:conc-name ,conc-name) + #-Genera + (:outside-accessible-instance-variables ,@slots) + #+Genera + (:readable-instance-variables ,@slots)) + ,(when reporter ;; when no reporter, parent's is inherited + `(zl:defmethod #-Genera (,name :report) + #+Genera (dbg:report ,name) (stream) + ,(if (stringp reporter) + `(write-string ,reporter stream) + `(,reporter global:self stream)) + global:self)) + (zl:compile-flavor-methods ,name) + ,(when documentation + `(setf (documentation name 'type) ,documentation)) + ',name))) + +#+(and lispm (not Genera) (not ansi-common-lisp)) +(zl:defflavor x-error () (global:error)) + +#+(and Genera (not ansi-common-lisp)) +(scl:defflavor x-error + ((dbg:proceed-types '(:continue)) ; + continue-format-string) + (sys:error) + (:initable-instance-variables continue-format-string)) + +#+(and Genera (not ansi-common-lisp)) +(scl:defmethod (scl:make-instance x-error) (&rest ignore) + (when (not (sys:variable-boundp continue-format-string)) + (setf dbg:proceed-types (remove :continue dbg:proceed-types)))) + +#+(and Genera (not ansi-common-lisp)) +(scl:defmethod (dbg:proceed x-error :continue) () + :continue) + +#+(and Genera (not ansi-common-lisp)) +(sys:defmethod (dbg:document-proceed-type x-error :continue) (stream) + (format stream continue-format-string)) + +#+(or ansi-common-lisp excl lcl3.0) +(define-condition x-error (error)) + +#-(or lispm ansi-common-lisp excl lcl3.0) +(defstruct x-error + report-function) + +#-(or lispm ansi-common-lisp excl lcl3.0) +(defun reporter-for-condition (name) + (xintern "." name '-reporter.)) + +#-(or lispm ansi-common-lisp excl lcl3.0) +(defmacro define-condition (name parents &body options) + ;; Define a structure that when printed displays an error message + (let ((slots (pop options)) + (documentation nil) + (conc-name (concatenate 'string (string name) "-")) + (reporter nil) + (condition (gensym)) + (stream (gensym)) + (report-function (reporter-for-condition name))) + (dolist (item options) + (ecase (first item) + (:documentation (setq documentation (second item))) + (:conc-name (setq conc-name (string (second item)))) + (:report (setq reporter (second item))))) + (unless reporter (setq report-function (reporter-for-condition (car parents)))) + `(within-definition (,name define-condition) + (defstruct (,name (:conc-name ,(intern conc-name)) + (:print-function condition-print) + (:include ,(car parents) (report-function ',report-function))) + ,@slots) + ,(when documentation + `(setf (documentation name 'type) ,documentation)) + ,(when reporter + `(defun ,report-function (,condition ,stream) + ,(if (stringp reporter) + `(write-string ,reporter ,stream) + `(,reporter ,condition ,stream)) + ,condition)) + ',name))) + +#-(or lispm ansi-common-lisp excl lcl3.0) +(defun condition-print (condition stream depth) + (declare (type x-error condition) + (type stream stream) + (ignore depth)) + (if *print-escape* + (print-unreadable-object (condition stream :type t)) + (funcall (x-error-report-function condition) condition stream)) + condition) + +#-(or lispm ansi-common-lisp excl lcl3.0) +(defun make-condition (type &rest slot-initializations) + (declare (dynamic-extent slot-initializations)) + (let ((make-function (intern (concatenate 'string (string 'make-) (string type)) + (symbol-package type)))) + (apply make-function slot-initializations))) + +#-(or ansi-common-lisp excl lcl3.0) +(define-condition type-error (x-error) + (datum + expected-type) + (:report (lambda (condition stream) + (format stream "~s isn't a ~a" + (type-error-datum condition) + (type-error-expected-type condition))))) + + +;;----------------------------------------------------------------------------- +;; HOST hacking +;;----------------------------------------------------------------------------- + +#-(or explorer Genera) +(defun host-address (host &optional (family :internet)) + ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) + ;; and cdr is a list of network address bytes. + (declare (type (or stringable list) host) + (type (or null (member :internet :decnet :chaos) card8) family)) + (declare (values list)) + host family + (error "HOST-ADDRESS not implemented yet.")) + +#+explorer +(defun host-address (host &optional (family :internet)) + ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) + ;; and cdr is a list of network address bytes. + (declare (type (or stringable list) host) + (type (or null (member :internet :decnet :chaos) card8) family)) + (declare (values list)) + (ecase family + (:internet + (let ((addr (ip:get-ip-address host))) + (unless addr (error "~s isn't an internet host name" host)) + (list :internet + (ldb (byte 8 24) addr) + (ldb (byte 8 16) addr) + (ldb (byte 8 8) addr) + (ldb (byte 8 0) addr)))) + (:chaos + (let ((addr (first (chaos:chaos-addresses host)))) + (unless addr (error "~s isn't a chaos host name" host)) + (list :chaos + (ldb (byte 8 0) addr) + (ldb (byte 8 8) addr)))))) + +#+Genera +(defun host-address (host &optional (family :internet)) + ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) + ;; and cdr is a list of network address bytes. + (declare (type (or stringable list) host) + (type (or null (member :internet :decnet :chaos) card8) family)) + (declare (values list)) + (let ((net-type (if (eq family :DECnet) + :DNA + family))) + (dolist (addr + (sys:send (net:parse-host host) :network-addresses) + (error "~s isn't a valid ~(~A~) host name" host family)) + (let ((network (car addr)) + (address (cadr addr))) + (when (sys:send network :network-typep net-type) + (return (ecase family + (:internet + (multiple-value-bind (a b c d) (tcp:explode-internet-address address) + (list :internet a b c d))) + ((:chaos :DECnet) + (list family (ldb (byte 8 0) address) (ldb (byte 8 8) address)))))))))) + +#+explorer ;; This isn't required, but it helps make sense of the results from access-hosts +(defun get-host (host-object) + ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos) + ;; and cdr is a list of network address bytes. + (declare (type list host-object)) + (declare (values string family)) + (let* ((family (first host-object)) + (address (ecase family + (:internet + (dpb (second host-object) + (byte 8 24) + (dpb (third host-object) + (byte 8 16) + (dpb (fourth host-object) + (byte 8 8) + (fifth host-object))))) + (:chaos + (dpb (third host-object) (byte 8 8) (second host-object)))))) + (when (eq family :internet) (setq family :ip)) + (let ((host (si:get-host-from-address address family))) + (values (and host (funcall host :name)) family)))) + +;;; This isn't required, but it helps make sense of the results from access-hosts +#+Genera +(defun get-host (host-object) + ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos) + ;; and cdr is a list of network address bytes. + (declare (type list host-object)) + (declare (values string family)) + (let ((family (first host-object))) + (values (sys:send (net:get-host-from-address + (ecase family + (:internet + (apply #'tcp:build-internet-address (rest host-object))) + ((:chaos :DECnet) + (dpb (third host-object) (byte 8 8) (second host-object)))) + (net:local-network-of-type (if (eq family :DECnet) + :DNA + family))) + :name) + family))) + + +;;----------------------------------------------------------------------------- +;; Whether to use closures for requests or not. +;;----------------------------------------------------------------------------- + +;;; If this macro expands to non-NIL, then request and locking code is +;;; compiled in a much more compact format, as the common code is shared, and +;;; the specific code is built into a closure that is funcalled by the shared +;;; code. If your compiler makes efficient use of closures then you probably +;;; want to make this expand to T, as it makes the code more compact. + +(defmacro use-closures () + #+lispm t #-lispm nil) + + +;;----------------------------------------------------------------------------- +;; Resource stuff +;;----------------------------------------------------------------------------- + + +;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if +;;; a resource manager isn't running. + +(defun default-resources-pathname () + (when #+unix t #-unix (search "Unix" (software-type) :test #'char-equal) + (merge-pathnames (user-homedir-pathname) (pathname ".Xdefaults")))) + + + +;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the +;;; defaults have been loaded. + +(defun resources-pathname () + (when #+unix t #-unix (search "Unix" (software-type) :test #'char-equal) + (or #+(or excl lcl3.0) + (let ((string (#+excl sys:getenv + #+lcl3.0 lcl:environment-variable + "XENVIRONMENT"))) + (when string + (pathname string))) + (merge-pathnames + (user-homedir-pathname) + (pathname + (concatenate 'simple-string ".Xdefaults-" + #+excl (short-site-name) + #-excl (machine-instance))))))) + + +;;----------------------------------------------------------------------------- +;; GC stuff +;;----------------------------------------------------------------------------- + +#+Genera +(si:define-gc-cleanup clx-cleanup ("CLX Cleanup") + (declare (special *event-free-list* + *pending-command-free-list* + *reply-buffer-free-lists* + *gcontext-local-state-cache* + *temp-gcontext-cache*)) + (setq *event-free-list* nil) + (setq *pending-command-free-list* nil) + (fill *reply-buffer-free-lists* nil) + (setq *gcontext-local-state-cache* nil) + (setq *temp-gcontext-cache* nil)) + + +;;----------------------------------------------------------------------------- +;; Image stuff +;;----------------------------------------------------------------------------- + +(deftype pixarray-1-element-type () + 'bit) + +(deftype pixarray-4-element-type () + 'card4) + +(deftype pixarray-8-element-type () + 'card8) + +(deftype pixarray-16-element-type () + 'card16) + +(deftype pixarray-24-element-type () + #-Genera 'card24 #+Genera 'int32) + +(deftype pixarray-32-element-type () + #-Genera 'card32 #+Genera 'int32) + +(deftype pixarray-1 () + '(array pixarray-1-element-type (* *))) + +(deftype pixarray-4 () + '(array pixarray-4-element-type (* *))) + +(deftype pixarray-8 () + '(array pixarray-8-element-type (* *))) + +(deftype pixarray-16 () + '(array pixarray-16-element-type (* *))) + +(deftype pixarray-24 () + '(array pixarray-24-element-type (* *))) + +(deftype pixarray-32 () + '(array pixarray-32-element-type (* *))) + +(deftype pixarray () + '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32)) + +(deftype bitmap () + 'pixarray-1) + + +;;; These are used to read and write pixels from and to CARD8s. + +;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s. + +(defmacro read-image-load-byte (size position integer) + `(the (unsigned-byte ,size) + (#-Genera ldb #+Genera sys:%logldb + (byte ,size ,(if *image-bit-lsb-first-p* position (- 7 position))) + (the card8 ,integer)))) + +;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from +;;; the appropriate number of CARD8s. + +(defmacro read-image-assemble-bytes (&rest bytes) + (let* ((bytes (if *image-byte-lsb-first-p* bytes (reverse bytes))) + (it (first bytes)) + (count 0)) + (dolist (byte (rest bytes)) + (setq it + `(#-Genera dpb #+Genera sys:%logdpb + (the card8 ,byte) + (byte 8 ,(incf count 8)) + (the (unsigned-byte ,count) ,it)))) + #-Genera `(the (unsigned-byte ,(* (length bytes) 8)) ,it) + #+Genera it)) + +;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit +;;; pixel. + +(defmacro write-image-load-byte (position integer integer-size) + integer-size + `(the card8 + (#-Genera ldb #+Genera sys:%logldb + (byte 8 ,(if *image-byte-lsb-first-p* + position + (- integer-size 8 position))) + #-Genera (the (unsigned-byte ,integer-size) ,integer) + #+Genera ,integer + ))) + +;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit +;;; pixels. + +(defmacro write-image-assemble-bytes (&rest bytes) + (let* ((bytes (if *image-bit-lsb-first-p* bytes (reverse bytes))) + (size (floor 8 (length bytes))) + (it (first bytes)) + (count 0)) + (dolist (byte (rest bytes)) + (setq it `(#-Genera dpb #+Genera sys:%logdpb + (the (unsigned-byte ,size) ,byte) + (byte ,size ,(incf count size)) + (the (unsigned-byte ,count) ,it)))) + `(the card8 ,it))) + +;;; If you can write fast routines that can read and write pixarrays out of a +;;; buffer-bytes, do it! It makes the image code a lot faster. The +;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines +;;; return T if they can do it, NIL if they can't. + +;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s + +#+(or lcl3.0 excl) +(defun fast-read-pixarray-1 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-1 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((vector (underlying-simple-vector array)) + (start (index+ index + (index* y padded-bytes-per-line) + (index-ceiling x 8)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y)) + (left-bits (index-mod (index- x) 8)) + (right-bits (index-mod (index- width left-bits) 8)) + (middle-bits (index- width left-bits right-bits)) + (middle-bytes (index-floor middle-bits 8))) + ((index>= y height)) + (declare (type (simple-array pixarray-1-element-type (*)) vector) + (type array-index start y + left-bits right-bits middle-bits middle-bytes)) + (cond ((index< middle-bits 0) + (let ((byte (aref buffer-bbuf (index1- start))) + (x (array-row-major-index array y left-bits))) + (declare (type card8 byte) + (type array-index x)) + (when (index> right-bits 6) + (setf (aref vector (index- x 1)) + (read-image-load-byte 1 7 byte))) + (when (and (index> left-bits 1) + (index> right-bits 5)) + (setf (aref vector (index- x 2)) + (read-image-load-byte 1 6 byte))) + (when (and (index> left-bits 2) + (index> right-bits 4)) + (setf (aref vector (index- x 3)) + (read-image-load-byte 1 5 byte))) + (when (and (index> left-bits 3) + (index> right-bits 3)) + (setf (aref vector (index- x 4)) + (read-image-load-byte 1 4 byte))) + (when (and (index> left-bits 4) + (index> right-bits 2)) + (setf (aref vector (index- x 5)) + (read-image-load-byte 1 3 byte))) + (when (and (index> left-bits 5) + (index> right-bits 1)) + (setf (aref vector (index- x 6)) + (read-image-load-byte 1 2 byte))) + (when (index> left-bits 6) + (setf (aref vector (index- x 7)) + (read-image-load-byte 1 1 byte))))) + (t + (unless (index-zerop left-bits) + (let ((byte (aref buffer-bbuf (index1- start))) + (x (array-row-major-index array y left-bits))) + (declare (type card8 byte) + (type array-index x)) + (setf (aref vector (index- x 1)) + (read-image-load-byte 1 7 byte)) + (when (index> left-bits 1) + (setf (aref vector (index- x 2)) + (read-image-load-byte 1 6 byte)) + (when (index> left-bits 2) + (setf (aref vector (index- x 3)) + (read-image-load-byte 1 5 byte)) + (when (index> left-bits 3) + (setf (aref vector (index- x 4)) + (read-image-load-byte 1 4 byte)) + (when (index> left-bits 4) + (setf (aref vector (index- x 5)) + (read-image-load-byte 1 3 byte)) + (when (index> left-bits 5) + (setf (aref vector (index- x 6)) + (read-image-load-byte 1 2 byte)) + (when (index> left-bits 6) + (setf (aref vector (index- x 7)) + (read-image-load-byte 1 1 byte)) + )))))))) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (x (array-row-major-index array y left-bits) (index+ x 8))) + ((index>= i end) + (unless (index-zerop right-bits) + (let ((byte (aref buffer-bbuf end)) + (x (array-row-major-index + array y (index+ left-bits middle-bits)))) + (declare (type card8 byte) + (type array-index x)) + (setf (aref vector (index+ x 0)) + (read-image-load-byte 1 0 byte)) + (when (index> right-bits 1) + (setf (aref vector (index+ x 1)) + (read-image-load-byte 1 1 byte)) + (when (index> right-bits 2) + (setf (aref vector (index+ x 2)) + (read-image-load-byte 1 2 byte)) + (when (index> right-bits 3) + (setf (aref vector (index+ x 3)) + (read-image-load-byte 1 3 byte)) + (when (index> right-bits 4) + (setf (aref vector (index+ x 4)) + (read-image-load-byte 1 4 byte)) + (when (index> right-bits 5) + (setf (aref vector (index+ x 5)) + (read-image-load-byte 1 5 byte)) + (when (index> right-bits 6) + (setf (aref vector (index+ x 6)) + (read-image-load-byte 1 6 byte)) + ))))))))) + (declare (type array-index end i x)) + (let ((byte (aref buffer-bbuf i))) + (declare (type card8 byte)) + (setf (aref vector (index+ x 0)) + (read-image-load-byte 1 0 byte)) + (setf (aref vector (index+ x 1)) + (read-image-load-byte 1 1 byte)) + (setf (aref vector (index+ x 2)) + (read-image-load-byte 1 2 byte)) + (setf (aref vector (index+ x 3)) + (read-image-load-byte 1 3 byte)) + (setf (aref vector (index+ x 4)) + (read-image-load-byte 1 4 byte)) + (setf (aref vector (index+ x 5)) + (read-image-load-byte 1 5 byte)) + (setf (aref vector (index+ x 6)) + (read-image-load-byte 1 6 byte)) + (setf (aref vector (index+ x 7)) + (read-image-load-byte 1 7 byte)))) + )))) + t) + +#+(or lcl3.0 excl) +(defun fast-read-pixarray-4 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-4 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((vector (underlying-simple-vector array)) + (start (index+ index + (index* y padded-bytes-per-line) + (index-ceiling x 2)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y)) + (left-nibbles (index-mod (index- x) 2)) + (right-nibbles (index-mod (index- width left-nibbles) 2)) + (middle-nibbles (index- width left-nibbles right-nibbles)) + (middle-bytes (index-floor middle-nibbles 2))) + ((index>= y height)) + (declare (type (simple-array pixarray-4-element-type (*)) vector) + (type array-index start y + left-nibbles right-nibbles middle-nibbles middle-bytes)) + (unless (index-zerop left-nibbles) + (setf (aref array y 0) + (read-image-load-byte + 4 4 (aref buffer-bbuf (index1- start))))) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (x (array-row-major-index array y left-nibbles) (index+ x 2))) + ((index>= i end) + (unless (index-zerop right-nibbles) + (setf (aref array y (index+ left-nibbles middle-nibbles)) + (read-image-load-byte 4 0 (aref buffer-bbuf end))))) + (declare (type array-index end i x)) + (let ((byte (aref buffer-bbuf i))) + (declare (type card8 byte)) + (setf (aref vector (index+ x 0)) + (read-image-load-byte 4 0 byte)) + (setf (aref vector (index+ x 1)) + (read-image-load-byte 4 4 byte)))) + )) + t) + +#+(or lcl3.0 excl) +(defun fast-read-pixarray-8 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-8 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((vector (underlying-simple-vector array)) + (start (index+ index + (index* y padded-bytes-per-line) + x) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) + (declare (type (simple-array pixarray-8-element-type (*)) vector) + (type array-index start y)) + (do* ((end (index+ start width)) + (i start (index1+ i)) + (x (array-row-major-index array y 0) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref vector x) + (the card8 (aref buffer-bbuf i)))))) + t) + +#+(or lcl3.0 excl) +(defun fast-read-pixarray-16 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-16 array) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((vector (underlying-simple-vector array)) + (start (index+ index + (index* y padded-bytes-per-line) + (index* x 2)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) + (declare (type (simple-array pixarray-16-element-type (*)) vector) + (type array-index start y)) + (do* ((end (index+ start (index* width 2))) + (i start (index+ i 2)) + (x (array-row-major-index array y 0) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref vector x) + (read-image-assemble-bytes + (aref buffer-bbuf (index+ i 0)) + (aref buffer-bbuf (index+ i 1))))))) + t) + +#+Genera +(defun fast-read-pixarray-24 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-24 array) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((array array) + (start (index+ index + (index* y padded-bytes-per-line) + (index* x 3)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) + (declare (sys:array-register-1d array) + (type array-index start y)) + (do* ((end (index+ start (index* width 3))) + (i start (index+ i 3)) + (x (array-row-major-index array y 0) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (sys:%1d-aref array x) + (read-image-assemble-bytes + (aref buffer-bbuf (index+ i 0)) + (aref buffer-bbuf (index+ i 1)) + (aref buffer-bbuf (index+ i 2))))))) + t) + +#+(or lcl3.0 excl) +(defun fast-read-pixarray-24 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-24 array) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((vector (underlying-simple-vector array)) + (start (index+ index + (index* y padded-bytes-per-line) + (index* x 3)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) + (declare (type (simple-array pixarray-24-element-type (*)) vector) + (type array-index start y)) + (do* ((end (index+ start (index* width 3))) + (i start (index+ i 3)) + (x (array-row-major-index array y 0) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref vector x) + (read-image-assemble-bytes + (aref buffer-bbuf (index+ i 0)) + (aref buffer-bbuf (index+ i 1)) + (aref buffer-bbuf (index+ i 2))))))) + t) + +#+(or lcl3.0 excl) +(defun fast-read-pixarray-32 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-32 array) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((vector (underlying-simple-vector array)) + (start (index+ index + (index* y padded-bytes-per-line) + (index* x 4)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) + (declare (type (simple-array pixarray-32-element-type (*)) vector) + (type array-index start y)) + (do* ((end (index+ start (index* width 4))) + (i start (index+ i 4)) + (x (array-row-major-index array y 0) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref vector x) + (read-image-assemble-bytes + (aref buffer-bbuf (index+ i 0)) + (aref buffer-bbuf (index+ i 1)) + (aref buffer-bbuf (index+ i 2)) + (aref buffer-bbuf (index+ i 3))))))) + t) + +(defun fast-read-pixarray (bbuf boffset pixarray + x y width height padded-bytes-per-line + bits-per-pixel) + (declare (type buffer-bytes bbuf) + (type array-index boffset + padded-bytes-per-line) + (type pixarray pixarray) + (type card16 x y width height) + (type (member 1 4 8 16 24 32) bits-per-pixel)) + (progn bbuf boffset pixarray x y width height padded-bytes-per-line + bits-per-pixel) + (or + #+lispm + (let* ((padded-bits-per-line (* padded-bytes-per-line 8)) + (padded-pixels-per-line + (floor padded-bits-per-line bits-per-pixel)) + (pixarray-padded-pixels-per-line + #+Genera (sys:array-row-span pixarray) + #-Genera (array-dimension pixarray 1)) + (pixarray-padded-bits-per-line + (* pixarray-padded-pixels-per-line bits-per-pixel))) + (when (and (= (sys:array-element-size pixarray) bits-per-pixel) + (zerop (index-mod padded-bits-per-line 32)) + (zerop (index-mod pixarray-padded-bits-per-line 32))) + (#+Genera sys:stack-let* #-Genera let* + ((dimensions (list height padded-pixels-per-line)) + (a (make-array + dimensions + :element-type (array-element-type pixarray) + :displaced-to bbuf + :displaced-index-offset (floor (* boffset 8) bits-per-pixel)))) + (sys:bitblt boole-1 width height a x y pixarray 0 0)) + t)) + #+Genera + (when (= bits-per-pixel 24) + (fast-read-pixarray-24 + bbuf boffset pixarray x y width height padded-bytes-per-line)) + #+(or lcl3.0 excl) + (funcall + (ecase bits-per-pixel + (1 #'fast-read-pixarray-1) (4 #'fast-read-pixarray-4) + (8 #'fast-read-pixarray-8) (16 #'fast-read-pixarray-16) + (24 #'fast-read-pixarray-24) (32 #'fast-read-pixarray-32)) + bbuf boffset pixarray x y width height padded-bytes-per-line) + )) + +;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s + +#+(or lcl3.0 excl) +(defun fast-write-pixarray-1 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-1 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((vector (underlying-simple-vector array)) + (h 0 (index1+ h)) + (y y (index1+ y)) + (right-bits (index-mod width 8)) + (middle-bits (index- width right-bits)) + (middle-bytes (index-ceiling middle-bits 8)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type (simple-array pixarray-1-element-type (*)) vector) + (type array-index h y right-bits middle-bits + middle-bytes start)) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (start-x x) + (x (array-row-major-index array y start-x) (index+ x 8))) + ((index>= i end) + (unless (index-zerop right-bits) + (let ((x (array-row-major-index + array y (index+ start-x middle-bits)))) + (declare (type array-index x)) + (setf (aref buffer-bbuf end) + (write-image-assemble-bytes + (aref vector (index+ x 0)) + (if (index> right-bits 1) + (aref vector (index+ x 1)) + 0) + (if (index> right-bits 2) + (aref vector (index+ x 2)) + 0) + (if (index> right-bits 3) + (aref vector (index+ x 3)) + 0) + (if (index> right-bits 4) + (aref vector (index+ x 4)) + 0) + (if (index> right-bits 5) + (aref vector (index+ x 5)) + 0) + (if (index> right-bits 6) + (aref vector (index+ x 6)) + 0) + 0))))) + (declare (type array-index end i start-x x)) + (setf (aref buffer-bbuf i) + (write-image-assemble-bytes + (aref vector (index+ x 0)) + (aref vector (index+ x 1)) + (aref vector (index+ x 2)) + (aref vector (index+ x 3)) + (aref vector (index+ x 4)) + (aref vector (index+ x 5)) + (aref vector (index+ x 6)) + (aref vector (index+ x 7))))))) + t) + +#+(or lcl3.0 excl) +(defun fast-write-pixarray-4 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-4 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((vector (underlying-simple-vector array)) + (h 0 (index1+ h)) + (y y (index1+ y)) + (right-nibbles (index-mod width 2)) + (middle-nibbles (index- width right-nibbles)) + (middle-bytes (index-ceiling middle-nibbles 2)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type (simple-array pixarray-4-element-type (*)) vector) + (type array-index h y right-nibbles middle-nibbles + middle-bytes start)) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (start-x x) + (x (array-row-major-index array y start-x) (index+ x 2))) + ((index>= i end) + (unless (index-zerop right-nibbles) + (setf (aref buffer-bbuf end) + (write-image-assemble-bytes + (aref array y (index+ start-x middle-nibbles)) + 0)))) + (declare (type array-index end i start-x x)) + (setf (aref buffer-bbuf i) + (write-image-assemble-bytes + (aref vector (index+ x 0)) + (aref vector (index+ x 1))))))) + t) + +#+(or lcl3.0 excl) +(defun fast-write-pixarray-8 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-8 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((vector (underlying-simple-vector array)) + (h 0 (index1+ h)) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type (simple-array pixarray-8-element-type (*)) vector) + (type array-index h y start)) + (do* ((end (index+ start width)) + (i start (index1+ i)) + (x (array-row-major-index array y x) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref buffer-bbuf i) (the card8 (aref vector x)))))) + t) + +#+(or lcl3.0 excl) +(defun fast-write-pixarray-16 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-16 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((vector (underlying-simple-vector array)) + (h 0 (index1+ h)) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type (simple-array pixarray-16-element-type (*)) vector) + (type array-index h y start)) + (do* ((end (index+ start (index* width 2))) + (i start (index+ i 2)) + (x (array-row-major-index array y x) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (let ((pixel (aref vector x))) + (declare (type pixarray-16-element-type pixel)) + (setf (aref buffer-bbuf (index+ i 0)) + (write-image-load-byte 0 pixel 16)) + (setf (aref buffer-bbuf (index+ i 1)) + (write-image-load-byte 8 pixel 16)))))) + t) + +#+Genera +(defun fast-write-pixarray-24 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-24 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((array array) + (h 0 (index1+ h)) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (sys:array-register-1d array) + (type array-index y start)) + (do* ((end (index+ start (index* width 3))) + (i start (index+ i 3)) + (x (array-row-major-index array y x) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (let ((pixel (sys:%1d-aref array x))) + (declare (type pixarray-24-element-type pixel)) + (setf (aref buffer-bbuf (index+ i 0)) + (write-image-load-byte 0 pixel 24)) + (setf (aref buffer-bbuf (index+ i 1)) + (write-image-load-byte 8 pixel 24)) + (setf (aref buffer-bbuf (index+ i 2)) + (write-image-load-byte 16 pixel 24)))))) + t) + +#+(or lcl3.0 excl) +(defun fast-write-pixarray-24 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-24 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((vector (underlying-simple-vector array)) + (h 0 (index1+ h)) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type (simple-array pixarray-24-element-type (*)) vector) + (type array-index y start)) + (do* ((end (index+ start (index* width 3))) + (i start (index+ i 3)) + (x (array-row-major-index array y x) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (let ((pixel (aref vector x))) + (declare (type pixarray-24-element-type pixel)) + (setf (aref buffer-bbuf (index+ i 0)) + (write-image-load-byte 0 pixel 24)) + (setf (aref buffer-bbuf (index+ i 1)) + (write-image-load-byte 8 pixel 24)) + (setf (aref buffer-bbuf (index+ i 2)) + (write-image-load-byte 16 pixel 24)))))) + t) + +#+(or lcl3.0 excl) +(defun fast-write-pixarray-32 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-32 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((vector (underlying-simple-vector array)) + (h 0 (index1+ h)) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type (simple-array pixarray-32-element-type (*)) vector) + (type array-index h y start)) + (do* ((end (index+ start (index* width 4))) + (i start (index+ i 4)) + (x (array-row-major-index array y x) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (let ((pixel (aref vector x))) + (declare (type pixarray-32-element-type pixel)) + (setf (aref buffer-bbuf (index+ i 0)) + (write-image-load-byte 0 pixel 32)) + (setf (aref buffer-bbuf (index+ i 1)) + (write-image-load-byte 8 pixel 32)) + (setf (aref buffer-bbuf (index+ i 2)) + (write-image-load-byte 16 pixel 32)) + (setf (aref buffer-bbuf (index+ i 2)) + (write-image-load-byte 24 pixel 32)))))) + t) + +(defun fast-write-pixarray (bbuf boffset pixarray x y width height + padded-bytes-per-line bits-per-pixel) + (declare (type buffer-bytes bbuf) + (type pixarray pixarray) + (type card16 x y width height) + (type array-index boffset padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel)) + (progn bbuf boffset pixarray x y width height padded-bytes-per-line + bits-per-pixel) + (or + #+lispm + (let* ((padded-bits-per-line (* padded-bytes-per-line 8)) + (padded-pixels-per-line + (floor padded-bits-per-line bits-per-pixel)) + (pixarray-padded-pixels-per-line + #+Genera (sys:array-row-span pixarray) + #-Genera (array-dimension pixarray 1)) + (pixarray-padded-bits-per-line + (* pixarray-padded-pixels-per-line bits-per-pixel))) + (when (and (= (sys:array-element-size pixarray) bits-per-pixel) + (zerop (index-mod padded-bits-per-line 32)) + (zerop (index-mod pixarray-padded-bits-per-line 32))) + (#+Genera sys:stack-let* #-Genera let* + ((dimensions (list height padded-pixels-per-line)) + (a (make-array + dimensions + :element-type (array-element-type pixarray) + :displaced-to bbuf + :displaced-index-offset (floor (* boffset 8) bits-per-pixel)))) + (sys:bitblt boole-1 width height pixarray x y a 0 0)) + t)) + #+Genera + (when (= bits-per-pixel 24) + (fast-write-pixarray-24 + bbuf boffset pixarray x y width height padded-bytes-per-line)) + #+(or lcl3.0 excl) + (funcall + (ecase bits-per-pixel + (1 #'fast-write-pixarray-1) (4 #'fast-write-pixarray-4) + (8 #'fast-write-pixarray-8) (16 #'fast-write-pixarray-16) + (24 #'fast-write-pixarray-24) (32 #'fast-write-pixarray-32)) + bbuf boffset pixarray x y width height padded-bytes-per-line) + )) + +;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another + +(defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel) + (declare (type pixarray pixarray copy) + (type card16 x y width height) + (type (member 1 4 8 16 24 32) bits-per-pixel)) + (progn pixarray copy x y width height bits-per-pixel) + (or + #+lispm + (let* ((pixarray-padded-pixels-per-line + #+Genera (sys:array-row-span pixarray) + #-Genera (array-dimension pixarray 1)) + (pixarray-padded-bits-per-line + (* pixarray-padded-pixels-per-line bits-per-pixel)) + (copy-padded-pixels-per-line + #+Genera (sys:array-row-span copy) + #-Genera (array-dimension copy 1)) + (copy-padded-bits-per-line + (* copy-padded-pixels-per-line bits-per-pixel))) + (when (and (= (sys:array-element-size pixarray) bits-per-pixel) + (zerop (index-mod pixarray-padded-bits-per-line 32)) + (zerop (index-mod copy-padded-bits-per-line 32))) + (sys:bitblt boole-1 width height pixarray x y copy 0 0) + t)) + #+Genera + (let ((src pixarray) + (dest copy)) + (declare (sys:array-register-1d src dest)) + (do* ((dst-y 0 (index1+ dst-y)) + (src-y y (index1+ src-y))) + ((index>= dst-y height)) + (declare (type card16 dst-y src-y)) + (do* ((dst-idx (array-row-major-index copy dst-y 0) + (index1+ dst-idx)) + (dst-end (index+ dst-idx width)) + (src-idx (array-row-major-index pixarray src-y x) + (index1+ src-idx))) + ((index>= dst-idx dst-end)) + (declare (type array-index dst-idx src-idx dst-end)) + (setf (sys:%1d-aref dest dst-idx) + (sys:%1d-aref src src-idx)))) + t) + #+(or lcl3.0 excl) + (macrolet + ((copy (type element-type) + `(let* ((pixarray pixarray) + (copy copy) + (src (underlying-simple-vector pixarray)) + (dst (underlying-simple-vector copy))) + (declare (type ,type pixarray copy) + (type (simple-array ,element-type (*)) src dst)) + #.(declare-buffun) + (do* ((dst-y 0 (index1+ dst-y)) + (src-y y (index1+ src-y))) + ((index>= dst-y height)) + (declare (type card16 dst-y src-y)) + (do* ((dst-idx (array-row-major-index copy dst-y 0) + (index1+ dst-idx)) + (dst-end (index+ dst-idx width)) + (src-idx (array-row-major-index pixarray src-y x) + (index1+ src-idx))) + ((index>= dst-idx dst-end)) + (declare (type array-index dst-idx src-idx dst-end)) + (setf (aref dst dst-idx) + (the ,element-type (aref src src-idx)))))))) + (ecase bits-per-pixel + (1 (copy pixarray-1 pixarray-1-element-type)) + (4 (copy pixarray-4 pixarray-4-element-type)) + (8 (copy pixarray-8 pixarray-8-element-type)) + (16 (copy pixarray-16 pixarray-16-element-type)) + (24 (copy pixarray-24 pixarray-24-element-type)) + (32 (copy pixarray-32 pixarray-32-element-type))) + t))) diff --git a/clx/display.lisp b/clx/display.lisp new file mode 100644 index 000000000..05cbcc283 --- /dev/null +++ b/clx/display.lisp @@ -0,0 +1,533 @@ +;;; -*- 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) + +(export '( + with-display + with-event-queue + open-display + display-force-output + close-display + display-protocol-version + display-vendor + display-roots + display-motion-buffer-size + display-max-request-length + display-error-handler + display-after-function + display-invoke-after-function + display-finish-output)) + +;; +;; 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 (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 + (declare (type display display) + (type t object)) + (declare (values resource-id)) + (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 (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 (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 (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 (values (or null resource-id))) + (gethash (if (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 (values resource-id)) + (let ((atom (if (keywordp atom) atom (kintern atom)))) + (declare (type keyword 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) + (do ((i 1 (1+ i)) + (end (length *predefined-atoms*))) + ((>= i end)) + (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) + (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)) + #+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) + (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 &rest options &key (display 0) protocol + authorization-name authorization-data &allow-other-keys) + ;; 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) + (dynamic-extent options)) + (declare (values display)) + ;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM. + (let* ((stream (open-x-stream host display protocol)) + (disp (apply #'make-buffer + #x2000 'make-display-internal + :host host + :display display + :output-stream stream + :input-stream stream + :allow-other-keys t + options)) + (ok-p nil)) + (unwind-protect + (progn + (display-connect disp + :authorization-name authorization-name + :authorization-data 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) + (unless authorization-name (setq authorization-name "")) + (unless authorization-data (setq 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) + (write-sequence-char 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 + (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) + (buffer-input display buffer-bbuf 0 40) + (let* ((root (make-window :id (card32-get 0) :display display)) + (root-visual (card32-get 32)) + (default-colormap + (make-colormap :id (card32-get 4) + :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 (window-id root) root) + ;; Create the depth AList for a screen, (depth . visual-infos) + (dotimes (j num-depths) + (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) + (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 (values major minor)) + (values (display-protocol-major-version display) + (display-protocol-minor-version display))) + +(defun display-vendor (display) + (declare (type display display)) + (declare (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/clx/doc.lisp b/clx/doc.lisp new file mode 100644 index 000000000..eb38a9363 --- /dev/null +++ b/clx/doc.lisp @@ -0,0 +1,3807 @@ +;;; -*- 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. + +;; Note: various perversions of the CL type system are used below. +;; Examples: (list elt-type) (sequence elt-type) + +(proclaim '(declaration arglist 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 <mumble>-display (<mumble>) + (declare (type <mumble> <mumble>) + (values display))) + +(defun <mumble>-id (<mumble>) + (declare (type <mumble> <mumble>) + (values resource-id))) + +(defun <mumble>-equal (<mumble>-1 <mumble>-2) + (declare (type <mumble> <mumble>-1 <mumble>-2))) + +(defun <mumble>-p (<mumble>) + (declare (type <mumble> <mumble>) + (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) + (values color))) + +(defun color-rgb (color) + (declare (type color color) + (values red green blue))) + +(defun color-red (color) + ;; setf'able + (declare (type color color) + (values rgb-val))) + +(defun color-green (color) + ;; setf'able + (declare (type color color) + (values rgb-val))) + +(defun color-blue (color) + ;; setf'able + (declare (type color color) + (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)) + +(deftype real (&optional (min '*) (max '*)) + `(or (real ,min ,max) (rational ,min ,max))) + +;; An association list. + +(deftype alist (key-type-and-name datum-type-and-name) 'list) + +;; 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 (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 (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 (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 (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 <unspec> :type (member 8 16 32)) + (pad <unspec> :type (member 8 16 32)) + (lsb-first-p <unspec> :type boolean)) + +(defstruct pixmap-format + (depth <unspec> :type image-depth) + (bits-per-pixel <unspec> :type (member 1 4 8 16 24 32)) + (pad <unspec> :type (member 8 16 32))) + +(defstruct visual-info + (id <unspec> :type resource-id) + (display <unspec> :type display) + (class <unspec> :type (member :static-gray :static-color :true-color + :gray-scale :pseudo-color :direct-color)) + (red-mask <unspec> :type pixel) + (green-mask <unspec> :type pixel) + (blue-mask <unspec> :type pixel) + (bits-per-rgb <unspec> :type card8) + (colormap-entries <unspec> :type card16)) + +(defstruct screen + (root <unspec> :type window) + (width <unspec> :type card16) + (height <unspec> :type card16) + (width-in-millimeters <unspec> :type card16) + (height-in-millimeters <unspec> :type card16) + (depths <unspec> :type (alist (image-depth depth) ((list visual-info) visuals))) + (root-depth <unspec> :type image-depth) + (root-visual-info <unspec> :type visual-info) + (default-colormap <unspec> :type colormap) + (white-pixel <unspec> :type pixel) + (black-pixel <unspec> :type pixel) + (min-installed-maps <unspec> :type card16) + (max-installed-maps <unspec> :type card16) + (backing-stores <unspec> :type (member :never :when-mapped :always)) + (save-unders-p <unspec> :type boolean) + (event-mask-at-open <unspec> :type mask32)) + +(defun screen-root-visual (screen) + (declare (type screen screen) + (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) + (values display))) + +(defun display-protocol-major-version (display) + (declare (type display display) + (values card16))) + +(defun display-protocol-minor-version (display) + (declare (type display display) + (values card16))) + +(defun display-vendor-name (display) + (declare (type display display) + (values string))) + +(defun display-release-number (display) + (declare (type display display) + (values card32))) + +(defun display-image-lsb-first-p (display) + (declare (type display display) + (values boolean))) + +(defun display-bitmap-formap (display) + (declare (type display display) + (values bitmap-format))) + +(defun display-pixmap-formats (display) + (declare (type display display) + (values (list pixmap-formats)))) + +(defun display-roots (display) + (declare (type display display) + (values (list screen)))) + +(defun display-motion-buffer-size (display) + (declare (type display display) + (values card32))) + +(defun display-max-request-length (display) + (declare (type display display) + (values card16))) + +(defun display-min-keycode (display) + (declare (type display display) + (values card8))) + +(defun display-max-keycode (display) + (declare (type display display) + (values card8))) + +(defun close-display (display) + (declare (type display display))) + +(defun display-error-handler (display) + (declare (type display display) + (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 (sequence (function (display symbol &rest key-vals))) + (function (display symbol &rest key-vals))) + 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 &rest key-vals) + ;; 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) + (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) + (values window))) + +(defun window-class (window) + (declare (type window window) + (values (member :input-output :input-only)))) + +(defun window-visual-info (window) + (declare (type window window) + (values visual-info))) + +(defun window-visual (window) + (declare (type window window) + (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) + (values win-gravity))) + +(defun window-bit-gravity (window) + ;; setf'able + (declare (type window window) + (values bit-gravity))) + +(defun window-backing-store (window) + ;; setf'able + (declare (type window window) + (values (member :not-useful :when-mapped :always)))) + +(defun window-backing-planes (window) + ;; setf'able + (declare (type window window) + (values pixel))) + +(defun window-backing-pixel (window) + ;; setf'able + (declare (type window window) + (values pixel))) + +(defun window-save-under (window) + ;; setf'able + (declare (type window window) + (values (member :on :off)))) + +(defun window-event-mask (window) + ;; setf'able + (declare (type window window) + (values mask32))) + +(defun window-do-not-propagate-mask (window) + ;; setf'able + (declare (type window window) + (values mask32))) + +(defun window-override-redirect (window) + ;; setf'able + (declare (type window window) + (values (member :on :off)))) + +(defun window-colormap (window) + (declare (type window window) + (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) + (values boolean))) + +(defun window-all-event-masks (window) + (declare (type window window) + (values mask32))) + +(defun window-map-state (window) + (declare (type window window) + (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) + (values window))) + +(defun drawable-depth (drawable) + (declare (type drawable drawable) + (values card8))) + +(defun drawable-x (drawable) + (declare (type drawable drawable) + (values int16))) + +(defun drawable-y (drawable) + (declare (type drawable drawable) + (values int16))) + +(defun drawable-width (drawable) + ;; For windows, inside width, excluding border. + (declare (type drawable drawable) + (values card16))) + +(defun drawable-height (drawable) + ;; For windows, inside height, excluding border. + (declare (type drawable drawable) + (values card16))) + +(defun drawable-border-width (drawable) + (declare (type drawable drawable) + (values card16))) + +(defun query-tree (window &key (result-type 'list)) + (declare (type window window) + (type type result-type) + (values (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) + (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 (sequence xatom) properties) + (type int16 delta))) + +(defun list-properties (window &key (result-type 'list)) + (declare (type window window) + (type type result-type) + (values (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) + (values resource-id))) + +(defun find-atom (display name) + (declare (type display display) + (type xatom name) + (values (or null resource-id)))) + +(defun atom-name (display atom-id) + (declare (type display display) + (type resource-id atom-id) + (values keyword))) + +(defun selection-owner (display selection) + (declare (type display display) + (type xatom selection) + (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) + (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) + (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) + (values x y same-screen-p child mask root-x root-y root))) + +(defun pointer-position (window) + (declare (type window window) + (values x y same-screen-p))) + +(defun global-pointer-position (display) + (declare (type display display) + (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) + (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) + (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) + (values focus revert-to))) + +(defun query-keymap (display) + (declare (type display display) + (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) + (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) + (values (or null string)))) + +(defun font-direction (font) + (declare (type font font) + (values draw-direction))) + +(defun font-min-char (font) + (declare (type font font) + (values card16))) + +(defun font-max-char (font) + (declare (type font font) + (values card16))) + +(defun font-min-byte1 (font) + (declare (type font font) + (values card8))) + +(defun font-max-byte1 (font) + (declare (type font font) + (values card8))) + +(defun font-min-byte2 (font) + (declare (type font font) + (values card8))) + +(defun font-max-byte2 (font) + (declare (type font font) + (values card8))) + +(defun font-all-chars-exist-p (font) + (declare (type font font) + (values boolean))) + +(defun font-default-char (font) + (declare (type font font) + (values card16))) + +(defun font-ascent (font) + (declare (type font font) + (values int16))) + +(defun font-descent (font) + (declare (type font font) + (values int16))) + +;; The list contains alternating keywords and int32s. + +(deftype font-props () 'list) + +(defun font-properties (font) + (declare (type font font) + (values font-props))) + +(defun font-property (font name) + (declare (type font font) + (type keyword name) + (values (or null int32)))) + +;; For each of left-bearing, right-bearing, width, ascent, descent, attributes: + +(defun char-<metric> (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) + (values (or null int16)))) + +(defun max-char-<metric> (font) + ;; Note: I have tentatively chosen separate accessors over allowing :min and + ;; :max as an index above. + (declare (type font font) + (values int16))) + +(defun min-char-<metric> (font) + (declare (type font font) + (values int16))) + +;; Note: char16-<metric> 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) + (values (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) + (values (sequence font)))) + +(defun font-path (display &key (result-type 'list)) + (declare (type display display) + (type type result-type) + (values (sequence (or string pathname))))) + +(defsetf font-path (display) (paths) + (declare (type display display) + (type (sequence (or string pathname)) paths))) + +(defun create-pixmap (&key width height depth drawable) + (declare (type card16 width height) + (type card8 depth) + (type drawable drawable) + (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 (sequence card8))) dashes) + (type boolean cache) + (values gcontext))) + +;; For each argument to create-gcontext (except font, clip-mask and +;; clip-ordering) declared as (type <type> <name>), there is an accessor: + +(defun gcontext-<name> (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) + (values <type>))) + +;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared +;; as (type (or null <type>) <name>), there is a setf for the corresponding accessor: + +(defsetf gcontext-<name> (gcontext) (value) + (declare (type gcontext gcontext) + (type <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) + (values (or null font)))) + +(defun gcontext-clip-mask (gcontext) + (declare (type gcontext gcontext) + (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 (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 (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 (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) + (values (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) + (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) + (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) + (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) + (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) + (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) + (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) + (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) + (values colormap))) + +(defun free-colormap (colormap) + (declare (type colormap colormap))) + +(defun copy-colormap-and-free (colormap) + (declare (type colormap colormap) + (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) + (values (sequence colormap)))) + +(defun alloc-color (colormap color) + (declare (type colormap colormap) + (type (or stringable color) color) + (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) + (values (sequence pixel) (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) + (values (sequence pixel) red-mask green-mask blue-mask))) + +(defun free-colors (colormap pixels &optional (plane-mask 0)) + (declare (type colormap colormap) + (type (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 (sequence pixel) pixels) + (type type result-type) + (values (sequence color)))) + +(defun lookup-color (colormap name) + (declare (type colormap colormap) + (type stringable name) + (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) + (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) + (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) + (values width height))) + +(defun query-best-tile (width height drawable) + (declare (type card16 width height) + (type drawable drawable) + (values width height))) + +(defun query-best-stipple (width height drawable) + (declare (type card16 width height) + (type drawable drawable) + (values width height))) + +(defun query-extension (display name) + (declare (type display display) + (type stringable name) + (values major-opcode first-event first-error))) + +(defun list-extensions (display &key (result-type 'list)) + (declare (type display display) + (type type result-type) + (values (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 (sequence card8) shift lock control mod1 mod2 mod3 mod4 mod5) + (values (member :success :busy :failed)))) + +(defun modifier-mapping (display) + ;; each value is a list of card8s + (declare (type display display) + (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) + (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) + (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) + (values (sequence card8)))) + +(defsetf pointer-mapping (display) (map) + ;; Can signal device-busy. + (declare (type display display) + (type (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) + (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) + (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) + (values (sequence host) enabled-p))) + +(defun access-control (display) + ;; setf'able + (declare (type display display) + (values boolean))) + +(defun close-down-mode (display) + ;; setf'able + ;; Cached locally in display object. + (declare (type display display) + (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 (list event-mask-class) keys) + (values mask32))) + +(defun make-event-keys (event-mask) + ;; This is only defined for core events. + (declare (type mask32 event-mask) + (values (list event-mask-class)))) + +(defun make-state-mask (&rest keys) + ;; Useful for constructing modifier-mask, state-mask. + (declare (type (list state-mask-key) keys) + (values mask16))) + +(defun make-state-keys (state-mask) + (declare (type mask16 mask) + (values (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) + (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 (sequence (function (&rest key-vals) t)) + (function (&rest key-vals) 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) + (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) + (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) + (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) + (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) + (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) + (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) + (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) + (card32 time)) + +(declare-event :selection-clear + (card16 sequence) + (window (window event-window)) + (keyword selection) + (card32 time)) + +(declare-event :selection-request + (card16 sequence) + (window (window event-window) requestor) + (keyword selection target) + ((or null keyword) property) + (card32 time)) + +(declare-event :selection-notify + (card16 sequence) + (window (window event-window)) + (keyword selection target) + ((or null keyword) property) + (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 integer) 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) + (values string))) + +(defsetf wm-name (window) (name)) + +(defun wm-icon-name (window) + (declare (type window window) + (values string))) + +(defsetf wm-icon-name (window) (name)) + +(defun get-wm-class (window) + (declare (type window window) + (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) + (values (list string)))) + +(defsetf wm-command (window) (command) + ;; Uses PRIN1 to a string-stream with the following bindings: + ;; (*print-length* nil) (*print-level* nil) (*print-radix* nil) + ;; (*print-base* 10.) (*print-array* t) (*package* (find-package 'lisp)) + ;; each element of command is seperated with NULL characters. + ;; This enables (mapcar #'read-from-string (wm-command window)) + ;; to recover a lisp command. + (declare (type window window) + (type (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) + (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) + (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) + (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) + (values wm-size-hints))) + +(defsetf icon-sizes (window) (wm-size-hints)) + +(defun wm-protocols (window) + (declare (type window window) + (values protocols))) + +(defsetf wm-protocols (window) (protocols) + (declare (type window window) + (type (list keyword) protocols))) + +(defun wm-colormap-windows (window) + (declare (type window window) + (values windows))) + +(defsetf wm-colormap-windows (window) (windows) + (declare (type window window) + (type (list window) windows))) + +(defun transient-for (window) + (declare (type window window) + (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 + 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 (or null boolean) user-specified-position-p user-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) + (values (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 (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) + (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) + (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 string-char t) object) + (type keysym keysym) + (type (or null mask16 list) ;; (list (or keysym state-mask-key)) + modifiers) + (type (or null (member :modifiers) mask16 list) ;; (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 list) ; (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 string-char t) object) + (type keysym keysym) + (type (or null mask16 list) ;; (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: + ;; (string-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) + (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 (list card8) bytes) + (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) + (values (list keysym)))) + +(defun keycode->keysym (display keycode keysym-index) + (declare (type display display) + (type card8 code) + (type card16 state) + (type card8 keysym-index) + (values keysym))) + +(defun keysym->keycodes (display keysym) + ;; Return keycodes for keysym, as multiple values + (declare (type display display) + (type keysym keysym) + (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) + (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) + (values (or null character)))) + +(defun default-keysym-index (display keycode state) + ;; Returns a keysym-index for use with keycode->character + (declare (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) + (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 (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) + (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) + (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 (list keywords)) event-codes) + (type (alist (field-type symbol) (field-names (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 (function (gcontext t) t) set-function) ;; required + (type (or null (function (gcontext gcontext t) t)) + 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) + (values region))) + +(defun region-p (thing)) + +(defun copy-region (region)) + +(defun region-empty-p (region) + (declare (type region region) + (values boolean))) + +(defun region-clip-box (region) + ;; Returns a region which is the smallest enclosing rectangle + ;; enclosing REGION + (declare (type region region) + (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 (list region) regions) + (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 (list region) regions) + (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) + (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) + (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) + (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) + (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) + (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) +;; (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) + (values region))) + +(defun region->image (region) + ;; Returns a depth-1 image containg 1 bits for every pixel in REGION. + (declare (type region region) + (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) + (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 (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 + (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) + (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) + (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) + (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) + (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 (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 (list stringable) full-name full-class) + (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 (list stringable) name-list) + (type t value))) + +(defun delete-resource (database name-list) + (declare (type resource-database database) + (type (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 ((list stringable) t &rest t) t) function) + (values nil))) + +(defun merge-resources (database with-database) + (declare (type resource-database database with-database) + (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 ((list string) t) boolean)) + test test-not) + (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 ((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 t) boolean)) test test-not) + (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 t) boolean)) test test-not) + (type (or null (function (string stream) t)) write) + (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 (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/clx/exclMakefile b/clx/exclMakefile new file mode 100644 index 000000000..567023432 --- /dev/null +++ b/clx/exclMakefile @@ -0,0 +1,133 @@ +# +# Makefile for CLX +# (X11 R4 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 = excldep.fasl defsystem.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 = 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 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 + + +all: $(C_OBJS) compile-CLX cat + +clos: $(C_OBJS) compile-closified-CLX cat + +CLX: $(C_OBJS) compile-CLX load-CLX + + +c: $(C_OBJS) + + +lisp: compile-CLX + + +compile-CLX: $(C_OBJS) + $(ECHO) " \ + (set-case-mode :case-sensitive-lower) \ + (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ + (compile-file-if-needed \"excldep\") \ + (compile-file-if-needed \"defsystem\") \ + (load \"defsystem\") \ + #+allegro (compile-system :clx) \ + #-allegro (xlib::compile-clx) \ + #+allegro (compile-system :clx-debug)" \ + | $(CL) $(CLOPTS) -batch + + +compile-closified-CLX: $(C_OBJS) + $(ECHO) " \ + (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ + (setq excl::*print-nickname* t) \ + (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))) \ + (compile-file-if-needed \"excldep\") \ + (compile-file-if-needed \"defsystem\") \ + (load \"defsystem\") \ + #+allegro (compile-system :clx) \ + #-allegro (xlib::compile-clx) \ + #+allegro (compile-system :clx-debug)" \ + | $(CL) $(CLOPTS) -batch + + +cat: + -cat $(L_NOMACROS_OBJS) > CLX.fasl + + +load-CLX: + $(ECHO) '(load "defsystem")' \ + "(let (#+allegro (spread (sys:gsgc-parameter :generation-spread)))" \ + " #+allegro (setf (sys:gsgc-parameter :generation-spread) 1)" \ + " #+allegro (load-system :clx)" \ + " #-allegro (xlib::load-clx)" \ + " #+allegro (gc :tenure)" \ + " #+allegro (setf (sys:gsgc-parameter :generation-spread) spread)" \ + ")" \ + '#+allegro (gc t)' \ + '(dumplisp :name "$(CLX)" #+allegro :checkpoint #+allegro nil)' \ + '(exit)' | $(CL) $(CLOPTS) + + +clean: + $(RM) -f *.fasl debug/*.fasl $(CLX) core $(C_OBJS) + + +install: + mv CLX.fasl $(DEST)/clx.fasl + mv *.o $(DEST) + + +tags: + $(TAGS) $(L_SRC) $(C_SRC) diff --git a/clx/exclREADME b/clx/exclREADME new file mode 100644 index 000000000..02ed020a8 --- /dev/null +++ b/clx/exclREADME @@ -0,0 +1,59 @@ + 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 +and 3.1. + + 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 +% mkdir MIT +% mv defsystem.cl MIT +% mv excldefsys.cl defsystem.cl +% 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: + +<cl> (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: + +<cl> (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/clx/exclcmac.lisp b/clx/exclcmac.lisp new file mode 100644 index 000000000..9759e4d00 --- /dev/null +++ b/clx/exclcmac.lisp @@ -0,0 +1,313 @@ +;;; -*- 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 :use '(:foreign-functions :lisp :excl)) + +(import '(excl::defcmacro)) + +;; +;; Type predicates +;; +(defcmacro card8p (x) + (let ((xx (gensym))) + `(let ((,xx ,x)) + (declare (optimize (speed 3) (safety 0)) + (fixnum ,xx)) + (and (fixnump ,xx) (> #.(expt 2 8) ,xx) (>= ,xx 0))))) + +(defcmacro card16p (x) + (let ((xx (gensym))) + `(let ((,xx ,x)) + (declare (optimize (speed 3) (safety 0)) + (fixnum ,xx)) + (and (fixnump ,xx) (> #.(expt 2 16) ,xx) (>= ,xx 0))))) + +(defcmacro int8p (x) + (let ((xx (gensym))) + `(let ((,xx ,x)) + (declare (optimize (speed 3) (safety 0)) + (fixnum ,xx)) + (and (fixnump ,xx) (> #.(expt 2 7) ,xx) (>= ,xx #.(expt -2 7)))))) + +(defcmacro int16p (x) + (let ((xx (gensym))) + `(let ((,xx ,x)) + (declare (optimize (speed 3) (safety 0)) + (fixnum ,xx)) + (and (fixnump ,xx) (> #.(expt 2 15) ,xx) (>= ,xx #.(expt -2 15)))))) + +;; Card29p, card32p, int32p are too large to expand inline + + +;; +;; Type transformers +;; +(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))))) +(defcmacro int8->card8 (x) + `(locally ,(declare-bufmac) + (the card8 (ldb (byte 8 0) (the int8 ,x))))) + +(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))))) + +(defcmacro int16->card16 (x) + `(locally ,(declare-bufmac) + (the card16 (ldb (byte 16 0) (the int16 ,x))))) + +(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))))) + +(defcmacro int32->card32 (x) + `(locally ,(declare-bufmac) + (the card32 (ldb (byte 32 0) (the int32 ,x))))) + +(defcmacro char->card8 (char) + `(locally ,(declare-bufmac) + (the card8 (char-code (the string-char ,char))))) + +(defcmacro card8->char (card8) + `(locally ,(declare-bufmac) + (the string-char (code-char (the card8 ,card8))))) + + +;; +;; Array accessors and setters +;; +(defcmacro aref-card8 (a i) + `(locally ,(declare-bufmac) + (the card8 (aref (the buffer-bytes ,a) (the array-index ,i))))) + +(defcmacro aset-card8 (v a i) + `(locally ,(declare-bufmac) + (setf (aref (the buffer-bytes ,a) (the array-index ,i)) + (the card8 ,v)))) + +(defcmacro aref-int8 (a i) + `(locally ,(declare-bufmac) + (card8->int8 (aref (the buffer-bytes ,a) (the array-index ,i))))) + +(defcmacro aset-int8 (v a i) + `(locally ,(declare-bufmac) + (setf (aref (the buffer-bytes ,a) (the array-index ,i)) + (int8->card8 ,v)))) + +(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)))) + +(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)))) + +(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)))) + +(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)))) + +(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)))) + +(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)))) + +(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)))) + +(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)))) + +(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)))) + +(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 +;; +(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))))) + +(defcmacro font-font-info (font) + (let ((f (gensym))) + `(let ((,f ,font)) + (or (font-font-info-internal ,f) + (query-font ,f))))) + +(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 +;; +(defcmacro current-process () + `(the (or mp::process null) (and mp::*scheduler-stack-group* + mp::*current-process*))) + +(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)))))) + +#+notyet +(defcmacro buffer-replace (target-sequence source-sequence target-start + target-end &optional (source-start 0)) + (let ((tv (gensym)) (sv (gensym)) (ts (gensym)) (te (gensym)) (ss (gensym))) + `(let ((,tv ,target-sequence) (,sv ,source-sequence) + (,ts ,target-start) (,te ,target-end) (,ss ,source-start)) + (declare (type buffer-bytes ,tv ,sv) + (type array-index ,ts ,te ,ss) + (optimize (speed 3) (safety 0))) + + (let ((source-end (length ,sv))) + (declare (type array-index source-end)) + + (if* (and (eq ,tv ,sv) + (> ,ts ,ss)) + then (let ((nelts (min (- ,te ,ts) + (- source-end ,ss)))) + (do ((target-index (+ ,ts nelts -1) (1- target-index)) + (source-index (+ ,ss nelts -1) (1- source-index))) + ((= target-index (1- ,ts)) ,tv) + (declare (type array-index target-index source-index)) + + (setf (aref ,tv target-index) + (aref ,sv source-index)))) + else (do ((target-index ,ts (1+ target-index)) + (source-index ,ss (1+ source-index))) + ((or (= target-index ,te) (= source-index source-end)) + ,tv) + (declare (type array-index target-index source-index)) + + (setf (aref ,tv target-index) + (aref ,sv source-index)))))))) + +(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))))))) + +(defcmacro byte-reverse (byte) + `(aref ,'#.(coerce + '#(0 128 64 192 32 160 96 224 16 144 80 208 48 176 112 240 + 8 136 72 200 40 168 104 232 24 152 88 216 56 184 120 248 + 4 132 68 196 36 164 100 228 20 148 84 212 52 180 116 244 + 12 140 76 204 44 172 108 236 28 156 92 220 60 188 124 252 + 2 130 66 194 34 162 98 226 18 146 82 210 50 178 114 242 + 10 138 74 202 42 170 106 234 26 154 90 218 58 186 122 250 + 6 134 70 198 38 166 102 230 22 150 86 214 54 182 118 246 + 14 142 78 206 46 174 110 238 30 158 94 222 62 190 126 254 + 1 129 65 193 33 161 97 225 17 145 81 209 49 177 113 241 + 9 137 73 201 41 169 105 233 25 153 89 217 57 185 121 249 + 5 133 69 197 37 165 101 229 21 149 85 213 53 181 117 245 + 13 141 77 205 45 173 109 237 29 157 93 221 61 189 125 253 + 3 131 67 195 35 163 99 227 19 147 83 211 51 179 115 243 + 11 139 75 203 43 171 107 235 27 155 91 219 59 187 123 251 + 7 135 71 199 39 167 103 231 23 151 87 215 55 183 119 247 + 15 143 79 207 47 175 111 239 31 159 95 223 63 191 127 255) + '(vector card8)) + ,byte)) + +#| +#+(or allegro-v3.0 allegro-v3.1) +(defcmacro graphic-char-p (char) + `(let* ((cint (char-int ,char))) + (if (and (<= #.(char-code #\space) cint) + (<= cint #.(char-code #\~))) + t + nil))) +|# + diff --git a/clx/excldefsys.lisp b/clx/excldefsys.lisp new file mode 100644 index 000000000..abbc5dc71 --- /dev/null +++ b/clx/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/clx/excldep.c b/clx/excldep.c new file mode 100644 index 000000000..c6fe25c64 --- /dev/null +++ b/clx/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 <sys/types.h> +#include <sys/errno.h> +#include <sys/time.h> +#include <stdio.h> + +#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/clx/excldep.lisp b/clx/excldep.lisp new file mode 100644 index 000000000..62c4574dd --- /dev/null +++ b/clx/excldep.lisp @@ -0,0 +1,514 @@ +;;; -*- 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 :use '(:foreign-functions :lisp :excl)) + +(eval-when (load) + (provide :clxexcldep) + (provide :clx)) + +(require :foreign) +(require :process) ; Needed even if scheduler is not + ; running. (Must be able to make + ; a process-lock.) + +(import '(excl::if* + excl::type-error + excl::type-error-datum + excl::type-error-expected-type)) +#+allegro +(import '(excl::without-interrupts)) + +#-(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 define-condition (name (parent-type) &optional slots &rest args) + `(excl::define-condition ,name (,parent-type) ,slots ,@args)) + + +(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))))) + + +(defun underlying-simple-vector (array) + (cond ((excl::svectorp array) + array) + ((arrayp array) + (cdr (excl::ah_data array))) + (t + (error "~s is not an array" array)))) + + +(defconstant type-pred-alist + '( + (card8 . card8p) + (card16 . card16p) + (card29 . card29p) + (card32 . card32p) + (int8 . int8p) + (int16 . int16p) + (int32 . int32p) + (mask16 . card16p) + (mask32 . card32p) + (pixel . card32p) + (resource-id . card29p) + (keysym . card32p) + )) + +;; This (if (and ...) t nil) stuff has a purpose -- it lets the old +;; sun4 compiler opencode the `and'. + +(defun card8p (x) + (declare (optimize (speed 3) (safety 0)) + (fixnum x)) + (if (and (fixnump x) (> #.(expt 2 8) x) (>= x 0)) + t + nil)) + +(defun card16p (x) + (declare (optimize (speed 3) (safety 0)) + (fixnum x)) + (if (and (fixnump x) (> #.(expt 2 16) x) (>= x 0)) + t + nil)) + +(defun card29p (x) + (declare (optimize (speed 3) (safety 0))) + (if (or (and (fixnump x) (>= (the fixnum x) 0)) + (and (bignump x) (> #.(expt 2 29) (the bignum x)) + (>= (the bignum x) 0))) + t + nil)) + +(defun card32p (x) + (declare (optimize (speed 3) (safety 0))) + (if (or (and (fixnump x) (>= (the fixnum x) 0)) + (and (bignump x) (> #.(expt 2 32) (the bignum x)) + (>= (the bignum x) 0))) + t + nil)) + +(defun int8p (x) + (declare (optimize (speed 3) (safety 0)) + (fixnum x)) + (if (and (fixnump x) (> #.(expt 2 7) x) (>= x #.(expt -2 7))) + t + nil)) + +(defun int16p (x) + (declare (optimize (speed 3) (safety 0)) + (fixnum x)) + (if (and (fixnump x) (> #.(expt 2 15) x) (>= x #.(expt -2 15))) + t + nil)) + +(defun int32p (x) + (declare (optimize (speed 3) (safety 0))) + (if (or (fixnump x) + (and (bignump x) (> #.(expt 2 31) (the bignum x)) + (>= (the bignum x) #.(expt -2 31)))) + t + nil)) + +(comp::def-tr comp::new-tr-typep typep (form type) + (let (ent) + (if* (and (consp type) + (eq 'quote (car type)) + (consp (cdr type))) + then (setq ent (franz:assq (cadr type) type-pred-alist))) + (if* ent + then `(,(cdr ent) ,form) + else (if* (and (consp type) + (eq 'quote (car type)) + (consp (cdr type))) + then (setq ent (franz:assq (cadr type) + excl::type-pred-alist))) + (if* ent + then `(,(cdr ent) ,form) + else (comp::no-transform))))) + + +;; 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) + (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)) + (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)))) + + +#-allegro +(defmacro without-interrupts (&body body) + `(let ((excl::*without-interrupts* t)) ,@body)) + + +(in-package :excl) + +#-allegro +(defun type-array-element-type-to-array (type &aux temp) + ;; type is a type descriptor, return a descriptor which tells + ;; the array code what kind of array to make + + ; convert the given element type to one of the symbols which + ; is in the car of the array-descriptors list + ;(msg "beginning type is " type 'N) + (if* (symbolp type) + then (if* (franz:memq type '(t bit string-char fixnum)) + thenret ; it is ok as it is + else (let ((temp (get type 'deftype-expander))) + (if* temp + then + (return-from type-array-element-type-to-array + (type-array-element-type-to-array + (funcall temp (list type)))) + else + (setq type (case type + (standard-char 'string-char) + ((single-float short-float) 'single-float) + ((double-float long-float) 'double-float) + (t t)))))) + elseif (consp type) + then (setq type + (case (car type) + (mod (if* (integerp (setq temp (cadr type))) + then (cond ((< temp 1) t) + ((<= temp 2) 'bit) + ((<= temp 256) 'ubyte) + ((<= temp 65536) 'uword) + ((<= temp 4294967296) 'ulong) + (t t)) + else t)) + (signed-byte + (if* (integerp (setq temp (cadr type))) + then (cond ((<= temp 0) t) + ((<= temp 8) 'byte) + ((<= temp 16) 'word) + ((<= temp 29) 'fixnum) + ((<= temp 32) 'long) + (t t)) + else t)) + (unsigned-byte + (if* (integerp (setq temp (cadr type))) + then (cond ((<= temp 0) t) + ((<= temp 8) 'ubyte) + ((<= temp 16) 'uword) + ((<= temp 32) 'ulong) + (t t)) + else t)) + (t t))) + else (setq type t)) + ; type is now one of the valid types. We return a descriptor + ; based on that name + ;(msg "resulting type is " type 'N) + (let ((res (franz:assq type array-descriptors))) + ;(msg " resulting decriptor " res 'N) + res)) + +#-allegro +(defun make-sequence (type length &rest rest &key initial-element) + "Returns a sequence of the given Type and Length, with elements initialized + to :Initial-Element." + (declare (fixnum length) + (ignore initial-element)) + (case (type-specifier type) + (list (apply #'make-list length rest)) + ((simple-string string) + (apply #'make-string length rest)) + ((array simple-array vector simple-vector) + (if* (listp type) + then (apply #'make-array length :element-type (cadr type) rest) + else (apply #'make-array length rest))) + ((bit-vector simple-bit-vector) + (apply #'make-array length :element-type 'bit rest)) + (t + ;; Now, we can either have a user-defined type symbol, or an error. + (if* (symbolp type) + then (let ((temp (get type 'excl::deftype-expander))) + (if* temp + then (cond (rest (return-from make-sequence + (make-sequence (funcall temp (list type)) length + :initial-element (cadr rest)))) + (t (return-from make-sequence (make-sequence + (funcall temp (list type)) length))))))) + (error "~s is a bad type specifier for sequences." type )))) + +;; special patch for CLX (various process fixes) +;; patch1000.2 + +(in-package 'patch :use '(lisp excl)) + +(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 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 (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))))) + (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 + (if* (null (process-lock-locker lock)) + then (setf (process-lock-locker lock) lock-value) + else (if* timeout + then (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. + (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 (if* (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) + (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)) + (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/clx/fonts.lisp b/clx/fonts.lisp new file mode 100644 index 000000000..b40f98679 --- /dev/null +++ b/clx/fonts.lisp @@ -0,0 +1,373 @@ +;;; -*- 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) + +(export '( + open-font + discard-font-info + close-font + list-font-names + list-fonts + font-path)) + +;; 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-<metric> (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) +; (values (or null integer)))) + +;(defun max-char-<metric> (font) +; ;; Note: I have tentatively chosen separate accessors over allowing :min and +; ;; :max as an index above. +; (declare (type font font) +; (values integer))) + +;(defun min-char-<metric> (font) +; (declare (type font font) +; (values integer))) + +;; Note: char16-<metric> accessors could be defined to accept two-byte indexes. + +(deftype char-info-vec () '(simple-array int16 (6))) + +(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 (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 (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 (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) + (array-register 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 (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 (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 (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 (values (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 (values (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 (values (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 sequence paths)) ;; (sequence (or string pathname)) + (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)))))) + +(defsetf font-path set-font-path) diff --git a/clx/gcontext.lisp b/clx/gcontext.lisp new file mode 100644 index 000000000..41c33a6c2 --- /dev/null +++ b/clx/gcontext.lisp @@ -0,0 +1,994 @@ +;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- + +;;; GContext + +;;; +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 +;;; +;;; Copyright (C) 1987 Texas Instruments Incorporated. +;;; +;;; Permission is granted to any individual or institution to use, copy, modify, +;;; and distribute this software, provided that this complete copyright and +;;; permission notice is maintained, intact, in all copies and supporting +;;; documentation. +;;; +;;; Texas Instruments Incorporated provides this software "as is" without +;;; express or implied warranty. +;;; + +;;; GContext values are usually cached locally in the GContext object. +;;; This is required because the X.11 server doesn't have any requests +;;; for getting GContext values back. +;;; +;;; GContext changes are cached until force-GContext-changes is called. +;;; All the requests that use GContext (including the GContext accessors, +;;; but not the SETF's) call force-GContext-changes. +;;; In addition, the macro WITH-GCONTEXT may be used to provide a +;;; local view if a GContext. +;;; +;;; Each GContext keeps a copy of the values the server has seen, and +;;; a copy altered by SETF, called the LOCAL-STATE (bad name...). +;;; The SETF accessors increment a timestamp in the GContext. +;;; When the timestamp in a GContext isn't equal to the timestamp in +;;; the local-state, changes have been made, and force-GContext-changes +;;; loops through the GContext and local-state, sending differences to +;;; the server, and updating GContext. +;;; +;;; WITH-GCONTEXT works by BINDING the local-state slot in a GContext to +;;; a private copy. This is easy (and fast) for lisp machines, but other +;;; lisps will have problems. Fortunately, most other lisps don't care, +;;; because they don't run in a multi-processing shared-address space +;;; environment. + +(in-package :xlib) + +(export '(force-gcontext-changes + with-gcontext + create-gcontext + copy-gcontext-components + copy-gcontext + free-gcontext + + gcontext-function + gcontext-plane-mask + gcontext-foreground + gcontext-background + gcontext-line-width + gcontext-line-style + gcontext-cap-style + gcontext-join-style + gcontext-fill-style + gcontext-fill-rule + gcontext-tile + gcontext-stipple + gcontext-ts-x + gcontext-ts-y + gcontext-font + gcontext-subwindow-mode + gcontext-exposures + gcontext-clip-x + gcontext-clip-y + gcontext-clip-mask + gcontext-dashes + gcontext-arc-mode + gcontext-dash-offset + gcontext-clip-ordering + + define-gcontext-accessor + )) + +;; GContext state accessors +;; The state vector contains all card32s to speed server updating + +(eval-when (eval compile load) + +(defconstant *gcontext-fast-change-length* #.(length *gcontext-components*)) + +(macrolet ((def-gc-internals (name &rest extras) + (let ((macros nil) + (indexes nil) + (masks nil) + (index 0)) + (dolist (name *gcontext-components*) + (push `(defmacro ,(xintern 'gcontext-internal- name) (state) + `(svref ,state ,,index)) + macros) + (setf (getf indexes name) index) + (push (ash 1 index) masks) + (incf index)) + (dolist (extra extras) + (push `(defmacro ,(xintern 'gcontext-internal- (first extra)) (state) + `(svref ,state ,,index)) + macros) + ;; don't override already correct index entries + (unless (or (getf indexes (second extra)) (getf indexes (first extra))) + (setf (getf indexes (or (second extra) (first extra))) index)) + (push (logior (ash 1 index) + (if (second extra) + (ash 1 (position (second extra) *gcontext-components*)) + 0)) + masks) + (incf index)) + `(within-definition (def-gc-internals ,name) + ,@(nreverse macros) + (eval-when (eval compile load) + (defconstant *gcontext-data-length* ,index) + (defconstant *gcontext-indexes* ',indexes) + (defconstant *gcontext-masks* + ',(coerce (nreverse masks) 'simple-vector))))))) + (def-gc-internals ignore + (:clip :clip-mask) (:dash :dashes) (:font-obj :font) (:timestamp))) + +) ;; end EVAL-WHEN + +(deftype gcmask () '(unsigned-byte #.*gcontext-fast-change-length*)) + +(deftype xgcmask () '(unsigned-byte #.*gcontext-data-length*)) + +(defstruct (gcontext-extension (:type vector) (:copier nil)) ;; un-named + (name nil :type symbol :read-only t) + (default nil :type t :read-only t) + (set-function #'identity :type (function (gcontext t) t) :read-only t) + (copy-function #'identity :type (function (gcontext gcontext t) t) :read-only t)) + +(defvar *gcontext-extensions* nil) ;; list of gcontext-extension + +;; Gcontext state Resource +(defvar *gcontext-local-state-cache* nil) ;; List of unused gcontext local states + +(defmacro gcontext-state-next (state) + `(svref ,state 0)) + +(defun allocate-gcontext-state () + ;; Allocate a gcontext-state + ;; Loop until a local state is found that's large enough to hold + ;; any extensions that may exist. + (let ((length (index+ *gcontext-data-length* (length *gcontext-extensions*)))) + (declare (type array-index length)) + (loop + (let ((state (or (threaded-atomic-pop *gcontext-local-state-cache* + gcontext-state-next gcontext-state) + (make-array length :initial-element nil)))) + (declare (type gcontext-state state)) + (when (index>= (length state) length) + (return state)))))) + +(defun deallocate-gcontext-state (state) + (declare (type gcontext-state state)) + (fill state nil) + (threaded-atomic-push state *gcontext-local-state-cache* + gcontext-state-next gcontext-state)) + +;; Temp-Gcontext Resource +(defvar *temp-gcontext-cache* nil) ;; List of unused gcontexts + +(defun allocate-temp-gcontext () + (or (threaded-atomic-pop *temp-gcontext-cache* gcontext-next gcontext) + (make-gcontext :local-state '#() :server-state '#()))) + +(defun deallocate-temp-gcontext (gc) + (declare (type gcontext gc)) + (threaded-atomic-push gc *temp-gcontext-cache* gcontext-next gcontext)) + +;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared +;; as (type <type> <name>), there is an accessor: + +;(defun gcontext-<name> (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) +; (values <type>))) + +;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared +;; as (type (or null <type>) <name>), there is a setf for the corresponding accessor: + +;(defsetf gcontext-<name> (gcontext) (value) +; ) + +;; Generate all the accessors and defsetf's for GContext + +(defmacro xgcmask->gcmask (mask) + `(the gcmask (logand ,mask #.(1- (ash 1 *gcontext-fast-change-length*))))) + +(defmacro access-gcontext ((gcontext local-state) &body body) + `(let ((,local-state (gcontext-local-state ,gcontext))) + (declare (type gcontext-state ,local-state)) + ,@body)) + +(defmacro modify-gcontext ((gcontext local-state) &body body) + ;; The timestamp must be altered after the modification + `(let ((,local-state (gcontext-local-state ,gcontext))) + (declare (type gcontext-state ,local-state)) + (prog1 + (progn ,@body) + (setf (gcontext-internal-timestamp ,local-state) 0)))) + +(defmacro def-gc-accessor (name type) + (let* ((gcontext-name (xintern 'gcontext- name)) + (internal-accessor (xintern 'gcontext-internal- name)) + (internal-setfer (xintern 'set- gcontext-name))) + `(within-definition (,name def-gc-accessor) + + (defun ,gcontext-name (gcontext) + (declare (type gcontext gcontext)) + (declare (values (or null ,type))) + (let ((value (,internal-accessor (gcontext-local-state gcontext)))) + (declare (type (or null card32) value)) + (when value ;; Don't do anything when value isn't known + (let ((%buffer (gcontext-display gcontext))) + (declare (type display %buffer)) + %buffer + (decode-type ,type value))))) + + (defun ,internal-setfer (gcontext value) + (declare (type gcontext gcontext) + (type ,type value)) + (modify-gcontext (gcontext local-state) + (setf (,internal-accessor local-state) (encode-type ,type value)) + ,@(when (eq type 'pixmap) + ;; write-through pixmaps, because the protocol allows + ;; the server to copy the pixmap contents at the time + ;; of the store, rather than continuing to share with + ;; the pixmap. + `((let ((server-state (gcontext-server-state gcontext))) + (setf (,internal-accessor server-state) nil)))) + value)) + + (defsetf ,gcontext-name ,internal-setfer)))) + +(defmacro incf-internal-timestamp (state) + (let ((ts (gensym))) + `(let ((,ts (the fixnum (gcontext-internal-timestamp ,state)))) + (declare (type fixnum ,ts)) + ;; the probability seems low enough + (setq ,ts (if (= ,ts most-positive-fixnum) + 1 + (the fixnum (1+ ,ts)))) + (setf (gcontext-internal-timestamp ,state) ,ts)))) + +(def-gc-accessor function boole-constant) +(def-gc-accessor plane-mask card32) +(def-gc-accessor foreground card32) +(def-gc-accessor background card32) +(def-gc-accessor line-width card16) +(def-gc-accessor line-style (member :solid :dash :double-dash)) +(def-gc-accessor cap-style (member :not-last :butt :round :projecting)) +(def-gc-accessor join-style (member :miter :round :bevel)) +(def-gc-accessor fill-style (member :solid :tiled :stippled :opaque-stippled)) +(def-gc-accessor fill-rule (member :even-odd :winding)) +(def-gc-accessor tile pixmap) +(def-gc-accessor stipple pixmap) +(def-gc-accessor ts-x int16) ;; Tile-Stipple-X-origin +(def-gc-accessor ts-y int16) ;; Tile-Stipple-Y-origin +;; (def-GC-accessor font font) ;; See below +(def-gc-accessor subwindow-mode (member :clip-by-children :include-inferiors)) +(def-gc-accessor exposures (member :off :on)) +(def-gc-accessor clip-x int16) +(def-gc-accessor clip-y int16) +;; (def-GC-accessor clip-mask) ;; see below +(def-gc-accessor dash-offset card16) +;; (def-GC-accessor dashes) ;; see below +(def-gc-accessor arc-mode (member :chord :pie-slice)) + + +(defun gcontext-clip-mask (gcontext) + (declare (type gcontext gcontext)) + (declare (values (or null (member :none) pixmap rect-seq) + (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)))) + (access-gcontext (gcontext local-state) + (multiple-value-bind (clip clip-mask) + (without-interrupts + (values (gcontext-internal-clip local-state) + (gcontext-internal-clip-mask local-state))) + (if (null clip) + (values (let ((%buffer (gcontext-display gcontext))) + (declare (type display %buffer)) + (decode-type (or (member :none) pixmap) clip-mask)) + nil) + (values (second clip) + (decode-type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) + (first clip))))))) + +(defsetf gcontext-clip-mask (gcontext &optional ordering) (clip-mask) + ;; A bit strange, but retains setf form. + ;; a nil clip-mask is transformed to an empty vector + `(set-gcontext-clip-mask ,gcontext ,ordering ,clip-mask)) + +(defun set-gcontext-clip-mask (gcontext ordering clip-mask) + ;; a nil clip-mask is transformed to an empty vector + (declare (type gcontext gcontext) + (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) ordering) + (type (or (member :none) pixmap rect-seq) clip-mask)) + (unless clip-mask (x-type-error clip-mask '(or (member :none) pixmap rect-seq))) + (multiple-value-bind (clip-mask clip) + (typecase clip-mask + (pixmap (values (pixmap-id clip-mask) nil)) + ((member :none) (values 0 nil)) + (sequence + (values nil + (list (encode-type + (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) + ordering) + (copy-seq clip-mask)))) + (otherwise (x-type-error clip-mask '(or (member :none) pixmap rect-seq)))) + (modify-gcontext (gcontext local-state) + (let ((server-state (gcontext-server-state gcontext))) + (declare (type gcontext-state server-state)) + (without-interrupts + (setf (gcontext-internal-clip local-state) clip + (gcontext-internal-clip-mask local-state) clip-mask) + (if (null clip) + (setf (gcontext-internal-clip server-state) nil) + (setf (gcontext-internal-clip-mask server-state) nil)) + (when (and clip-mask (not (zerop clip-mask))) + ;; write-through clip-mask pixmap, because the protocol allows the + ;; server to copy the pixmap contents at the time of the store, + ;; rather than continuing to share with the pixmap. + (setf (gcontext-internal-clip-mask server-state) nil)))))) + clip-mask) + +(defun gcontext-dashes (gcontext) + (declare (type gcontext gcontext)) + (declare (values (or null card8 sequence))) + (access-gcontext (gcontext local-state) + (multiple-value-bind (dash dashes) + (without-interrupts + (values (gcontext-internal-dash local-state) + (gcontext-internal-dashes local-state))) + (if (null dash) + dashes + dash)))) + +(defsetf gcontext-dashes set-gcontext-dashes) + +(defun set-gcontext-dashes (gcontext dashes) + (declare (type gcontext gcontext) + (type (or card8 sequence) dashes)) + (multiple-value-bind (dashes dash) + (if (type? dashes 'sequence) + (if (zerop (length dashes)) + (x-type-error dashes '(or card8 sequence) "non-empty sequence") + (values nil (or (copy-seq dashes) (vector)))) + (values (encode-type card8 dashes) nil)) + (modify-gcontext (gcontext local-state) + (let ((server-state (gcontext-server-state gcontext))) + (declare (type gcontext-state server-state)) + (without-interrupts + (setf (gcontext-internal-dash local-state) dash + (gcontext-internal-dashes local-state) dashes) + (if (null dash) + (setf (gcontext-internal-dash server-state) nil) + (setf (gcontext-internal-dashes server-state) nil)))))) + dashes) + +(defun gcontext-font (gcontext &optional metrics-p) + ;; If the stored font is known, it is returned. If it is not known and + ;; metrics-p is false, then nil is returned. If it is not known and + ;; metrics-p is true, then a pseudo font is returned. Full metric and + ;; property information can be obtained, but the font does not have a name or + ;; a resource-id, and attempts to use it where a resource-id is required will + ;; result in an invalid-font error. + (declare (type gcontext gcontext) + (type boolean metrics-p)) + (declare (values (or null font))) + (access-gcontext (gcontext local-state) + (let ((font (gcontext-internal-font-obj local-state))) + (or font + (when metrics-p + ;; XXX this isn't correct + (make-font :display (gcontext-display gcontext) + :id (gcontext-id gcontext) + :name nil)))))) + +(defsetf gcontext-font set-gcontext-font) + +(defun set-gcontext-font (gcontext font) + (declare (type gcontext gcontext) + (type fontable font)) + (let* ((font-object (if (font-p font) font (open-font (gcontext-display gcontext) font))) + (font (and font-object (font-id font-object)))) + ;; XXX need to check font has id (and name?) + (modify-gcontext (gcontext local-state) + (let ((server-state (gcontext-server-state gcontext))) + (declare (type gcontext-state server-state)) + (without-interrupts + (setf (gcontext-internal-font-obj local-state) font-object + (gcontext-internal-font local-state) font) + ;; check against font, not against font-obj + (if (null font) + (setf (gcontext-internal-font server-state) nil) + (setf (gcontext-internal-font-obj server-state) font-object)))))) + font) + +(defun force-gcontext-changes-internal (gcontext) + ;; Force any delayed changes. + (declare (type gcontext gcontext)) + #.(declare-buffun) + + (let ((display (gcontext-display gcontext)) + (server-state (gcontext-server-state gcontext)) + (local-state (gcontext-local-state gcontext))) + (declare (type display display) + (type gcontext-state server-state local-state)) + + ;; Update server when timestamps don't match + (unless (= (the fixnum (gcontext-internal-timestamp local-state)) + (the fixnum (gcontext-internal-timestamp server-state))) + + ;; The display is already locked. + (macrolet ((with-buffer ((buffer &key timeout) &body body) + `(progn (progn ,buffer ,@(and timeout `(,timeout)) nil) + ,@body))) + + ;; Because there is no locking on the local state we have to + ;; assume that state will change and set timestamps up front, + ;; otherwise by the time we figured out there were no changes + ;; and tried to store the server stamp as the local stamp, the + ;; local stamp might have since been modified. + (setf (gcontext-internal-timestamp local-state) + (incf-internal-timestamp server-state)) + + (block no-changes + (let ((last-request (buffer-last-request display))) + (with-buffer-request (display *x-changegc*) + (gcontext gcontext) + (progn + (do ((i 0 (index+ i 1)) + (bit 1 (the xgcmask (ash bit 1))) + (nbyte 12) + (mask 0) + (local 0)) + ((index>= i *gcontext-fast-change-length*) + (when (zerop mask) + ;; If nothing changed, restore last-request and quit + (setf (buffer-last-request display) + (if (zerop (buffer-last-request display)) + nil + last-request)) + (return-from no-changes nil)) + (card29-put 8 mask) + (card16-put 2 (index-ash nbyte -2)) + (index-incf (buffer-boffset display) nbyte)) + (declare (type array-index i nbyte) + (type xgcmask bit) + (type gcmask mask) + (type (or null card32) local)) + (unless (eql (the (or null card32) (svref server-state i)) + (setq local (the (or null card32) (svref local-state i)))) + (setf (svref server-state i) local) + (card32-put nbyte local) + (setq mask (the gcmask (logior mask bit))) + (index-incf nbyte 4))))))) + + ;; Update GContext extensions + (do ((extension *gcontext-extensions* (cdr extension)) + (i *gcontext-data-length* (index+ i 1)) + (local)) + ((endp extension)) + (unless (eql (svref server-state i) + (setq local (svref local-state i))) + (setf (svref server-state i) local) + (funcall (gcontext-extension-set-function (car extension)) gcontext local))) + + ;; Update clipping rectangles + (multiple-value-bind (local-clip server-clip) + (without-interrupts + (values (gcontext-internal-clip local-state) + (gcontext-internal-clip server-state))) + (unless (equalp local-clip server-clip) + (setf (gcontext-internal-clip server-state) nil) + (unless (null local-clip) + (with-buffer-request (display *x-setcliprectangles*) + (data (first local-clip)) + (gcontext gcontext) + ;; XXX treat nil correctly + (card16 (or (gcontext-internal-clip-x local-state) 0) + (or (gcontext-internal-clip-y local-state) 0)) + ;; XXX this has both int16 and card16 values + ((sequence :format int16) (second local-clip))) + (setf (gcontext-internal-clip server-state) local-clip)))) + + ;; Update dashes + (multiple-value-bind (local-dash server-dash) + (without-interrupts + (values (gcontext-internal-dash local-state) + (gcontext-internal-dash server-state))) + (unless (equalp local-dash server-dash) + (setf (gcontext-internal-dash server-state) nil) + (unless (null local-dash) + (with-buffer-request (display *x-setdashes*) + (gcontext gcontext) + ;; XXX treat nil correctly + (card16 (or (gcontext-internal-dash-offset local-state) 0) + (length local-dash)) + ((sequence :format card8) local-dash)) + (setf (gcontext-internal-dash server-state) local-dash)))))))) + +(defun force-gcontext-changes (gcontext) + ;; Force any delayed changes. + (declare (type gcontext gcontext)) + (let ((display (gcontext-display gcontext)) + (server-state (gcontext-server-state gcontext)) + (local-state (gcontext-local-state gcontext))) + (declare (type gcontext-state server-state local-state) + (array-register server-state local-state)) + ;; Update server when timestamps don't match + (unless (= (the fixnum (gcontext-internal-timestamp local-state)) + (the fixnum (gcontext-internal-timestamp server-state))) + (with-display (display) + (force-gcontext-changes-internal gcontext))))) + +;;; WARNING: WITH-GCONTEXT WORKS MUCH MORE EFFICIENTLY WHEN THE OPTIONS BEING "BOUND" ARE +;;; SET IN THE GCONTEXT ON ENTRY. BECAUSE THERE'S NO WAY TO GET THE VALUE OF AN +;;; UNKNOWN GC COMPONENT, WITH-GCONTEXT MUST CREATE A TEMPORARY GC, COPY THE UNKNOWN +;;; COMPONENTS TO THE TEMPORARY GC, ALTER THE GC BEING USED, THEN COPY COMPOMENTS +;;; BACK. + +(defmacro with-gcontext ((gcontext &rest options &key clip-ordering + &allow-other-keys) + &body body) + ;; "Binds" the gcontext components specified by options within the + ;; dynamic scope of the body (i.e., indefinite scope and dynamic + ;; extent), on a per-process basis in a multi-process environment. + ;; The body is not surrounded by a with-display. If cache-p is nil or + ;; the some component states are unknown, this will implement + ;; save/restore by creating a temporary gcontext and doing + ;; copy-gcontext-components to and from it. + + (declare (arglist (gcontext &rest options &key + function plane-mask foreground background + line-width line-style cap-style join-style + fill-style fill-rule arc-mode tile stipple ts-x + ts-y font subwindow-mode exposures clip-x clip-y + clip-mask clip-ordering dash-offset dashes + &allow-other-keys) + &body body)) + (remf options :clip-ordering) + + (let ((gc (gensym)) + (saved-state (gensym)) + (temp-gc (gensym)) + (temp-mask (gensym)) + (temp-vars nil) + (setfs nil) + (indexes nil) ; List of gcontext field indices + (extension-indexes nil) ; List of gcontext extension field indices + (ts-index (getf *gcontext-indexes* :timestamp))) + + (do* ((option options (cddr option)) + (name (car option) (car option)) + (value (cadr option) (cadr option))) + ((endp option) (setq setfs (nreverse setfs))) + (let ((index (getf *gcontext-indexes* name))) + (if index + (push index indexes) + (let ((extension (find name *gcontext-extensions* + :key #'gcontext-extension-name))) + (if extension + (progn + (push (xintern "Internal-" 'gcontext- name "-State-Index") + extension-indexes)) + (x-type-error name 'gcontext-key))))) + (let ((accessor `(,(xintern 'gcontext- name) ,gc + ,@(when (eq name :clip-mask) `(,clip-ordering)))) + (temp-var (gensym))) + (when value + (push `(,temp-var ,value) temp-vars) + (push `(setf ,accessor ,temp-var) setfs)))) + (if setfs + `(multiple-value-bind (,gc ,saved-state ,temp-mask ,temp-gc) + (copy-gcontext-local-state ,gcontext ',indexes ,@extension-indexes) + (declare (type gcontext ,gc) + (type gcontext-state ,saved-state) + (type xgcmask ,temp-mask) + (type (or null resource-id) ,temp-gc)) + (with-gcontext-bindings (,gc ,saved-state + ,(append indexes extension-indexes) + ,ts-index ,temp-mask ,temp-gc) + (let ,temp-vars + ,@setfs) + ,@body)) + `(progn ,@body)))) + +(defun copy-gcontext-local-state (gcontext indexes &rest extension-indices) + ;; Called from WITH-GCONTEXT to save the fields in GCONTEXT indicated by MASK + (declare (type gcontext gcontext) + (type list indexes) + (dynamic-extent extension-indices)) + (let ((local-state (gcontext-local-state gcontext)) + (saved-state (allocate-gcontext-state)) + (cache-p (gcontext-cache-p gcontext))) + (declare (type gcontext-state local-state saved-state)) + (setf (gcontext-internal-timestamp saved-state) 1) + (let ((temp-gc nil) + (temp-mask 0) + (extension-mask 0)) + (declare (type xgcmask temp-mask) + (type integer extension-mask)) + (dolist (i indexes) + (when (or (not (setf (svref saved-state i) (svref local-state i))) + (not cache-p)) + (setq temp-mask + (the xgcmask (logior temp-mask + (the xgcmask (svref *gcontext-masks* i))))))) + (dolist (i extension-indices) + (when (or (not (setf (svref saved-state i) (svref local-state i))) + (not cache-p)) + (setq extension-mask + (the xgcmask (logior extension-mask (ash 1 i)))))) + (when (or (plusp temp-mask) + (plusp extension-mask)) + ;; Copy to temporary GC when field unknown or cache-p false + (let ((display (gcontext-display gcontext))) + (declare (type display display)) + (with-display (display) + (setq temp-gc (allocate-temp-gcontext)) + (setf (gcontext-id temp-gc) (allocate-resource-id display gcontext 'gcontext) + (gcontext-display temp-gc) display + (gcontext-drawable temp-gc) (gcontext-drawable gcontext) + (gcontext-server-state temp-gc) saved-state + (gcontext-local-state temp-gc) saved-state) + ;; Create a new (temporary) gcontext + (with-buffer-request (display *x-creategc*) + (gcontext temp-gc) + (drawable (gcontext-drawable gcontext)) + (card29 0)) + ;; Copy changed components to the temporary gcontext + (when (plusp temp-mask) + (with-buffer-request (display *x-copygc*) + (gcontext gcontext) + (gcontext temp-gc) + (card29 (xgcmask->gcmask temp-mask)))) + ;; Copy extension fields to the new gcontext + (when (plusp extension-mask) + ;; Copy extension fields from temp back to gcontext + (do ((bit (ash extension-mask (- *gcontext-data-length*)) (ash bit -1)) + (i 0 (index+ i 1))) + ((zerop bit)) + (let ((copy-function (gcontext-extension-copy-function + (elt *gcontext-extensions* i)))) + (funcall copy-function gcontext temp-gc + (svref local-state (index+ i *gcontext-data-length*)))))) + ))) + (values gcontext saved-state (logior temp-mask extension-mask) temp-gc)))) + +(defun restore-gcontext-temp-state (gcontext temp-mask temp-gc) + (declare (type gcontext gcontext temp-gc) + (type xgcmask temp-mask)) + (let ((display (gcontext-display gcontext))) + (declare (type display display)) + (with-display (display) + (with-buffer-request (display *x-copygc*) + (gcontext temp-gc) + (gcontext gcontext) + (card29 (xgcmask->gcmask temp-mask))) + ;; Copy extension fields from temp back to gcontext + (do ((bit (ash temp-mask (- *gcontext-data-length*)) (ash bit -1)) + (extensions *gcontext-extensions* (cdr extensions)) + (i *gcontext-data-length* (index+ i 1)) + (local-state (gcontext-local-state temp-gc))) + ((zerop bit)) + (let ((copy-function (gcontext-extension-copy-function (car extensions)))) + (funcall copy-function temp-gc gcontext (svref local-state i)))) + ;; free gcontext + (with-buffer-request (display *x-freegc*) + (gcontext temp-gc)) + (deallocate-resource-id display (gcontext-id temp-gc) 'gcontext) + (deallocate-temp-gcontext temp-gc) + ;; Copy saved state back to server state + (do ((server-state (gcontext-server-state gcontext)) + (bit (xgcmask->gcmask temp-mask) (the gcmask (ash bit -1))) + (i 0 (index+ i 1))) + ((zerop bit) + (incf-internal-timestamp server-state)) + (declare (type gcontext-state server-state) + (type gcmask bit) + (type array-index i)) + (when (oddp bit) + (setf (svref server-state i) nil)))))) + +(defun create-gcontext (&rest options &key (drawable (required-arg drawable)) + function plane-mask foreground background + line-width line-style cap-style join-style fill-style fill-rule + arc-mode tile stipple ts-x ts-y font subwindow-mode + exposures clip-x clip-y clip-mask clip-ordering + dash-offset dashes + (cache-p t) + &allow-other-keys) + ;; Only non-nil components are passed on in the request, but for effective caching + ;; assumptions have to be made about what the actual protocol defaults are. For + ;; all gcontext components, a value of nil causes the default gcontext value to be + ;; used. For clip-mask, this implies that an empty rect-seq cannot be represented + ;; as a list. Note: use of stringable as font will cause an implicit open-font. + ;; Note: papers over protocol SetClipRectangles and SetDashes special cases. If + ;; cache-p is true, then gcontext state is cached locally, and changing a gcontext + ;; component will have no effect unless the new value differs from the cached + ;; value. Component changes (setfs and with-gcontext) are always deferred + ;; regardless of the cache mode, and sent over the protocol only when required by a + ;; local operation or by an explicit call to force-gcontext-changes. + (declare (type drawable drawable) ; Required to be non-null + (type (or null boole-constant) function) + (type (or null pixel) plane-mask foreground background) + (type (or null card16) line-width dash-offset) + (type (or null int16) ts-x ts-y clip-x clip-y) + (type (or null (member :solid :dash :double-dash)) line-style) + (type (or null (member :not-last :butt :round :projecting)) cap-style) + (type (or null (member :miter :round :bevel)) join-style) + (type (or null (member :solid :tiled :opaque-stippled :stippled)) fill-style) + (type (or null (member :even-odd :winding)) fill-rule) + (type (or null (member :chord :pie-slice)) arc-mode) + (type (or null pixmap) tile stipple) + (type (or null fontable) font) + (type (or null (member :clip-by-children :include-inferiors)) subwindow-mode) + (type (or null (member :on :off)) exposures) + (type (or null (member :none) pixmap rect-seq) clip-mask) + (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering) + (type (or null card8 sequence) dashes) + (dynamic-extent options) + (type boolean cache-p)) + (declare (values gcontext)) + (let* ((display (drawable-display drawable)) + (gcontext (make-gcontext :display display :drawable drawable :cache-p cache-p)) + (local-state (gcontext-local-state gcontext)) + (server-state (gcontext-server-state gcontext)) + (gcontextid (allocate-resource-id display gcontext 'gcontext))) + (declare (type display display) + (type gcontext gcontext) + (type resource-id gcontextid) + (type gcontext-state local-state server-state)) + (setf (gcontext-id gcontext) gcontextid) + + (unless function (setf (gcontext-function gcontext) boole-1)) + ;; using the depth of the drawable would be better, but ... + (unless plane-mask (setf (gcontext-plane-mask gcontext) #xffffffff)) + (unless foreground (setf (gcontext-foreground gcontext) 0)) + (unless background (setf (gcontext-background gcontext) 1)) + (unless line-width (setf (gcontext-line-width gcontext) 0)) + (unless line-style (setf (gcontext-line-style gcontext) :solid)) + (unless cap-style (setf (gcontext-cap-style gcontext) :butt)) + (unless join-style (setf (gcontext-join-style gcontext) :miter)) + (unless fill-style (setf (gcontext-fill-style gcontext) :solid)) + (unless fill-rule (setf (gcontext-fill-rule gcontext) :even-odd)) + (unless arc-mode (setf (gcontext-arc-mode gcontext) :pie-slice)) + (unless ts-x (setf (gcontext-ts-x gcontext) 0)) + (unless ts-y (setf (gcontext-ts-y gcontext) 0)) + (unless subwindow-mode (setf (gcontext-subwindow-mode gcontext) + :clip-by-children)) + (unless exposures (setf (gcontext-exposures gcontext) :on)) + (unless clip-mask (setf (gcontext-clip-mask gcontext) :none)) + (unless clip-x (setf (gcontext-clip-x gcontext) 0)) + (unless clip-y (setf (gcontext-clip-y gcontext) 0)) + (unless dashes (setf (gcontext-dashes gcontext) 4)) + (unless dash-offset (setf (gcontext-dash-offset gcontext) 0)) + ;; a bit kludgy, but ... + (replace server-state local-state) + + (when function (setf (gcontext-function gcontext) function)) + (when plane-mask (setf (gcontext-plane-mask gcontext) plane-mask)) + (when foreground (setf (gcontext-foreground gcontext) foreground)) + (when background (setf (gcontext-background gcontext) background)) + (when line-width (setf (gcontext-line-width gcontext) line-width)) + (when line-style (setf (gcontext-line-style gcontext) line-style)) + (when cap-style (setf (gcontext-cap-style gcontext) cap-style)) + (when join-style (setf (gcontext-join-style gcontext) join-style)) + (when fill-style (setf (gcontext-fill-style gcontext) fill-style)) + (when fill-rule (setf (gcontext-fill-rule gcontext) fill-rule)) + (when arc-mode (setf (gcontext-arc-mode gcontext) arc-mode)) + (when tile (setf (gcontext-tile gcontext) tile)) + (when stipple (setf (gcontext-stipple gcontext) stipple)) + (when ts-x (setf (gcontext-ts-x gcontext) ts-x)) + (when ts-y (setf (gcontext-ts-y gcontext) ts-y)) + (when font (setf (gcontext-font gcontext) font)) + (when subwindow-mode (setf (gcontext-subwindow-mode gcontext) subwindow-mode)) + (when exposures (setf (gcontext-exposures gcontext) exposures)) + (when clip-x (setf (gcontext-clip-x gcontext) clip-x)) + (when clip-y (setf (gcontext-clip-y gcontext) clip-y)) + (when clip-mask (setf (gcontext-clip-mask gcontext clip-ordering) clip-mask)) + (when dash-offset (setf (gcontext-dash-offset gcontext) dash-offset)) + (when dashes (setf (gcontext-dashes gcontext) dashes)) + + (setf (gcontext-internal-timestamp server-state) 1) + (setf (gcontext-internal-timestamp local-state) 1) + + (with-buffer-request (display *x-creategc*) + (resource-id gcontextid) + (drawable drawable) + (progn (do* ((i 0 (index+ i 1)) + (bit 1 (the xgcmask (ash bit 1))) + (nbyte 16) + (mask 0) + (local (svref local-state i) (svref local-state i))) + ((index>= i *gcontext-fast-change-length*) + (card29-put 12 mask) + (card16-put 2 (index-ash nbyte -2)) + (index-incf (buffer-boffset display) nbyte)) + (declare (type array-index i nbyte) + (type xgcmask bit) + (type gcmask mask) + (type (or null card32) local)) + (unless (eql local (the (or null card32) (svref server-state i))) + (setf (svref server-state i) local) + (card32-put nbyte local) + (setq mask (the gcmask (logior mask bit))) + (index-incf nbyte 4))))) + + ;; Initialize extensions + (do ((extensions *gcontext-extensions* (cdr extensions)) + (i *gcontext-data-length* (index+ i 1))) + ((endp extensions)) + (declare (type list extensions) + (type array-index i)) + (setf (svref server-state i) + (setf (svref local-state i) + (gcontext-extension-default (car extensions))))) + + ;; Set extension values + (do* ((option-list options (cddr option-list)) + (option (car option-list) (car option-list)) + (extension)) + ((endp option-list)) + (declare (type list option-list)) + (cond ((getf *gcontext-indexes* option)) ; Gcontext field + ((member option '(:drawable :clip-ordering :cache-p))) ; Optional parameter + ((setq extension (find option *gcontext-extensions* + :key #'gcontext-extension-name)) + (funcall (gcontext-extension-set-function extension) + gcontext (second option-list))) + (t (x-type-error option 'gcontext-key)))) + gcontext)) + +(defun copy-gcontext-components (src dst &rest keys) + (declare (type gcontext src dst) + (dynamic-extent keys)) + ;; you might ask why this isn't just a bunch of + ;; (setf (gcontext-<mumble> dst) (gcontext-<mumble> src)) + ;; the answer is that you can do that yourself if you want, what we are + ;; providing here is access to the protocol request, which will generally + ;; be more efficient (particularly for things like clip and dash lists). + (when keys + (let ((display (gcontext-display src)) + (mask 0)) + (declare (type xgcmask mask)) + (with-display (display) + (force-gcontext-changes-internal src) + (force-gcontext-changes-internal dst) + + ;; collect entire mask and handle extensions + (dolist (key keys) + (let ((i (getf *gcontext-indexes* key))) + (declare (type (or null array-index) i)) + (if i + (setq mask (the xgcmask (logior mask + (the xgcmask (svref *gcontext-masks* i))))) + (multiple-value-bind (extension index) + (find key *gcontext-extensions* :key #'gcontext-extension-name) + (if extension + (funcall (gcontext-extension-copy-function extension) + src dst (svref (gcontext-local-state src) + (index+ index *gcontext-data-length*))) + (x-type-error key 'gcontext-key)))))) + + (when (plusp mask) + (do ((src-server-state (gcontext-server-state src)) + (dst-server-state (gcontext-server-state dst)) + (dst-local-state (gcontext-local-state dst)) + (bit mask (the xgcmask (ash bit -1))) + (i 0 (index+ i 1))) + ((zerop bit) + (incf-internal-timestamp dst-server-state) + (setf (gcontext-internal-timestamp dst-local-state) 0)) + (declare (type gcontext-state src-server-state dst-server-state dst-local-state) + (type xgcmask bit) + (type array-index i)) + (when (oddp bit) + (setf (svref dst-local-state i) + (setf (svref dst-server-state i) (svref src-server-state i))))) + (with-buffer-request (display *x-copygc*) + (gcontext src dst) + (card29 (xgcmask->gcmask mask)))))))) + +(defun copy-gcontext (src dst) + (declare (type gcontext src dst)) + ;; Copies all components. + (apply #'copy-gcontext-components src dst *gcontext-components*) + (do ((extensions *gcontext-extensions* (cdr extensions)) + (i *gcontext-data-length* (index+ i 1))) + ((endp extensions)) + (funcall (gcontext-extension-copy-function (car extensions)) + src dst (svref (gcontext-local-state src) i)))) + +(defun free-gcontext (gcontext) + (declare (type gcontext gcontext)) + (let ((display (gcontext-display gcontext))) + (with-buffer-request (display *x-freegc*) + (gcontext gcontext)) + (deallocate-resource-id display (gcontext-id gcontext) 'gcontext) + (deallocate-gcontext-state (gcontext-server-state gcontext)) + (deallocate-gcontext-state (gcontext-local-state gcontext)) + nil)) + +(defmacro define-gcontext-accessor (name &key default set-function copy-function) + ;; This will define a new gcontext accessor called NAME. + ;; Defines the gcontext-NAME accessor function and its defsetf. + ;; Gcontext's will cache DEFAULT-VALUE and the last value SETF'ed when + ;; gcontext-cache-p is true. The NAME keyword will be allowed in + ;; CREATE-GCONTEXT, WITH-GCONTEXT, and COPY-GCONTEXT-COMPONENTS. + ;; SET-FUNCTION will be called with parameters (GCONTEXT NEW-VALUE) + ;; from create-gcontext, and force-gcontext-changes. + ;; COPY-FUNCTION will be called with parameters (src-gc dst-gc src-value) + ;; from copy-gcontext and copy-gcontext-components. + ;; The copy-function defaults to: + ;; (lambda (ignore dst-gc value) + ;; (if value + ;; (,set-function dst-gc value) + ;; (error "Can't copy unknown GContext component ~a" ',name))) + (declare (type symbol name) + (type t default) + (type (function (gcontext t) t) set-function) ;; required + (type (or null (function (gcontext gcontext t) t)) + copy-function)) + (let* ((gc-name (intern (concatenate 'string + (string 'gcontext-) + (string name)))) ;; in current package + (key-name (kintern name)) + (setfer (xintern "Set-" gc-name)) + (internal-set-function (xintern "Internal-Set-" gc-name)) + (internal-copy-function (xintern "Internal-Copy-" gc-name)) + (internal-state-index (xintern "Internal-" gc-name "-State-Index"))) + (unless copy-function + (setq copy-function + `(lambda (src-gc dst-gc value) + (declare (ignore src-gc)) + (if value + (,set-function dst-gc value) + (error "Can't copy unknown GContext component ~a" ',name))))) + `(progn + (eval-when (compile load eval) + (defparameter ,internal-state-index + (add-gcontext-extension ',key-name ,default ',internal-set-function + ',internal-copy-function)) + ) ;; end eval-when + (defun ,gc-name (gcontext) + (svref (gcontext-local-state gcontext) ,internal-state-index)) + (defun ,setfer (gcontext new-value) + (let ((local-state (gcontext-local-state gcontext))) + (setf (gcontext-internal-timestamp local-state) 0) + (setf (svref local-state ,internal-state-index) new-value))) + (defsetf ,gc-name ,setfer) + (defun ,internal-set-function (gcontext new-value) + (,set-function gcontext new-value) + (setf (svref (gcontext-server-state gcontext) ,internal-state-index) + (setf (svref (gcontext-local-state gcontext) ,internal-state-index) + new-value))) + (defun ,internal-copy-function (src-gc dst-gc new-value) + (,copy-function src-gc dst-gc new-value) + (setf (svref (gcontext-local-state dst-gc) ,internal-state-index) + (setf (svref (gcontext-server-state dst-gc) ,internal-state-index) + new-value))) + ',name))) + +;; GContext extension fields are treated in much the same way as normal GContext +;; components. The current value is stored in a slot of the gcontext-local-state, +;; and the value known to the server is in a slot of the gcontext-server-state. +;; The slot-number is defined by its position in the *gcontext-extensions* list. +;; The value of the special variable |Internal-GCONTEXT-name| (where "name" is +;; the extension component name) reflects this position. The position within +;; *gcontext-extensions* and the value of the special value are determined at +;; LOAD time to facilitate merging of seperately compiled extension files. + +(defun add-gcontext-extension (name default-value set-function copy-function) + (declare (type symbol name) + (type t default-value) + (type (function (gcontext t) t) set-function) + (type (function (gcontext gcontext t) t) copy-function)) + (let ((number (or (position name *gcontext-extensions* :key #'gcontext-extension-name) + (prog1 (length *gcontext-extensions*) + (push nil *gcontext-extensions*))))) + (setf (nth number *gcontext-extensions*) + (make-gcontext-extension :name name + :default default-value + :set-function set-function + :copy-function copy-function)) + (+ number *gcontext-data-length*))) diff --git a/clx/generalock.lisp b/clx/generalock.lisp new file mode 100644 index 000000000..0319ab599 --- /dev/null +++ b/clx/generalock.lisp @@ -0,0 +1,62 @@ +;;; -*- Mode: LISP; Syntax: Common-lisp; Package: PROCESS; Base: 10; Lowercase: Yes -*- + +(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/clx/graphics.lisp b/clx/graphics.lisp new file mode 100644 index 000000000..2f560888b --- /dev/null +++ b/clx/graphics.lisp @@ -0,0 +1,460 @@ +;;; -*- 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) + +(export '( + draw-point + draw-points + draw-line + draw-lines + draw-segments + draw-rectangle + draw-rectangles + draw-arc + draw-arcs + put-raw-image + get-raw-image)) + +(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 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 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 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 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 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 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 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 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 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 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 (values (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/clx/image.lisp b/clx/image.lisp new file mode 100644 index 000000000..152af53f8 --- /dev/null +++ b/clx/image.lisp @@ -0,0 +1,2697 @@ +;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- + +;;; CLX Image functions + +;;; +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 +;;; +;;; Copyright (C) 1987 Texas Instruments Incorporated. +;;; +;;; Permission is granted to any individual or institution to use, copy, modify, +;;; and distribute this software, provided that this complete copyright and +;;; permission notice is maintained, intact, in all copies and supporting +;;; documentation. +;;; +;;; Texas Instruments Incorporated provides this software "as is" without +;;; express or implied warranty. +;;; + +(in-package :xlib) + +(export '(bitmap + pixarray + image + image-width + image-height + image-depth + image-plist + image-name + image-x-hot + image-y-hot + image-red-mask + image-blue-mask + image-green-mask + image-x + image-xy + image-z + image-x-p + image-xy-p + image-z-p + image-xy-bitmap-list + image-z-bits-per-pixel + image-z-pixarray + create-image + get-image + put-image + copy-image + read-bitmap-file + write-bitmap-file + bitmap-image + image-pixmap)) + +(def-clx-class (image (:constructor nil) (:copier nil) (:predicate nil)) + ;; Public structure + (width 0 :type card16 :read-only t) + (height 0 :type card16 :read-only t) + (depth 1 :type card8 :read-only t) + (plist nil :type list)) + +;; Image-Plist accessors: +(defmacro image-name (image) `(getf (image-plist ,image) :name)) +(defmacro image-x-hot (image) `(getf (image-plist ,image) :x-hot)) +(defmacro image-y-hot (image) `(getf (image-plist ,image) :y-hot)) +(defmacro image-red-mask (image) `(getf (image-plist ,image) :red-mask)) +(defmacro image-blue-mask (image) `(getf (image-plist ,image) :blue-mask)) +(defmacro image-green-mask (image) `(getf (image-plist ,image) :green-mask)) + +(defun print-image (image stream depth) + (declare (type image image) + (ignore depth)) + (print-unreadable-object (image stream :type t) + (when (image-name image) + (princ (image-name image) stream) + (princ " " stream)) + (prin1 (image-width image) stream) + (princ "x" stream) + (prin1 (image-height image) stream) + (princ "x" stream) + (prin1 (image-depth image) stream))) + +(defconstant *empty-data-x* #.(make-sequence '(array card8 (*)) 0)) + +(defconstant *empty-data-z* + #.(make-array '(0 0) :element-type 'pixarray-1-element-type)) + +(def-clx-class (image-x (:include image) (:copier nil) + (:print-function print-image)) + ;; Use this format for shoveling image data + ;; Private structure. Accessors for these NOT exported. + (format :z-pixmap :type (member :bitmap :xy-pixmap :z-pixmap)) + (bytes-per-line 0 :type card16) + (bits-per-pixel 1 :type (member 1 4 8 16 24 32)) + (bit-lsb-first-p *image-bit-lsb-first-p* :type boolean) ; Bit order + (byte-lsb-first-p *image-byte-lsb-first-p* :type boolean) ; Byte order + (data *empty-data-x* :type (array card8 (*))) ; row-major + (unit *image-unit* :type (member 8 16 32)) ; Bitmap unit + (pad *image-pad* :type (member 8 16 32)) ; Scanline pad + (left-pad 0 :type card8)) ; Left pad + +(def-clx-class (image-xy (:include image) (:copier nil) + (:print-function print-image)) + ;; Public structure + ;; Use this format for image processing + (bitmap-list nil :type list)) ;; list of bitmaps + +(def-clx-class (image-z (:include image) (:copier nil) + (:print-function print-image)) + ;; Public structure + ;; Use this format for image processing + (bits-per-pixel 1 :type (member 1 4 8 16 24 32)) + (pixarray *empty-data-z* :type pixarray)) + +(defun create-image (&key width height depth + (data (required-arg data)) + plist name x-hot y-hot + red-mask blue-mask green-mask + bits-per-pixel format bytes-per-line + (byte-lsb-first-p *image-byte-lsb-first-p*) + (bit-lsb-first-p *image-bit-lsb-first-p*) + unit pad left-pad) + ;; Returns an image-x image-xy or image-z structure, depending on the + ;; type of the :DATA parameter. + (declare + (type (or null card16) width height) ; Required + (type (or null card8) depth) ; Defualts to 1 + (type (or buffer-bytes ; Returns image-x + list ; Returns image-xy + pixarray) data) ; Returns image-z + (type list plist) + (type (or null stringable) name) + (type (or null card16) x-hot y-hot) + (type (or null pixel) red-mask blue-mask green-mask) + (type (or null (member 1 4 8 16 24 32)) bits-per-pixel) + + ;; The following parameters are ignored for image-xy and image-z: + (type (or null (member :bitmap :xy-pixmap :z-pixmap)) + format) ; defaults to :z-pixmap + (type (or null card16) bytes-per-line) + (type boolean byte-lsb-first-p bit-lsb-first-p) + (type (or null (member 8 16 32)) unit pad) + (type (or null card8) left-pad)) + (declare (values image)) + (let ((image + (etypecase data + (buffer-bytes ; image-x + (let ((data data)) + (declare (type buffer-bytes data)) + (unless depth (setq depth (or bits-per-pixel 1))) + (unless format + (setq format (if (= depth 1) :xy-pixmap :z-pixmap))) + (unless bits-per-pixel + (setq bits-per-pixel + (cond ((eq format :xy-pixmap) 1) + ((index> depth 24) 32) + ((index> depth 16) 24) + ((index> depth 8) 16) + ((index> depth 4) 8) + ((index> depth 1) 4) + (t 1)))) + (unless width (required-arg width)) + (unless height (required-arg height)) + (unless bytes-per-line + (let* ((pad (or pad 8)) + (bits-per-line (index* width bits-per-pixel)) + (padded-bits-per-line + (index* (index-ceiling bits-per-line pad) pad))) + (declare (type array-index pad bits-per-line + padded-bits-per-line)) + (setq bytes-per-line (index-ceiling padded-bits-per-line 8)))) + (unless unit (setq unit *image-unit*)) + (unless pad + (setq pad + (dolist (pad '(32 16 8)) + (when (and (index<= pad *image-pad*) + (zerop + (index-mod + (index* bytes-per-line 8) pad))) + (return pad))))) + (unless left-pad (setq left-pad 0)) + (make-image-x + :width width :height height :depth depth :plist plist + :format format :data data + :bits-per-pixel bits-per-pixel + :bytes-per-line bytes-per-line + :byte-lsb-first-p byte-lsb-first-p + :bit-lsb-first-p bit-lsb-first-p + :unit unit :pad pad :left-pad left-pad))) + (list ; image-xy + (let ((data data)) + (declare (type list data)) + (unless depth (setq depth (length data))) + (when data + (unless width (setq width (array-dimension (car data) 1))) + (unless height (setq height (array-dimension (car data) 0)))) + (make-image-xy + :width width :height height :plist plist :depth depth + :bitmap-list data))) + (pixarray ; image-z + (let ((data data)) + (declare (type pixarray data)) + (unless width (setq width (array-dimension data 1))) + (unless height (setq height (array-dimension data 0))) + (unless bits-per-pixel + (setq bits-per-pixel + (etypecase data + (pixarray-32 32) + (pixarray-24 24) + (pixarray-16 16) + (pixarray-8 8) + (pixarray-4 4) + (pixarray-1 1))))) + (unless depth (setq depth bits-per-pixel)) + (make-image-z + :width width :height height :depth depth :plist plist + :bits-per-pixel bits-per-pixel :pixarray data))))) + (declare (type image image)) + (when name (setf (image-name image) name)) + (when x-hot (setf (image-x-hot image) x-hot)) + (when y-hot (setf (image-y-hot image) y-hot)) + (when red-mask (setf (image-red-mask image) red-mask)) + (when blue-mask (setf (image-blue-mask image) blue-mask)) + (when green-mask (setf (image-green-mask image) green-mask)) + image)) + +;;;----------------------------------------------------------------------------- +;;; Swapping stuff + +(defun image-noswap + (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type boolean lsb-first-p) + (ignore lsb-first-p)) + #.(declare-buffun) + (if (index= srcinc destinc) + (buffer-replace + dest src destoff + (index+ destoff (index* srcinc (index1- height)) srclen) + srcoff) + (do* ((h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc)) + (destend (index+ deststart srclen) (index+ deststart srclen))) + ((index-zerop h)) + (declare (type array-index srcstart deststart destend) + (type card16 h)) + (buffer-replace dest src deststart destend srcstart)))) + +(defun image-swap-two-bytes + (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type boolean lsb-first-p)) + #.(declare-buffun) + (with-vector (src buffer-bytes) + (with-vector (dest buffer-bytes) + (do ((length (index* (index-ceiling srclen 2) 2)) + (h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index length srcstart deststart) + (type card16 h)) + (when (and (index= h 1) (not (index= srclen length))) + (index-decf length 2) + (if lsb-first-p + (setf (aref dest (index1+ (index+ deststart length))) + (the card8 (aref src (index+ srcstart length)))) + (setf (aref dest (index+ deststart length)) + (the card8 (aref src (index1+ (index+ srcstart length))))))) + (do ((i length (index- i 2)) + (srcidx srcstart (index+ srcidx 2)) + (destidx deststart (index+ destidx 2))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (the card8 (aref src (index1+ srcidx)))) + (setf (aref dest (index1+ destidx)) + (the card8 (aref src srcidx)))))))) + +(defun image-swap-three-bytes + (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type boolean lsb-first-p)) + #.(declare-buffun) + (with-vector (src buffer-bytes) + (with-vector (dest buffer-bytes) + (do ((length (index* (index-ceiling srclen 3) 3)) + (h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index length srcstart deststart) + (type card16 h)) + (when (and (index= h 1) (not (index= srclen length))) + (index-decf length 3) + (when (index= (index- srclen length) 2) + (setf (aref dest (index+ deststart length 1)) + (the card8 (aref src (index+ srcstart length 1))))) + (if lsb-first-p + (setf (aref dest (index+ deststart length 2)) + (the card8 (aref src (index+ srcstart length)))) + (setf (aref dest (index+ deststart length)) + (the card8 (aref src (index+ srcstart length 2)))))) + (do ((i length (index- i 3)) + (srcidx srcstart (index+ srcidx 3)) + (destidx deststart (index+ destidx 3))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (the card8 (aref src (index+ srcidx 2)))) + (setf (aref dest (index1+ destidx)) + (the card8 (aref src (index1+ srcidx)))) + (setf (aref dest (index+ destidx 2)) + (the card8 (aref src srcidx)))))))) + +(defun image-swap-four-bytes + (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type boolean lsb-first-p)) + #.(declare-buffun) + (with-vector (src buffer-bytes) + (with-vector (dest buffer-bytes) + (do ((length (index* (index-ceiling srclen 4) 4)) + (h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index length srcstart deststart) + (type card16 h)) + (when (and (index= h 1) (not (index= srclen length))) + (index-decf length 4) + (unless lsb-first-p + (setf (aref dest (index+ deststart length)) + (the card8 (aref src (index+ srcstart length 3))))) + (when (if lsb-first-p + (index= (index- srclen length) 3) + (not (index-zerop (index-logand srclen 2)))) + (setf (aref dest (index+ deststart length 1)) + (the card8 (aref src (index+ srcstart length 2))))) + (when (if (null lsb-first-p) + (index= (index- srclen length) 3) + (not (index-zerop (index-logand srclen 2)))) + (setf (aref dest (index+ deststart length 2)) + (the card8 (aref src (index+ srcstart length 1))))) + (when lsb-first-p + (setf (aref dest (index+ deststart length 3)) + (the card8 (aref src (index+ srcstart length)))))) + (do ((i length (index- i 4)) + (srcidx srcstart (index+ srcidx 4)) + (destidx deststart (index+ destidx 4))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (the card8 (aref src (index+ srcidx 3)))) + (setf (aref dest (index1+ destidx)) + (the card8 (aref src (index+ srcidx 2)))) + (setf (aref dest (index+ destidx 2)) + (the card8 (aref src (index1+ srcidx)))) + (setf (aref dest (index+ destidx 3)) + (the card8 (aref src srcidx)))))))) + +(defun image-swap-words + (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type boolean lsb-first-p)) + #.(declare-buffun) + (with-vector (src buffer-bytes) + (with-vector (dest buffer-bytes) + (do ((length (index* (index-ceiling srclen 4) 4)) + (h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index length srcstart deststart) + (type card16 h)) + (when (and (index= h 1) (not (index= srclen length))) + (index-decf length 4) + (unless lsb-first-p + (setf (aref dest (index+ deststart length 1)) + (the card8 (aref src (index+ srcstart length 3))))) + (when (if lsb-first-p + (index= (index- srclen length) 3) + (not (index-zerop (index-logand srclen 2)))) + (setf (aref dest (index+ deststart length)) + (the card8 (aref src (index+ srcstart length 2))))) + (when (if (null lsb-first-p) + (index= (index- srclen length) 3) + (not (index-zerop (index-logand srclen 2)))) + (setf (aref dest (index+ deststart length 3)) + (the card8 (aref src (index+ srcstart length 1))))) + (when lsb-first-p + (setf (aref dest (index+ deststart length 2)) + (the card8 (aref src (index+ srcstart length)))))) + (do ((i length (index- i 4)) + (srcidx srcstart (index+ srcidx 4)) + (destidx deststart (index+ destidx 4))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (the card8 (aref src (index+ srcidx 2)))) + (setf (aref dest (index1+ destidx)) + (the card8 (aref src (index+ srcidx 3)))) + (setf (aref dest (index+ destidx 2)) + (the card8 (aref src srcidx))) + (setf (aref dest (index+ destidx 3)) + (the card8 (aref src (index1+ srcidx))))))))) + +(defun image-swap-nibbles + (src dest srcoff destoff srclen srcinc destinc height) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height)) + #.(declare-buffun) + (with-vector (src buffer-bytes) + (with-vector (dest buffer-bytes) + (do ((h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index srcstart deststart) + (type card16 h)) + (do ((i srclen (index1- i)) + (srcidx srcstart (index1+ srcidx)) + (destidx deststart (index1+ destidx))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (the card8 + (let ((byte (aref src srcidx))) + (declare (type card8 byte)) + (dpb (the card4 (ldb (byte 4 0) byte)) + (byte 4 4) + (the card4 (ldb (byte 4 4) byte))))))))))) + +(defun image-swap-nibbles-left + (src dest srcoff destoff srclen srcinc destinc height) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height)) + #.(declare-buffun) + (with-vector (src buffer-bytes) + (with-vector (dest buffer-bytes) + (do ((h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index srcstart deststart) + (type card16 h)) + (do ((i srclen (index1- i)) + (srcidx srcstart (index1+ srcidx)) + (destidx deststart (index1+ destidx))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (the card8 + (let ((byte1 (aref src srcidx)) + (byte2 (aref src (index1+ srcidx)))) + (declare (type card8 byte1 byte2)) + (dpb (the card4 (ldb (byte 4 0) byte1)) + (byte 4 4) + (the card4 (ldb (byte 4 4) byte2))))))))))) + +(defconstant + *image-byte-reverse* + '#.(coerce + '#( + 0 128 64 192 32 160 96 224 16 144 80 208 48 176 112 240 + 8 136 72 200 40 168 104 232 24 152 88 216 56 184 120 248 + 4 132 68 196 36 164 100 228 20 148 84 212 52 180 116 244 + 12 140 76 204 44 172 108 236 28 156 92 220 60 188 124 252 + 2 130 66 194 34 162 98 226 18 146 82 210 50 178 114 242 + 10 138 74 202 42 170 106 234 26 154 90 218 58 186 122 250 + 6 134 70 198 38 166 102 230 22 150 86 214 54 182 118 246 + 14 142 78 206 46 174 110 238 30 158 94 222 62 190 126 254 + 1 129 65 193 33 161 97 225 17 145 81 209 49 177 113 241 + 9 137 73 201 41 169 105 233 25 153 89 217 57 185 121 249 + 5 133 69 197 37 165 101 229 21 149 85 213 53 181 117 245 + 13 141 77 205 45 173 109 237 29 157 93 221 61 189 125 253 + 3 131 67 195 35 163 99 227 19 147 83 211 51 179 115 243 + 11 139 75 203 43 171 107 235 27 155 91 219 59 187 123 251 + 7 135 71 199 39 167 103 231 23 151 87 215 55 183 119 247 + 15 143 79 207 47 175 111 239 31 159 95 223 63 191 127 255) + '(vector card8))) + +(defun image-swap-bits + (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type boolean lsb-first-p) + (ignore lsb-first-p)) + #.(declare-buffun) + (with-vector (src buffer-bytes) + (with-vector (dest buffer-bytes) + (let ((byte-reverse *image-byte-reverse*)) + (with-vector (byte-reverse (simple-array card8 (256))) + (macrolet ((br (byte) + `(the card8 (aref byte-reverse (the card8 ,byte))))) + (do ((h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index srcstart deststart) + (type card16 h)) + (do ((i srclen (index1- i)) + (srcidx srcstart (index1+ srcidx)) + (destidx deststart (index1+ destidx))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) (br (aref src srcidx))))))))))) + +(defun image-swap-bits-and-two-bytes + (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type boolean lsb-first-p)) + #.(declare-buffun) + (with-vector (src buffer-bytes) + (with-vector (dest buffer-bytes) + (let ((byte-reverse *image-byte-reverse*)) + (with-vector (byte-reverse (simple-array card8 (256))) + (macrolet ((br (byte) + `(the card8 (aref byte-reverse (the card8 ,byte))))) + (do ((length (index* (index-ceiling srclen 2) 2)) + (h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index length srcstart deststart) + (type card16 h)) + (when (and (index= h 1) (not (index= srclen length))) + (index-decf length 2) + (if lsb-first-p + (setf (aref dest (index1+ (index+ deststart length))) + (br (aref src (index+ srcstart length)))) + (setf (aref dest (index+ deststart length)) + (br (aref src (index1+ (index+ srcstart length))))))) + (do ((i length (index- i 2)) + (srcidx srcstart (index+ srcidx 2)) + (destidx deststart (index+ destidx 2))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (br (aref src (index1+ srcidx)))) + (setf (aref dest (index1+ destidx)) + (br (aref src srcidx))))))))))) + +(defun image-swap-bits-and-four-bytes + (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type boolean lsb-first-p)) + #.(declare-buffun) + (with-vector (src buffer-bytes) + (with-vector (dest buffer-bytes) + (let ((byte-reverse *image-byte-reverse*)) + (with-vector (byte-reverse (simple-array card8 (256))) + (macrolet ((br (byte) + `(the card8 (aref byte-reverse (the card8 ,byte))))) + (do ((length (index* (index-ceiling srclen 4) 4)) + (h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index length srcstart deststart) + (type card16 h)) + (when (and (index= h 1) (not (index= srclen length))) + (index-decf length 4) + (unless lsb-first-p + (setf (aref dest (index+ deststart length)) + (br (aref src (index+ srcstart length 3))))) + (when (if lsb-first-p + (index= (index- srclen length) 3) + (not (index-zerop (index-logand srclen 2)))) + (setf (aref dest (index+ deststart length 1)) + (br (aref src (index+ srcstart length 2))))) + (when (if (null lsb-first-p) + (index= (index- srclen length) 3) + (not (index-zerop (index-logand srclen 2)))) + (setf (aref dest (index+ deststart length 2)) + (br (aref src (index+ srcstart length 1))))) + (when lsb-first-p + (setf (aref dest (index+ deststart length 3)) + (br (aref src (index+ srcstart length)))))) + (do ((i length (index- i 4)) + (srcidx srcstart (index+ srcidx 4)) + (destidx deststart (index+ destidx 4))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (br (aref src (index+ srcidx 3)))) + (setf (aref dest (index1+ destidx)) + (br (aref src (index+ srcidx 2)))) + (setf (aref dest (index+ destidx 2)) + (br (aref src (index1+ srcidx)))) + (setf (aref dest (index+ destidx 3)) + (br (aref src srcidx))))))))))) + +(defun image-swap-bits-and-words + (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type boolean lsb-first-p)) + #.(declare-buffun) + (with-vector (src buffer-bytes) + (with-vector (dest buffer-bytes) + (let ((byte-reverse *image-byte-reverse*)) + (with-vector (byte-reverse (simple-array card8 (256))) + (macrolet ((br (byte) + `(the card8 (aref byte-reverse (the card8 ,byte))))) + (do ((length (index* (index-ceiling srclen 4) 4)) + (h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index length srcstart deststart) + (type card16 h)) + (when (and (index= h 1) (not (index= srclen length))) + (index-decf length 4) + (unless lsb-first-p + (setf (aref dest (index+ deststart length 1)) + (br (aref src (index+ srcstart length 3))))) + (when (if lsb-first-p + (index= (index- srclen length) 3) + (not (index-zerop (index-logand srclen 2)))) + (setf (aref dest (index+ deststart length)) + (br (aref src (index+ srcstart length 2))))) + (when (if (null lsb-first-p) + (index= (index- srclen length) 3) + (not (index-zerop (index-logand srclen 2)))) + (setf (aref dest (index+ deststart length 3)) + (br (aref src (index+ srcstart length 1))))) + (when lsb-first-p + (setf (aref dest (index+ deststart length 2)) + (br (aref src (index+ srcstart length)))))) + (do ((i length (index- i 4)) + (srcidx srcstart (index+ srcidx 4)) + (destidx deststart (index+ destidx 4))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (br (aref src (index+ srcidx 2)))) + (setf (aref dest (index1+ destidx)) + (br (aref src (index+ srcidx 3)))) + (setf (aref dest (index+ destidx 2)) + (br (aref src srcidx))) + (setf (aref dest (index+ destidx 3)) + (br (aref src (index1+ srcidx)))))))))))) + +;;; The following table gives the bit ordering within bytes (when accessed +;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to +;;; 31, where bit 0 should be leftmost on the display. For a given byte +;;; labelled A-B, A is for the most significant bit of the byte, and B is +;;; for the least significant bit. +;;; +;;; legend: +;;; 1 scanline-unit = 8 +;;; 2 scanline-unit = 16 +;;; 4 scanline-unit = 32 +;;; M byte-order = MostSignificant +;;; L byte-order = LeastSignificant +;;; m bit-order = MostSignificant +;;; l bit-order = LeastSignificant +;;; +;;; +;;; format ordering +;;; +;;; 1Mm 00-07 08-15 16-23 24-31 +;;; 2Mm 00-07 08-15 16-23 24-31 +;;; 4Mm 00-07 08-15 16-23 24-31 +;;; 1Ml 07-00 15-08 23-16 31-24 +;;; 2Ml 15-08 07-00 31-24 23-16 +;;; 4Ml 31-24 23-16 15-08 07-00 +;;; 1Lm 00-07 08-15 16-23 24-31 +;;; 2Lm 08-15 00-07 24-31 16-23 +;;; 4Lm 24-31 16-23 08-15 00-07 +;;; 1Ll 07-00 15-08 23-16 31-24 +;;; 2Ll 07-00 15-08 23-16 31-24 +;;; 4Ll 07-00 15-08 23-16 31-24 +;;; +;;; +;;; The following table gives the required conversion between any two +;;; formats. It is based strictly on the table above. If you believe one, +;;; you should believe the other. +;;; +;;; legend: +;;; n no changes +;;; s reverse 8-bit units within 16-bit units +;;; l reverse 8-bit units within 32-bit units +;;; w reverse 16-bit units within 32-bit units +;;; r reverse bits within 8-bit units +;;; sr s+R +;;; lr l+R +;;; wr w+R + +(defconstant + *image-swap-function* + '#.(make-array + '(12 12) :initial-contents + (let ((n 'image-noswap) + (s 'image-swap-two-bytes) + (l 'image-swap-four-bytes) + (w 'image-swap-words) + (r 'image-swap-bits) + (sr 'image-swap-bits-and-two-bytes) + (lr 'image-swap-bits-and-four-bytes) + (wr 'image-swap-bits-and-words)) + (list #| 1Mm 2Mm 4Mm 1Ml 2Ml 4Ml 1Lm 2Lm 4Lm 1Ll 2Ll 4Ll |# + (list #| 1Mm |# n n n r sr lr n s l r r r ) + (list #| 2Mm |# n n n r sr lr n s l r r r ) + (list #| 4Mm |# n n n r sr lr n s l r r r ) + (list #| 1Ml |# r r r n s l r sr lr n n n ) + (list #| 2Ml |# sr sr sr s n w sr r wr s s s ) + (list #| 4Ml |# lr lr lr l w n lr wr r l l l ) + (list #| 1Lm |# n n n r sr lr n s l r r r ) + (list #| 2Lm |# s s s sr r wr s n w sr sr sr) + (list #| 4Lm |# l l l lr wr r l w n lr lr lr) + (list #| 1Ll |# r r r n s l r sr lr n n n ) + (list #| 2Ll |# r r r n s l r sr lr n n n ) + (list #| 4Ll |# r r r n s l r sr lr n n n ))))) + +;;; Of course, the table above is a lie. We also need to factor in the +;;; order of the source data to cope with swapping half of a unit at the +;;; end of a scanline, since we are trying to avoid de-ref'ing off the +;;; end of the source. +;;; +;;; Defines whether the first half of a unit has the first half of the data + +(defconstant + *image-swap-lsb-first-p* + '#.(make-array + 12 :initial-contents + (list t #| 1mm |# + t #| 2mm |# + t #| 4mm |# + t #| 1ml |# + nil #| 2ml |# + nil #| 4ml |# + t #| 1lm |# + nil #| 2lm |# + nil #| 4lm |# + t #| 1ll |# + t #| 2ll |# + t #| 4ll |# + ))) + +(defun image-swap-function + (from-bitmap-unit from-bitmap-byte-lsb-first-p + from-bitmap-bit-lsb-first-p to-bitmap-unit + to-bitmap-byte-lsb-first-p to-bitmap-bit-lsb-first-p) + (declare (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) + (type boolean from-bitmap-bit-lsb-first-p + from-bitmap-byte-lsb-first-p to-bitmap-bit-lsb-first-p + to-bitmap-byte-lsb-first-p) + (values function lsb-first-p)) + (let ((from-index + (index+ + (ecase from-bitmap-unit (32 2) (16 1) (8 0)) + (if from-bitmap-bit-lsb-first-p 3 0) + (if from-bitmap-byte-lsb-first-p 6 0)))) + (values + (aref *image-swap-function* from-index + (index+ + (ecase to-bitmap-unit (32 2) (16 1) (8 0)) + (if to-bitmap-bit-lsb-first-p 3 0) + (if to-bitmap-byte-lsb-first-p 6 0))) + (aref *image-swap-lsb-first-p* from-index)))) + +(defun image-swap-xy + (src dest srcoff destoff srclen srcinc destinc height + from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) + (type boolean from-byte-lsb-first-p from-bit-lsb-first-p + to-byte-lsb-first-p to-bit-lsb-first-p)) + (multiple-value-bind (function lsb-first-p) + (image-swap-function + from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) + (declare (type symbol function) + (type boolean lsb-first-p)) + (funcall function src dest srcoff destoff srclen srcinc destinc height + lsb-first-p))) + +(defun image-swap-z + (src dest srcoff destoff srclen srcinc destinc height + bits-per-pixel from-byte-lsb-first-p to-byte-lsb-first-p) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type card16 height) + (type boolean from-byte-lsb-first-p to-byte-lsb-first-p)) + (cond ((or (eq from-byte-lsb-first-p to-byte-lsb-first-p) + (= bits-per-pixel 8)) + (image-noswap + src dest srcoff destoff srclen srcinc destinc height + from-byte-lsb-first-p)) + ((= bits-per-pixel 32) + (image-swap-four-bytes + src dest srcoff destoff srclen srcinc destinc height + from-byte-lsb-first-p)) + ((= bits-per-pixel 24) + (image-swap-three-bytes + src dest srcoff destoff srclen srcinc destinc height + from-byte-lsb-first-p)) + ((= bits-per-pixel 16) + (image-swap-two-bytes + src dest srcoff destoff srclen srcinc destinc height + from-byte-lsb-first-p)) + (t + (image-swap-nibbles + src dest srcoff destoff srclen srcinc destinc height)))) + + +;;;----------------------------------------------------------------------------- +;;; GET-IMAGE + +(defun read-pixarray-1 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-1 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((start (index+ index + (index* y padded-bytes-per-line) + (index-ceiling x 8)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y)) + (left-bits (index-mod (index- x) 8)) + (right-bits (index-mod (index- width left-bits) 8)) + (middle-bits (index- width left-bits right-bits)) + (middle-bytes (index-floor middle-bits 8))) + ((index>= y height)) + (declare (type array-index start y + left-bits right-bits middle-bits middle-bytes)) + (cond ((index< middle-bits 0) + (let ((byte (aref buffer-bbuf (index1- start))) + (x left-bits)) + (declare (type card8 byte) + (type array-index x)) + (when (index> right-bits 6) + (setf (aref array y (index- x 1)) + (read-image-load-byte 1 7 byte))) + (when (and (index> left-bits 1) + (index> right-bits 5)) + (setf (aref array y (index- x 2)) + (read-image-load-byte 1 6 byte))) + (when (and (index> left-bits 2) + (index> right-bits 4)) + (setf (aref array y (index- x 3)) + (read-image-load-byte 1 5 byte))) + (when (and (index> left-bits 3) + (index> right-bits 3)) + (setf (aref array y (index- x 4)) + (read-image-load-byte 1 4 byte))) + (when (and (index> left-bits 4) + (index> right-bits 2)) + (setf (aref array y (index- x 5)) + (read-image-load-byte 1 3 byte))) + (when (and (index> left-bits 5) + (index> right-bits 1)) + (setf (aref array y (index- x 6)) + (read-image-load-byte 1 2 byte))) + (when (index> left-bits 6) + (setf (aref array y (index- x 7)) + (read-image-load-byte 1 1 byte))))) + (t + (unless (index-zerop left-bits) + (let ((byte (aref buffer-bbuf (index1- start))) + (x left-bits)) + (declare (type card8 byte) + (type array-index x)) + (setf (aref array y (index- x 1)) + (read-image-load-byte 1 7 byte)) + (when (index> left-bits 1) + (setf (aref array y (index- x 2)) + (read-image-load-byte 1 6 byte)) + (when (index> left-bits 2) + (setf (aref array y (index- x 3)) + (read-image-load-byte 1 5 byte)) + (when (index> left-bits 3) + (setf (aref array y (index- x 4)) + (read-image-load-byte 1 4 byte)) + (when (index> left-bits 4) + (setf (aref array y (index- x 5)) + (read-image-load-byte 1 3 byte)) + (when (index> left-bits 5) + (setf (aref array y (index- x 6)) + (read-image-load-byte 1 2 byte)) + (when (index> left-bits 6) + (setf (aref array y (index- x 7)) + (read-image-load-byte 1 1 byte)) + )))))))) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (x left-bits (index+ x 8))) + ((index>= i end) + (unless (index-zerop right-bits) + (let ((byte (aref buffer-bbuf end)) + (x (index+ left-bits middle-bits))) + (declare (type card8 byte) + (type array-index x)) + (setf (aref array y (index+ x 0)) + (read-image-load-byte 1 0 byte)) + (when (index> right-bits 1) + (setf (aref array y (index+ x 1)) + (read-image-load-byte 1 1 byte)) + (when (index> right-bits 2) + (setf (aref array y (index+ x 2)) + (read-image-load-byte 1 2 byte)) + (when (index> right-bits 3) + (setf (aref array y (index+ x 3)) + (read-image-load-byte 1 3 byte)) + (when (index> right-bits 4) + (setf (aref array y (index+ x 4)) + (read-image-load-byte 1 4 byte)) + (when (index> right-bits 5) + (setf (aref array y (index+ x 5)) + (read-image-load-byte 1 5 byte)) + (when (index> right-bits 6) + (setf (aref array y (index+ x 6)) + (read-image-load-byte 1 6 byte)) + ))))))))) + (declare (type array-index end i x)) + (let ((byte (aref buffer-bbuf i))) + (declare (type card8 byte)) + (setf (aref array y (index+ x 0)) + (read-image-load-byte 1 0 byte)) + (setf (aref array y (index+ x 1)) + (read-image-load-byte 1 1 byte)) + (setf (aref array y (index+ x 2)) + (read-image-load-byte 1 2 byte)) + (setf (aref array y (index+ x 3)) + (read-image-load-byte 1 3 byte)) + (setf (aref array y (index+ x 4)) + (read-image-load-byte 1 4 byte)) + (setf (aref array y (index+ x 5)) + (read-image-load-byte 1 5 byte)) + (setf (aref array y (index+ x 6)) + (read-image-load-byte 1 6 byte)) + (setf (aref array y (index+ x 7)) + (read-image-load-byte 1 7 byte)))) + ))))) + +(defun read-pixarray-4 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-4 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((start (index+ index + (index* y padded-bytes-per-line) + (index-ceiling x 2)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y)) + (left-nibbles (index-mod (index- x) 2)) + (right-nibbles (index-mod (index- width left-nibbles) 2)) + (middle-nibbles (index- width left-nibbles right-nibbles)) + (middle-bytes (index-floor middle-nibbles 2))) + ((index>= y height)) + (declare (type array-index start y + left-nibbles right-nibbles middle-nibbles middle-bytes)) + (unless (index-zerop left-nibbles) + (setf (aref array y 0) + (read-image-load-byte + 4 4 (aref buffer-bbuf (index1- start))))) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (x left-nibbles (index+ x 2))) + ((index>= i end) + (unless (index-zerop right-nibbles) + (setf (aref array y (index+ left-nibbles middle-nibbles)) + (read-image-load-byte 4 0 (aref buffer-bbuf end))))) + (declare (type array-index end i x)) + (let ((byte (aref buffer-bbuf i))) + (declare (type card8 byte)) + (setf (aref array y (index+ x 0)) + (read-image-load-byte 4 0 byte)) + (setf (aref array y (index+ x 1)) + (read-image-load-byte 4 4 byte)))) + ))) + +(defun read-pixarray-8 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-8 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((start (index+ index + (index* y padded-bytes-per-line) + x) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) + (declare (type array-index start y)) + (do* ((end (index+ start width)) + (i start (index1+ i)) + (x 0 (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref array y x) + (the card8 (aref buffer-bbuf i))))))) + +(defun read-pixarray-16 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-16 array) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((start (index+ index + (index* y padded-bytes-per-line) + (index* x 2)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) + (declare (type array-index start y)) + (do* ((end (index+ start (index* width 2))) + (i start (index+ i 2)) + (x 0 (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref array y x) + (read-image-assemble-bytes + (aref buffer-bbuf (index+ i 0)) + (aref buffer-bbuf (index+ i 1)))))))) + +(defun read-pixarray-24 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-24 array) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((start (index+ index + (index* y padded-bytes-per-line) + (index* x 3)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) + (declare (type array-index start y)) + (do* ((end (index+ start (index* width 3))) + (i start (index+ i 3)) + (x 0 (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref array y x) + (read-image-assemble-bytes + (aref buffer-bbuf (index+ i 0)) + (aref buffer-bbuf (index+ i 1)) + (aref buffer-bbuf (index+ i 2)))))))) + +(defun read-pixarray-32 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-32 array) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((start (index+ index + (index* y padded-bytes-per-line) + (index* x 4)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) + (declare (type array-index start y)) + (do* ((end (index+ start (index* width 4))) + (i start (index+ i 4)) + (x 0 (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref array y x) + (read-image-assemble-bytes + (aref buffer-bbuf (index+ i 0)) + (aref buffer-bbuf (index+ i 1)) + (aref buffer-bbuf (index+ i 2)) + (aref buffer-bbuf (index+ i 3)))))))) + +(defun read-xy-format-image-x + (buffer-bbuf index length data width height depth + padded-bytes-per-line padded-bytes-per-plane + unit byte-lsb-first-p bit-lsb-first-p pad) + (declare (type buffer-bytes buffer-bbuf) + (type card16 width height) + (type array-index index length padded-bytes-per-line + padded-bytes-per-plane) + (type image-depth depth) + (type (member 8 16 32) unit pad) + (type boolean byte-lsb-first-p bit-lsb-first-p) + (values image-x)) + (assert (index<= (index* depth padded-bytes-per-plane) length)) + (let* ((bytes-per-line (index-ceiling width 8)) + (data-length (index* padded-bytes-per-plane depth))) + (declare (type array-index bytes-per-line data-length)) + (cond (data + (check-type data buffer-bytes) + (assert (index>= (length data) data-length))) + (t + (setq data (make-array data-length :element-type 'card8)))) + (do ((plane 0 (index1+ plane))) + ((index>= plane depth)) + (declare (type image-depth plane)) + (image-noswap + buffer-bbuf data + (index+ index (index* plane padded-bytes-per-plane)) + (index* plane padded-bytes-per-plane) + bytes-per-line padded-bytes-per-line padded-bytes-per-line + height byte-lsb-first-p)) + (create-image + :width width :height height :depth depth :data data + :bits-per-pixel 1 :format :xy-pixmap + :bytes-per-line padded-bytes-per-line + :unit unit :byte-lsb-first-p byte-lsb-first-p + :bit-lsb-first-p bit-lsb-first-p :unit unit :pad pad))) + +(defun read-z-format-image-x + (buffer-bbuf index length data width height depth + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p pad bits-per-pixel) + (declare (type buffer-bytes buffer-bbuf) + (type card16 width height) + (type array-index index length padded-bytes-per-line) + (type image-depth depth) + (type (member 8 16 32) unit pad) + (type boolean byte-lsb-first-p bit-lsb-first-p) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (values image-x)) + (assert (index<= (index* height padded-bytes-per-line) length)) + (let ((bytes-per-line (index-ceiling (index* width bits-per-pixel) 8)) + (data-length (index* padded-bytes-per-line height))) + (declare (type array-index bytes-per-line data-length)) + (cond (data + (check-type data buffer-bytes) + (assert (index>= (length data) data-length))) + (t + (setq data (make-array data-length :element-type 'card8)))) + (image-noswap + buffer-bbuf data index 0 bytes-per-line padded-bytes-per-line + padded-bytes-per-line height byte-lsb-first-p) + (create-image + :width width :height height :depth depth :data data + :bits-per-pixel bits-per-pixel :format :z-pixmap + :bytes-per-line padded-bytes-per-line + :unit unit :byte-lsb-first-p byte-lsb-first-p + :bit-lsb-first-p bit-lsb-first-p :unit unit :pad pad))) + +(defmacro with-image-data-buffer ((buffer size) &body body) + (declare (indentation 0 4 1 1)) + `(let ((.reply-buffer. (allocate-reply-buffer ,size))) + (declare (type reply-buffer .reply-buffer.)) + (unwind-protect + (let ((,buffer (reply-ibuf8 .reply-buffer.))) + (declare (type buffer-bytes ,buffer)) + (with-vector (,buffer buffer-bytes) + ,@body)) + (deallocate-reply-buffer .reply-buffer.)))) + +(defun read-image-xy-data (bbuf index pixarray x y width height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type buffer-bytes bbuf) + (type array-index index padded-bytes-per-line) + (type pixarray pixarray) + (type card16 x y width height) + (type (member 8 16 32) unit) + (type boolean byte-lsb-first-p bit-lsb-first-p)) + (let* ((x1 (index* (index-floor x unit) unit)) + (x (index- x x1)) + (width1 (index+ width x)) + (padded-bits-per-line1 + (index* (index-ceiling width1 *image-pad*) *image-pad*)) + (padded-bytes-per-line1 (index-ceiling padded-bits-per-line1 8))) + (declare (type card16 x1 x width1) + (type array-index padded-bits-per-line1 padded-bytes-per-line1)) + (with-image-data-buffer (buf (index* height padded-bytes-per-line1)) + (image-swap-xy + bbuf buf + (index+ index + (index* y padded-bytes-per-line) + (index-floor x1 8)) + 0 + (index-ceiling width1 8) + padded-bytes-per-line padded-bytes-per-line1 + height + unit byte-lsb-first-p bit-lsb-first-p + *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*) + (unless (fast-read-pixarray + buf 0 pixarray x 0 width height padded-bytes-per-line1 1) + (read-pixarray-1 + buf 0 pixarray x 0 width height padded-bytes-per-line1))))) + +(defun read-image-xy (bbuf index length data x y width height depth + padded-bytes-per-line padded-bytes-per-plane + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type buffer-bytes bbuf) + (type card16 x y width height) + (type array-index index length padded-bytes-per-line + padded-bytes-per-plane) + (type image-depth depth) + (type (member 8 16 32) unit) + (type boolean byte-lsb-first-p bit-lsb-first-p) + (values image-xy)) + (check-type data list) + (multiple-value-bind (dimensions element-type) + (if data + (values (array-dimensions (first data)) + (array-element-type (first data))) + (values (list height + (index* (index-ceiling width *image-pad*) *image-pad*)) + 'pixarray-1-element-type)) + (do* ((arrays data) + (result nil) + (limit (index+ length index)) + (plane 0 (1+ plane)) + (index index (index+ index padded-bytes-per-plane))) + ((or (>= plane depth) + (index> (index+ index padded-bytes-per-plane) limit)) + (setq data (nreverse result) depth (length data))) + (declare (type array-index limit index) + (type image-depth plane) + (type list arrays result)) + (let ((array (or (pop arrays) + (make-array dimensions :element-type element-type)))) + (declare (type pixarray-1 array)) + (push array result) + (read-image-xy-data + bbuf index array x y width height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p))) + (create-image + :width width :height height :depth depth :data data))) + +(defun read-image-z-data (bbuf index pixarray x y width height + padded-bytes-per-line + bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type buffer-bytes bbuf) + (type array-index index padded-bytes-per-line) + (type pixarray pixarray) + (type card16 x y width height) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type (member 8 16 32) unit) + (type boolean byte-lsb-first-p bit-lsb-first-p)) + (if (index= bits-per-pixel 1) + (read-image-xy-data + bbuf index pixarray x y width height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p) + (let* ((xbits (index* x bits-per-pixel)) + (xbits1 (index* (index-floor xbits unit) unit)) + (x1 (index-floor xbits1 bits-per-pixel)) + (x (index- x x1)) + (width1 (index+ width x)) + (bits-per-line1 (index* width1 bits-per-pixel)) + (bytes-per-line1 (index-ceiling bits-per-line1 8)) + (padded-bits-per-line1 + (index* (index-ceiling bits-per-line1 *image-pad*) *image-pad*)) + (padded-bytes-per-line1 + (index-ceiling padded-bits-per-line1 8))) + (declare (type array-index xbits xbits1 x1 x + bits-per-line1 bytes-per-line1 + padded-bits-per-line1 padded-bytes-per-line1)) + (with-image-data-buffer (buf (index* height padded-bytes-per-line1)) + (image-swap-z + bbuf buf + (index+ index + (index* y padded-bytes-per-line) + (index-floor xbits1 8)) + 0 + bytes-per-line1 + padded-bytes-per-line padded-bytes-per-line1 + height + bits-per-pixel byte-lsb-first-p *image-byte-lsb-first-p*) + (unless (fast-read-pixarray + buf 0 pixarray x 0 width height padded-bytes-per-line1 + bits-per-pixel) + (funcall + (ecase bits-per-pixel + (1 #'read-pixarray-1) (4 #'read-pixarray-4) + (8 #'read-pixarray-8) (16 #'read-pixarray-16) + (24 #'read-pixarray-24) (32 #'read-pixarray-32)) + buf 0 pixarray x 0 width height padded-bytes-per-line1)))))) + +(defun read-image-z (bbuf index length data x y width height depth + padded-bytes-per-line bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type buffer-bytes bbuf) + (type card16 x y width height) + (type array-index index length padded-bytes-per-line) + (type image-depth depth) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type (member 8 16 32) unit) + (type boolean byte-lsb-first-p bit-lsb-first-p) + (values image-z)) + (assert (index<= (index* (index+ y height) padded-bytes-per-line) length)) + (let* ((image-bits-per-line (index* width bits-per-pixel)) + (image-pixels-per-line + (index-ceiling + (index* (index-ceiling image-bits-per-line *image-pad*) + *image-pad*) + bits-per-pixel))) + (declare (type array-index image-bits-per-line image-pixels-per-line)) + (unless data + (setq data + (make-array + (list height image-pixels-per-line) + :element-type (ecase bits-per-pixel + (1 'pixarray-1-element-type) + (4 'pixarray-4-element-type) + (8 'pixarray-8-element-type) + (16 'pixarray-16-element-type) + (24 'pixarray-24-element-type) + (32 'pixarray-32-element-type))))) + (read-image-z-data + bbuf index data x y width height + padded-bytes-per-line bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p) + (create-image + :width width :height height :depth depth :data data + :bits-per-pixel bits-per-pixel))) + +(defun get-image (drawable &key + data + (x (required-arg x)) + (y (required-arg y)) + (width (required-arg width)) + (height (required-arg height)) + plane-mask format result-type) + (declare (type drawable drawable) + (type (or buffer-bytes list pixarray) data) + (type int16 x y) ;; required + (type card16 width height) ;; required + (type (or null pixel) plane-mask) + (type (or null (member :xy-pixmap :z-pixmap)) format) + (type (or null (member image-xy image-x image-z)) result-type) + (values image visual-info)) + (unless result-type + (setq result-type (ecase format + (:xy-pixmap 'image-xy) + (:z-pixmap 'image-z) + ((nil) 'image-x)))) + (unless format + (setq format (case result-type + (image-xy :xy-pixmap) + ((image-z image-x) :z-pixmap)))) + (unless (ecase result-type + (image-xy (eq format :xy-pixmap)) + (image-z (eq format :z-pixmap)) + (image-x t)) + (error "Result-type ~s is incompatable with format ~s" + result-type format)) + (unless plane-mask (setq plane-mask #xffffffff)) + (let ((display (drawable-display drawable))) + (with-buffer-request-and-reply (display *x-getimage* nil :sizes (8 32)) + (((data (member error :xy-pixmap :z-pixmap)) format) + (drawable drawable) + (int16 x y) + (card16 width height) + (card32 plane-mask)) + (let* ((depth (card8-get 1)) + (length (index* 4 (card32-get 4))) + (visual-info (visual-info display (resource-id-get 8))) + (bitmap-format (display-bitmap-format display)) + (unit (bitmap-format-unit bitmap-format)) + (byte-lsb-first-p (display-image-lsb-first-p display)) + (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) + (declare (type image-depth depth) + (type array-index length) + (type (or null visual-info) visual-info) + (type bitmap-format bitmap-format) + (type (member 8 16 32) unit) + (type boolean byte-lsb-first-p bit-lsb-first-p)) + (multiple-value-bind (pad bits-per-pixel) + (ecase format + (:xy-pixmap + (values (bitmap-format-pad bitmap-format) 1)) + (:z-pixmap + (if (= depth 1) + (values (bitmap-format-pad bitmap-format) 1) + (let ((pixmap-format + (find depth (display-pixmap-formats display) + :key #'pixmap-format-depth))) + (declare (type pixmap-format pixmap-format)) + (values (pixmap-format-scanline-pad pixmap-format) + (pixmap-format-bits-per-pixel pixmap-format)))))) + (declare (type (member 8 16 32) pad) + (type (member 1 4 8 16 24 32) bits-per-pixel)) + (let* ((bits-per-line (index* bits-per-pixel width)) + (padded-bits-per-line + (index* (index-ceiling bits-per-line pad) pad)) + (padded-bytes-per-line + (index-ceiling padded-bits-per-line 8)) + (padded-bytes-per-plane + (index* padded-bytes-per-line height)) + (image + (ecase result-type + (image-x + (ecase format + (:xy-pixmap + (read-xy-format-image-x + buffer-bbuf *replysize* length data + width height depth + padded-bytes-per-line padded-bytes-per-plane + unit byte-lsb-first-p bit-lsb-first-p + pad)) + (:z-pixmap + (read-z-format-image-x + buffer-bbuf *replysize* length data + width height depth + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p + pad bits-per-pixel)))) + (image-xy + (read-image-xy + buffer-bbuf *replysize* length data + 0 0 width height depth + padded-bytes-per-line padded-bytes-per-plane + unit byte-lsb-first-p bit-lsb-first-p)) + (image-z + (read-image-z + buffer-bbuf *replysize* length data + 0 0 width height depth padded-bytes-per-line + bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p))))) + (declare (type image image) + (type array-index bits-per-line + padded-bits-per-line padded-bytes-per-line)) + (when visual-info + (unless (zerop (visual-info-red-mask visual-info)) + (setf (image-red-mask image) + (visual-info-red-mask visual-info))) + (unless (zerop (visual-info-green-mask visual-info)) + (setf (image-green-mask image) + (visual-info-green-mask visual-info))) + (unless (zerop (visual-info-blue-mask visual-info)) + (setf (image-blue-mask image) + (visual-info-blue-mask visual-info)))) + (values image visual-info))))))) + + +;;;----------------------------------------------------------------------------- +;;; PUT-IMAGE + +(defun write-pixarray-1 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-1 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((h 0 (index1+ h)) + (y y (index1+ y)) + (right-bits (index-mod width 8)) + (middle-bits (index- width right-bits)) + (middle-bytes (index-ceiling middle-bits 8)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type array-index h y right-bits middle-bits + middle-bytes start)) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (start-x x) + (x start-x (index+ x 8))) + ((index>= i end) + (unless (index-zerop right-bits) + (let ((x (index+ start-x middle-bits))) + (declare (type array-index x)) + (setf (aref buffer-bbuf end) + (write-image-assemble-bytes + (aref array y (index+ x 0)) + (if (index> right-bits 1) + (aref array y (index+ x 1)) + 0) + (if (index> right-bits 2) + (aref array y (index+ x 2)) + 0) + (if (index> right-bits 3) + (aref array y (index+ x 3)) + 0) + (if (index> right-bits 4) + (aref array y (index+ x 4)) + 0) + (if (index> right-bits 5) + (aref array y (index+ x 5)) + 0) + (if (index> right-bits 6) + (aref array y (index+ x 6)) + 0) + 0))))) + (declare (type array-index end i start-x x)) + (setf (aref buffer-bbuf i) + (write-image-assemble-bytes + (aref array y (index+ x 0)) + (aref array y (index+ x 1)) + (aref array y (index+ x 2)) + (aref array y (index+ x 3)) + (aref array y (index+ x 4)) + (aref array y (index+ x 5)) + (aref array y (index+ x 6)) + (aref array y (index+ x 7)))))))) + +(defun write-pixarray-4 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-4 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((h 0 (index1+ h)) + (y y (index1+ y)) + (right-nibbles (index-mod width 2)) + (middle-nibbles (index- width right-nibbles)) + (middle-bytes (index-ceiling middle-nibbles 2)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type array-index h y right-nibbles middle-nibbles + middle-bytes start)) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (start-x x) + (x start-x (index+ x 2))) + ((index>= i end) + (unless (index-zerop right-nibbles) + (setf (aref buffer-bbuf end) + (write-image-assemble-bytes + (aref array y (index+ start-x middle-nibbles)) + 0)))) + (declare (type array-index end i start-x x)) + (setf (aref buffer-bbuf i) + (write-image-assemble-bytes + (aref array y (index+ x 0)) + (aref array y (index+ x 1)))))))) + +(defun write-pixarray-8 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-8 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((h 0 (index1+ h)) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type array-index h y start)) + (do* ((end (index+ start width)) + (i start (index1+ i)) + (x x (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref buffer-bbuf i) (the card8 (aref array y x))))))) + +(defun write-pixarray-16 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-16 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((h 0 (index1+ h)) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type array-index h y start)) + (do* ((end (index+ start (index* width 2))) + (i start (index+ i 2)) + (x x (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (let ((pixel (aref array y x))) + (declare (type pixarray-16-element-type pixel)) + (setf (aref buffer-bbuf (index+ i 0)) + (write-image-load-byte 0 pixel 16)) + (setf (aref buffer-bbuf (index+ i 1)) + (write-image-load-byte 8 pixel 16))))))) + +(defun write-pixarray-24 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-24 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((h 0 (index1+ h)) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type array-index y start)) + (do* ((end (index+ start (index* width 3))) + (i start (index+ i 3)) + (x x (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (let ((pixel (aref array y x))) + (declare (type pixarray-24-element-type pixel)) + (setf (aref buffer-bbuf (index+ i 0)) + (write-image-load-byte 0 pixel 24)) + (setf (aref buffer-bbuf (index+ i 1)) + (write-image-load-byte 8 pixel 24)) + (setf (aref buffer-bbuf (index+ i 2)) + (write-image-load-byte 16 pixel 24))))))) + +(defun write-pixarray-32 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-32 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((h 0 (index1+ h)) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type array-index h y start)) + (do* ((end (index+ start (index* width 4))) + (i start (index+ i 4)) + (x x (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (let ((pixel (aref array y x))) + (declare (type pixarray-32-element-type pixel)) + (setf (aref buffer-bbuf (index+ i 0)) + (write-image-load-byte 0 pixel 32)) + (setf (aref buffer-bbuf (index+ i 1)) + (write-image-load-byte 8 pixel 32)) + (setf (aref buffer-bbuf (index+ i 2)) + (write-image-load-byte 16 pixel 32)) + (setf (aref buffer-bbuf (index+ i 2)) + (write-image-load-byte 24 pixel 32))))))) + +(defun write-xy-format-image-x-data + (data obuf data-start obuf-start x y width height + from-padded-bytes-per-line to-padded-bytes-per-line + from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) + (declare (type buffer-bytes data obuf) + (type array-index data-start obuf-start + from-padded-bytes-per-line to-padded-bytes-per-line) + (type card16 x y width height) + (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) + (type boolean from-byte-lsb-first-p from-bit-lsb-first-p + to-byte-lsb-first-p to-bit-lsb-first-p)) + (assert (index-zerop (index-mod x 8))) + (let ((x-mod-unit (index-mod x from-bitmap-unit))) + (declare (type card16 x-mod-unit)) + (if (and (index-plusp x-mod-unit) + (not (eq from-byte-lsb-first-p from-bit-lsb-first-p))) + (let* ((temp-width (index+ width x-mod-unit)) + (temp-bytes-per-line (index-ceiling temp-width 8)) + (temp-padded-bits-per-line + (index* (index-ceiling temp-width from-bitmap-unit) + from-bitmap-unit)) + (temp-padded-bytes-per-line + (index-ceiling temp-padded-bits-per-line 8))) + (declare (type card16 temp-width temp-bytes-per-line + temp-padded-bits-per-line temp-padded-bytes-per-line)) + (with-image-data-buffer (buf (index* height + temp-padded-bytes-per-line)) + (image-swap-xy + data buf + (index+ data-start + (index* y from-padded-bytes-per-line) + (index-floor (index- x x-mod-unit) 8)) + 0 + temp-bytes-per-line + from-padded-bytes-per-line temp-padded-bytes-per-line + height + from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p + from-bitmap-unit to-byte-lsb-first-p to-byte-lsb-first-p) + (write-xy-format-image-x-data + buf obuf 0 obuf-start x-mod-unit 0 width height + temp-padded-bytes-per-line to-padded-bytes-per-line + from-bitmap-unit to-byte-lsb-first-p to-byte-lsb-first-p + to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p))) + (image-swap-xy + data obuf + (index+ data-start + (index* y from-padded-bytes-per-line) + (index-floor x 8)) + obuf-start + (index-ceiling width 8) + from-padded-bytes-per-line to-padded-bytes-per-line + height + from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)))) + +(defun write-xy-format-image-x + (display image src-x src-y width height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type display display) + (type image-x image) + (type int16 src-x src-y) + (type card16 width height) + (type array-index padded-bytes-per-line) + (type (member 8 16 32) unit) + (type boolean byte-lsb-first-p bit-lsb-first-p)) + (dotimes (plane (image-depth image)) + (let ((data-start + (index* (index* plane (image-height image)) + (image-x-bytes-per-line image))) + (src-y src-y) + (height height)) + (declare (type int16 src-y) + (type card16 height)) + (loop + (when (index-zerop height) (return)) + (let ((nlines + (index-min (index-floor (index- (buffer-size display) + (buffer-boffset display)) + padded-bytes-per-line) + height))) + (declare (type array-index nlines)) + (when (index-plusp nlines) + (write-xy-format-image-x-data + (image-x-data image) (buffer-obuf8 display) + data-start (buffer-boffset display) + src-x src-y width nlines + (image-x-bytes-per-line image) padded-bytes-per-line + (image-x-unit image) (image-x-byte-lsb-first-p image) + (image-x-bit-lsb-first-p image) + unit byte-lsb-first-p bit-lsb-first-p) + (index-incf (buffer-boffset display) + (index* nlines padded-bytes-per-line)) + (index-incf src-y nlines) + (when (index-zerop (index-decf height nlines)) (return)))) + (buffer-flush display))))) + +(defun write-z-format-image-x-data + (data obuf data-start obuf-start x y width height + from-padded-bytes-per-line to-padded-bytes-per-line + bits-per-pixel + from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) + (declare (type buffer-bytes data obuf) + (type array-index data-start obuf-start + from-padded-bytes-per-line to-padded-bytes-per-line) + (type card16 x y width height) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) + (type boolean from-byte-lsb-first-p from-bit-lsb-first-p + to-byte-lsb-first-p to-bit-lsb-first-p)) + (if (index= bits-per-pixel 1) + (write-xy-format-image-x-data + data obuf data-start obuf-start x y width height + from-padded-bytes-per-line to-padded-bytes-per-line + from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) + (let ((srcoff + (index+ data-start + (index* y from-padded-bytes-per-line) + (index-floor (index* x bits-per-pixel) 8))) + (srclen (index-ceiling (index* width bits-per-pixel) 8))) + (declare (type array-index srcoff srclen)) + (if (and (index= bits-per-pixel 4) (index-oddp x)) + (with-image-data-buffer (buf (index* height to-padded-bytes-per-line)) + (image-swap-nibbles-left + data buf srcoff 0 srclen + from-padded-bytes-per-line to-padded-bytes-per-line height) + (write-z-format-image-x-data + buf obuf 0 obuf-start 0 0 width height + to-padded-bytes-per-line to-padded-bytes-per-line + bits-per-pixel + from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)) + (image-swap-z + data obuf srcoff obuf-start srclen + from-padded-bytes-per-line to-padded-bytes-per-line height + bits-per-pixel from-byte-lsb-first-p to-byte-lsb-first-p))))) + +(defun write-z-format-image-x (display image src-x src-y width height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type display display) + (type image-x image) + (type int16 src-x src-y) + (type card16 width height) + (type array-index padded-bytes-per-line) + (type boolean byte-lsb-first-p bit-lsb-first-p)) + (loop + (when (index-zerop height) (return)) + (let ((nlines + (index-min (index-floor (index- (buffer-size display) + (buffer-boffset display)) + padded-bytes-per-line) + height))) + (declare (type array-index nlines)) + (when (index-plusp nlines) + (write-z-format-image-x-data + (image-x-data image) (buffer-obuf8 display) 0 (buffer-boffset display) + src-x src-y width nlines + (image-x-bytes-per-line image) padded-bytes-per-line + (image-x-bits-per-pixel image) + (image-x-unit image) (image-x-byte-lsb-first-p image) + (image-x-bit-lsb-first-p image) + unit byte-lsb-first-p bit-lsb-first-p) + (index-incf (buffer-boffset display) + (index* nlines padded-bytes-per-line)) + (index-incf src-y nlines) + (when (index-zerop (index-decf height nlines)) (return)))) + (buffer-flush display))) + +(defun write-image-xy-data (obuf boffset pixarray x y width height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type buffer-bytes obuf) + (type array-index boffset padded-bytes-per-line) + (type pixarray-1 pixarray) + (type card16 x y width height) + (type (member 8 16 32) unit) + (type boolean byte-lsb-first-p bit-lsb-first-p)) + (with-image-data-buffer (buf (index* height padded-bytes-per-line)) + (unless (fast-write-pixarray + buf 0 pixarray x y width height padded-bytes-per-line 1) + (write-pixarray-1 + buf 0 pixarray x y width height padded-bytes-per-line)) + (image-swap-xy + buf obuf 0 boffset (index-ceiling width 8) + padded-bytes-per-line padded-bytes-per-line height + *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p* + unit byte-lsb-first-p bit-lsb-first-p))) + +(defun write-image-xy (display image src-x src-y width height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type display display) + (type image-xy image) + (type array-index padded-bytes-per-line) + (type int16 src-x src-y) + (type card16 width height) + (type (member 8 16 32) unit) + (type boolean byte-lsb-first-p bit-lsb-first-p)) + (dolist (bitmap (image-xy-bitmap-list image)) + (declare (type pixarray-1 bitmap)) + (let ((src-y src-y) + (height height)) + (declare (type int16 src-y) + (type card16 height)) + (loop + (let ((nlines + (index-min (index-floor (index- (buffer-size display) + (buffer-boffset display)) + padded-bytes-per-line) + height))) + (declare (type array-index nlines)) + (when (index-plusp nlines) + (write-image-xy-data + (buffer-obuf8 display) (buffer-boffset display) + bitmap src-x src-y width nlines + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p) + (index-incf (buffer-boffset display) + (index* nlines padded-bytes-per-line)) + (index-incf src-y nlines) + (when (index-zerop (index-decf height nlines)) (return)))) + (buffer-flush display))))) + +(defun write-image-z-data (obuf boffset pixarray x y width height + padded-bytes-per-line bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type buffer-bytes obuf) + (type array-index boffset padded-bytes-per-line) + (type pixarray-1 pixarray) + (type card16 x y width height) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type (member 8 16 32) unit) + (type boolean byte-lsb-first-p bit-lsb-first-p)) + (if (index= bits-per-pixel 1) + (write-image-xy-data + obuf boffset pixarray x y width height padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p) + (with-image-data-buffer (buf (index* height padded-bytes-per-line)) + (unless (fast-write-pixarray + buf 0 pixarray x y width height + padded-bytes-per-line bits-per-pixel) + (funcall + (ecase bits-per-pixel + (1 #'write-pixarray-1) (4 #'write-pixarray-4) + (8 #'write-pixarray-8) (16 #'write-pixarray-16) + (24 #'write-pixarray-24) (32 #'write-pixarray-32)) + buf 0 pixarray x y width height padded-bytes-per-line)) + (image-swap-z + buf obuf 0 boffset + (index-ceiling (index* width bits-per-pixel) 8) + padded-bytes-per-line padded-bytes-per-line + height bits-per-pixel + *image-byte-lsb-first-p* byte-lsb-first-p)))) + +(defun write-image-z (display image src-x src-y width height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type display display) + (type image-z image) + (type array-index padded-bytes-per-line) + (type int16 src-x src-y) + (type card16 width height) + (type (member 8 16 32) unit) + (type boolean byte-lsb-first-p bit-lsb-first-p)) + (loop + (let ((bits-per-pixel (image-z-bits-per-pixel image)) + (nlines + (index-min (index-floor (index- (buffer-size display) + (buffer-boffset display)) + padded-bytes-per-line) + height))) + (declare (type (member 1 4 8 16 24 32) bits-per-pixel) + (type array-index nlines)) + (when (index-plusp nlines) + (write-image-z-data + (buffer-obuf8 display) (buffer-boffset display) + (image-z-pixarray image) src-x src-y width nlines + padded-bytes-per-line bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p) + (index-incf (buffer-boffset display) + (index* nlines padded-bytes-per-line)) + (index-incf src-y nlines) + (when (index-zerop (index-decf height nlines)) (return)))) + (buffer-flush display))) + +;;; Note: The only difference between a format of :bitmap and :xy-pixmap +;;; of depth 1 is that when sending a :bitmap format the foreground +;;; and background in the gcontext are used. + +(defun put-image (drawable gcontext image &key + (src-x 0) (src-y 0) ;Position within image + (x (required-arg x)) ;Position within drawable + (y (required-arg y)) + width height + bitmap-p) + ;; Copy an image into a drawable. + ;; WIDTH and HEIGHT default from IMAGE. + ;; When BITMAP-P, force format to be :bitmap when depth=1. + ;; This causes gcontext to supply foreground & background pixels. + (declare (type drawable drawable) + (type gcontext gcontext) + (type image image) + (type int16 x y) ;; required + (type int16 src-x src-y) + (type (or null card16) width height) + (type boolean bitmap-p)) + (let* ((format + (etypecase image + (image-x (image-x-format (the image-x image))) + (image-xy :xy-pixmap) + (image-z :z-pixmap))) + (src-x + (if (image-x-p image) + (index+ src-x (image-x-left-pad (the image-x image))) + src-x)) + (image-width (image-width image)) + (image-height (image-height image)) + (width (min (or width image-width) (index- image-width src-x))) + (height (min (or height image-height) (index- image-height src-y))) + (depth (image-depth image)) + (display (drawable-display drawable)) + (bitmap-format (display-bitmap-format display)) + (unit (bitmap-format-unit bitmap-format)) + (byte-lsb-first-p (display-image-lsb-first-p display)) + (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) + (declare (type (member :bitmap :xy-pixmap :z-pixmap) format) + (type card16 src-x image-width image-height width height) + (type image-depth depth) + (type display display) + (type bitmap-format bitmap-format) + (type (member 8 16 32) unit) + (type boolean byte-lsb-first-p bit-lsb-first-p)) + (when (and bitmap-p (not (index= depth 1))) + (error "Bitmaps must have depth 1")) + (unless (index<= 0 src-x (index1- (image-width image))) + (error "src-x not inside image")) + (unless (index<= 0 src-y (index1- (image-height image))) + (error "src-y not inside image")) + (when (and (index> width 0) (index> height 0)) + (multiple-value-bind (pad bits-per-pixel) + (ecase format + ((:bitmap :xy-pixmap) + (values (bitmap-format-pad bitmap-format) 1)) + (:z-pixmap + (if (= depth 1) + (values (bitmap-format-pad bitmap-format) 1) + (let ((pixmap-format + (find depth (display-pixmap-formats display) + :key #'pixmap-format-depth))) + (declare (type pixmap-format pixmap-format)) + (values (pixmap-format-scanline-pad pixmap-format) + (pixmap-format-bits-per-pixel pixmap-format)))))) + (declare (type (member 8 16 32) pad) + (type (member 1 4 8 16 24 32) bits-per-pixel)) + (let* ((left-pad + (if (or (eq format :xy-pixmap) (= depth 1)) + (index-mod src-x (index-min pad *image-pad*)) + 0)) + (left-padded-src-x (index- src-x left-pad)) + (left-padded-width (index+ width left-pad)) + (bits-per-line (index* left-padded-width bits-per-pixel)) + (padded-bits-per-line + (index* (index-ceiling bits-per-line pad) pad)) + (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) + (request-bytes-per-line + (ecase format + ((:bitmap :xy-pixmap) (index* padded-bytes-per-line depth)) + (:z-pixmap padded-bytes-per-line))) + (max-bytes-per-request + (index* (index- (display-max-request-length display) 6) 4)) + (max-request-height + (floor max-bytes-per-request request-bytes-per-line))) + (declare (type card8 left-pad) + (type int16 left-padded-src-x) + (type card16 left-padded-width) + (type array-index bits-per-line padded-bits-per-line + padded-bytes-per-line request-bytes-per-line + max-bytes-per-request max-request-height)) + ;; Be sure that a scanline can fit in a request + (when (index-zerop max-request-height) + (error "Can't even fit one image scanline in a request")) + ;; Be sure a scanline can fit in a buffer + (buffer-ensure-size display padded-bytes-per-line) + ;; Send the image in multiple requests to avoid exceeding the + ;; request limit + (do* ((request-src-y src-y (index+ request-src-y request-height)) + (request-y y (index+ request-y request-height)) + (height-remaining + height (index- height-remaining request-height)) + (request-height + (index-min height-remaining max-request-height) + (index-min height-remaining max-request-height))) + ((index<= height-remaining 0)) + (declare (type array-index request-src-y height-remaining + request-height)) + (let* ((request-bytes (index* request-bytes-per-line request-height)) + (request-words (index-ceiling request-bytes 4)) + (request-length (index+ request-words 6))) + (declare (type array-index request-bytes) + (type card16 request-words request-length)) + (with-buffer-request (display *x-putimage* :gc-force gcontext) + ((data (member :bitmap :xy-pixmap :z-pixmap)) + (cond ((or (eq format :bitmap) bitmap-p) :bitmap) + ((plusp left-pad) :xy-pixmap) + (t format))) + (drawable drawable) + (gcontext gcontext) + (card16 width request-height) + (int16 x request-y) + (card8 left-pad depth) + (pad16 nil) + (progn + (length-put 2 request-length) + (setf (buffer-boffset display) (advance-buffer-offset 24)) + (etypecase image + (image-x + (ecase (image-x-format (the image-x image)) + ((:bitmap :xy-pixmap) + (write-xy-format-image-x + display image left-padded-src-x request-src-y + left-padded-width request-height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p)) + (:z-pixmap + (write-z-format-image-x + display image left-padded-src-x request-src-y + left-padded-width request-height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p)))) + (image-xy + (write-image-xy + display image left-padded-src-x request-src-y + left-padded-width request-height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p)) + (image-z + (write-image-z + display image left-padded-src-x request-src-y + left-padded-width request-height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p))) + ;; Be sure the request is padded to a multiple of 4 bytes + (buffer-pad-request display (index- (index* request-words 4) request-bytes)) + ))))))))) + +;;;----------------------------------------------------------------------------- +;;; COPY-IMAGE + +(defun xy-format-image-x->image-x (image x y width height) + (declare (type image-x image) + (type card16 x y width height) + (values image-x)) + (let* ((padded-x (index+ x (image-x-left-pad image))) + (left-pad (index-mod padded-x 8)) + (x (index- padded-x left-pad)) + (unit (image-x-unit image)) + (byte-lsb-first-p (image-x-byte-lsb-first-p image)) + (bit-lsb-first-p (image-x-bit-lsb-first-p image)) + (pad (image-x-pad image)) + (padded-width + (index* (index-ceiling (index+ width left-pad) pad) pad)) + (padded-bytes-per-line (index-ceiling padded-width 8)) + (padded-bytes-per-plane (index* padded-bytes-per-line height)) + (length (index* padded-bytes-per-plane (image-depth image))) + (obuf (make-array length :element-type 'card8))) + (declare (type card16 x) + (type card8 left-pad) + (type (member 8 16 32) unit pad) + (type array-index padded-width padded-bytes-per-line + padded-bytes-per-plane length) + (type buffer-bytes obuf)) + (dotimes (plane (image-depth image)) + (let ((data-start + (index* (image-x-bytes-per-line image) + (image-height image) + plane)) + (obuf-start + (index* padded-bytes-per-plane + plane))) + (declare (type array-index data-start obuf-start)) + (write-xy-format-image-x-data + (image-x-data image) obuf data-start obuf-start + x y width height + (image-x-bytes-per-line image) padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p + unit byte-lsb-first-p bit-lsb-first-p))) + (create-image + :width width :height height :depth (image-depth image) + :data obuf :format (image-x-format image) :bits-per-pixel 1 + :bytes-per-line padded-bytes-per-line + :unit unit :byte-lsb-first-p byte-lsb-first-p + :bit-lsb-first-p bit-lsb-first-p :pad pad :left-pad left-pad))) + +(defun z-format-image-x->image-x (image x y width height) + (declare (type image-x image) + (type card16 x y width height) + (values image-x)) + (let* ((padded-x (index+ x (image-x-left-pad image))) + (left-pad + (if (index= (image-depth image) 1) + (index-mod padded-x 8) + 0)) + (x (index- padded-x left-pad)) + (bits-per-pixel (image-x-bits-per-pixel image)) + (unit (image-x-unit image)) + (byte-lsb-first-p (image-x-byte-lsb-first-p image)) + (bit-lsb-first-p (image-x-bit-lsb-first-p image)) + (pad (image-x-pad image)) + (bits-per-line (index* (index+ width left-pad) bits-per-pixel)) + (padded-bits-per-line (index* (index-ceiling bits-per-line pad) pad)) + (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) + (padded-bytes-per-plane (index* padded-bytes-per-line height)) + (length (index* padded-bytes-per-plane (image-depth image))) + (obuf (make-array length :element-type 'card8))) + (declare (type card16 x) + (type card8 left-pad) + (type (member 8 16 32) unit pad) + (type array-index bits-per-pixel padded-bytes-per-line + padded-bytes-per-plane length) + (type buffer-bytes obuf)) + (write-z-format-image-x-data + (image-x-data image) obuf 0 0 + x y width height + (image-x-bytes-per-line image) padded-bytes-per-line + bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p + unit byte-lsb-first-p bit-lsb-first-p) + (create-image + :width width :height height :depth (image-depth image) + :data obuf :format :z-pixmap :bits-per-pixel bits-per-pixel + :bytes-per-line padded-bytes-per-line + :unit unit :byte-lsb-first-p byte-lsb-first-p + :bit-lsb-first-p bit-lsb-first-p :pad pad :left-pad left-pad))) + +(defun image-x->image-x (image x y width height) + (declare (type image-x image) + (type card16 x y width height) + (values image-x)) + (ecase (image-x-format image) + ((:bitmap :xy-pixmap) + (xy-format-image-x->image-x image x y width height)) + (:z-pixmap + (z-format-image-x->image-x image x y width height)))) + +(defun image-x->image-xy (image x y width height) + (declare (type image-x image) + (type card16 x y width height) + (values image-xy)) + (unless (or (eq (image-x-format image) :bitmap) + (eq (image-x-format image) :xy-pixmap) + (and (eq (image-x-format image) :z-pixmap) + (index= (image-depth image) 1))) + (error "Format conversion from ~S to ~S not supported" + (image-x-format image) :xy-pixmap)) + (read-image-xy + (image-x-data image) 0 (length (image-x-data image)) nil + (index+ x (image-x-left-pad image)) y width height + (image-depth image) (image-x-bytes-per-line image) + (index* (image-x-bytes-per-line image) (image-height image)) + (image-x-unit image) (image-x-byte-lsb-first-p image) + (image-x-bit-lsb-first-p image))) + +(defun image-x->image-z (image x y width height) + (declare (type image-x image) + (type card16 x y width height) + (values image-z)) + (unless (or (eq (image-x-format image) :z-pixmap) + (eq (image-x-format image) :bitmap) + (and (eq (image-x-format image) :xy-pixmap) + (index= (image-depth image) 1))) + (error "Format conversion from ~S to ~S not supported" + (image-x-format image) :z-pixmap)) + (read-image-z + (image-x-data image) 0 (length (image-x-data image)) nil + (index+ x (image-x-left-pad image)) y width height + (image-depth image) (image-x-bytes-per-line image) + (image-x-bits-per-pixel image) + (image-x-unit image) (image-x-byte-lsb-first-p image) + (image-x-bit-lsb-first-p image))) + +(defun copy-pixarray (array x y width height bits-per-pixel) + (declare (type pixarray array) + (type card16 x y width height) + (type (member 1 4 8 16 24 32) bits-per-pixel)) + (let* ((bits-per-line (index* bits-per-pixel width)) + (padded-bits-per-line + (index* (index-ceiling bits-per-line *image-pad*) *image-pad*)) + (padded-width (index-ceiling padded-bits-per-line bits-per-pixel)) + (copy (make-array (list height padded-width) + :element-type (array-element-type array)))) + (declare (type array-index bits-per-line padded-bits-per-line padded-width) + (type pixarray copy)) + #.(declare-buffun) + (unless (fast-copy-pixarray array copy x y width height bits-per-pixel) + (macrolet + ((copy (array-type element-type) + `(let ((array array) + (copy copy)) + (declare (type ,array-type array copy)) + (do* ((dst-y 0 (index1+ dst-y)) + (src-y y (index1+ src-y))) + ((index>= dst-y height)) + (declare (type card16 dst-y src-y)) + (do* ((dst-x 0 (index1+ dst-x)) + (src-x x (index1+ src-x))) + ((index>= dst-x width)) + (declare (type card16 dst-x src-x)) + (setf (aref copy dst-y dst-x) + (the ,element-type + (aref array src-y src-x)))))))) + (ecase bits-per-pixel + (1 (copy pixarray-1 pixarray-1-element-type)) + (4 (copy pixarray-4 pixarray-4-element-type)) + (8 (copy pixarray-8 pixarray-8-element-type)) + (16 (copy pixarray-16 pixarray-16-element-type)) + (24 (copy pixarray-24 pixarray-24-element-type)) + (32 (copy pixarray-32 pixarray-32-element-type))))) + copy)) + +(defun image-xy->image-x (image x y width height) + (declare (type image-xy image) + (type card16 x y width height) + (values image-x)) + (let* ((padded-bits-per-line + (index* (index-ceiling width *image-pad*) *image-pad*)) + (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) + (padded-bytes-per-plane (index* padded-bytes-per-line height)) + (bytes-total (index* padded-bytes-per-plane (image-depth image))) + (data (make-array bytes-total :element-type 'card8))) + (declare (type array-index padded-bits-per-line padded-bytes-per-line + padded-bytes-per-plane bytes-total) + (type buffer-bytes data)) + (let ((index 0)) + (declare (type array-index index)) + (dolist (bitmap (image-xy-bitmap-list image)) + (declare (type pixarray-1 bitmap)) + (unless (fast-write-pixarray + data index bitmap x y width height + padded-bytes-per-line 1) + (write-pixarray-1 + data index bitmap x y width height + padded-bytes-per-line)) + (index-incf index padded-bytes-per-plane))) + (create-image + :width width :height height :depth (image-depth image) + :data data :format :xy-pixmap :bits-per-pixel 1 + :bytes-per-line padded-bytes-per-line + :unit *image-unit* :byte-lsb-first-p *image-byte-lsb-first-p* + :bit-lsb-first-p *image-bit-lsb-first-p* :pad *image-pad*))) + +(defun image-xy->image-xy (image x y width height) + (declare (type image-xy image) + (type card16 x y width height) + (values image-xy)) + (create-image + :width width :height height :depth (image-depth image) + :data (mapcar + #'(lambda (array) + (declare (type pixarray-1 array)) + (copy-pixarray array x y width height 1)) + (image-xy-bitmap-list image)))) + +(defun image-xy->image-z (image x y width height) + (declare (type image-z image) + (type card16 x y width height) + (ignore image x y width height)) + (error "Format conversion from ~S to ~S not supported" + :xy-pixmap :z-pixmap)) + +(defun image-z->image-x (image x y width height) + (declare (type image-z image) + (type card16 x y width height) + (values image-x)) + (let* ((bits-per-line (index* width (image-z-bits-per-pixel image))) + (padded-bits-per-line + (index* (index-ceiling bits-per-line *image-pad*) *image-pad*)) + (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) + (bytes-total + (index* padded-bytes-per-line height (image-depth image))) + (data (make-array bytes-total :element-type 'card8))) + (declare (type array-index bits-per-line padded-bits-per-line + padded-bytes-per-line bytes-total) + (type buffer-bytes data)) + (unless (fast-write-pixarray + data 0 (image-z-pixarray image) x y width height + padded-bytes-per-line + (image-z-bits-per-pixel image)) + (funcall + (ecase (image-z-bits-per-pixel image) + (1 #'write-pixarray-1) (4 #'write-pixarray-4) + (8 #'write-pixarray-8) (16 #'write-pixarray-16) + (24 #'write-pixarray-24) (32 #'write-pixarray-32)) + data 0 (image-z-pixarray image) x y width height + padded-bytes-per-line)) + (create-image + :width width :height height :depth (image-depth image) + :data data :format :z-pixmap + :bits-per-pixel (image-z-bits-per-pixel image) + :bytes-per-line padded-bytes-per-line + :unit *image-unit* :byte-lsb-first-p *image-byte-lsb-first-p* + :bit-lsb-first-p *image-bit-lsb-first-p* :pad *image-pad*))) + +(defun image-z->image-xy (image x y width height) + (declare (type image-z image) + (type card16 x y width height) + (ignore image x y width height)) + (error "Format conversion from ~S to ~S not supported" + :z-pixmap :xy-pixmap)) + +(defun image-z->image-z (image x y width height) + (declare (type image-z image) + (type card16 x y width height) + (values image-z)) + (create-image + :width width :height height :depth (image-depth image) + :data (copy-pixarray + (image-z-pixarray image) x y width height + (image-z-bits-per-pixel image)))) + +(defun copy-image (image &key (x 0) (y 0) width height result-type) + ;; Copy with optional sub-imaging and format conversion. + ;; result-type defaults to (type-of image) + (declare (type image image) + (type card16 x y) + (type (or null card16) width height) ;; Default from image + (type (or null (member image-x image-xy image-z)) result-type)) + (declare (values image)) + (let* ((image-width (image-width image)) + (image-height (image-height image)) + (width (or width image-width)) + (height (or height image-height))) + (declare (type card16 image-width image-height width height)) + (unless (index<= 0 x (index1- image-width)) (error "x not inside image")) + (unless (index<= 0 y (index1- image-height)) (error "y not inside image")) + (setq width (index-min width (index-max (index- image-width x) 0))) + (setq height (index-min height (index-max (index- image-height y) 0))) + (let ((copy + (etypecase image + (image-x + (ecase result-type + ((nil image-x) (image-x->image-x image x y width height)) + (image-xy (image-x->image-xy image x y width height)) + (image-z (image-x->image-z image x y width height)))) + (image-xy + (ecase result-type + (image-x (image-xy->image-x image x y width height)) + ((nil image-xy) (image-xy->image-xy image x y width height)) + (image-z (image-xy->image-z image x y width height)))) + (image-z + (ecase result-type + (image-x (image-z->image-x image x y width height)) + (image-xy (image-z->image-xy image x y width height)) + ((nil image-z) (image-z->image-z image x y width height))))))) + (declare (type image copy)) + (setf (image-plist copy) (copy-list (image-plist image))) + (when (and (image-x-hot image) (not (index-zerop x))) + (setf (image-x-hot copy) (index- (image-x-hot image) x))) + (when (and (image-y-hot image) (not (index-zerop y))) + (setf (image-y-hot copy) (index- (image-y-hot image) y))) + copy))) + + +;;;----------------------------------------------------------------------------- +;;; Image I/O functions + + +(defun read-bitmap-file (pathname) + ;; Creates an image from a C include file in standard X11 format + (declare (type (or pathname string stream) pathname)) + (declare (values image)) + (with-open-file (fstream pathname :direction :input) + (let ((line "") + (properties nil) + (name nil) + (name-end nil) + (*package* (find-package 'keyword)) + (*read-base* 10)) + (declare (type string line) + (type stringable name) + (type list properties)) + ;; Get properties + (loop + (setq line (read-line fstream)) + (unless (char= (aref line 0) #\#) (return)) + (flet ((read-keyword (line start end) + (kintern + (substitute + #\- #\_ + (#-excl string-upcase + #+excl correct-case + (subseq line start end)) + :test #'char=)))) + (when (null name) + (setq name-end (position #\_ line :test #'char= :from-end t) + name (read-keyword line 8 name-end)) + (unless (eq name :image) + (setf (getf properties :name) name))) + (let* ((ind-start (index1+ name-end)) + (ind-end (position #\Space line :test #'char= + :start ind-start)) + (ind (read-keyword line ind-start ind-end)) + (val-start (index1+ ind-end)) + (val (parse-integer line :start val-start))) + (setf (getf properties ind) val)))) + ;; Calculate sizes + (multiple-value-bind (width height depth left-pad) + (flet ((extract-property (ind &rest default) + (prog1 (apply #'getf properties ind default) + (remf properties ind)))) + (values (extract-property :width) + (extract-property :height) + (extract-property :depth 1) + (extract-property :left-pad 0))) + (declare (type (or null card16) width height) + (type image-depth depth) + (type card8 left-pad)) + (unless (and width height) (error "Not a BITMAP file")) + (let* ((bits-per-pixel + (cond ((index> depth 24) 32) + ((index> depth 16) 24) + ((index> depth 8) 16) + ((index> depth 4) 8) + ((index> depth 1) 4) + (t 1))) + (bits-per-line (index* width bits-per-pixel)) + (bytes-per-line (index-ceiling bits-per-line 8)) + (padded-bits-per-line + (index* (index-ceiling bits-per-line 32) 32)) + (padded-bytes-per-line + (index-ceiling padded-bits-per-line 8)) + (data (make-array (* padded-bytes-per-line height) + :element-type 'card8)) + (line-base 0) + (byte 0)) + (declare (type array-index bits-per-line bytes-per-line + padded-bits-per-line padded-bytes-per-line + line-base byte) + (type buffer-bytes data)) + (with-vector (data buffer-bytes) + (flet ((parse-hex (char) + (second + (assoc char + '((#\0 0) (#\1 1) (#\2 2) (#\3 3) + (#\4 4) (#\5 5) (#\6 6) (#\7 7) + (#\8 8) (#\9 6) (#\a 10) (#\b 11) + (#\c 12) (#\d 13) (#\e 14) (#\f 15)) + :test #'char-equal)))) + ;; Read data + ;; Note: using read-line instead of read-char would be 20% faster, + ;; but would cons a lot of garbage... + (dotimes (i height) + (dotimes (j bytes-per-line) + (loop (when (eql (read-char fstream) #\x) (return))) + (setf (aref data (index+ line-base byte)) + (index+ (index-ash (parse-hex (read-char fstream)) 4) + (parse-hex (read-char fstream)))) + (incf byte)) + (setq byte 0 + line-base (index+ line-base padded-bytes-per-line))))) + ;; Compensate for left-pad in width and x-hot + (index-decf width left-pad) + (when (getf properties :x-hot) + (index-decf (getf properties :x-hot) left-pad)) + (create-image + :width width :height height + :depth depth :bits-per-pixel bits-per-pixel + :data data :plist properties :format :z-pixmap + :bytes-per-line padded-bytes-per-line + :unit 32 :byte-lsb-first-p t :bit-lsb-first-p t + :pad 32 :left-pad left-pad)))))) + +(defun write-bitmap-file (pathname image &optional name) + ;; Writes an image to a C include file in standard X11 format + ;; NAME argument used for variable prefixes. Defaults to "image" + (declare (type (or pathname string stream) pathname) + (type image image) + (type (or null stringable) name)) + (unless (typep image 'image-x) + (setq image (copy-image image :result-type 'image-x))) + (let* ((plist (image-plist image)) + (name (or name (image-name image) 'image)) + (left-pad (image-x-left-pad image)) + (width (index+ (image-width image) left-pad)) + (height (image-height image)) + (depth + (if (eq (image-x-format image) :z-pixmap) + (image-depth image) + 1)) + (bits-per-pixel (image-x-bits-per-pixel image)) + (bits-per-line (index* width bits-per-pixel)) + (bytes-per-line (index-ceiling bits-per-line 8)) + (last (index* bytes-per-line height)) + (count 0)) + (declare (type list plist) + (type stringable name) + (type card8 left-pad) + (type card16 width height) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type image-depth depth) + (type array-index bits-per-line bytes-per-line count last)) + ;; Move x-hot by left-pad, if there is an x-hot, so image readers that + ;; don't know about left pad get the hot spot in the right place. We have + ;; already increased width by left-pad. + (when (getf plist :x-hot) + (setq plist (copy-list plist)) + (index-incf (getf plist :x-hot) left-pad)) + (with-image-data-buffer (data last) + (if (index> bits-per-pixel 1) + (image-swap-z + (image-x-data image) data 0 0 bytes-per-line + (image-x-bytes-per-line image) bytes-per-line + height bits-per-pixel + (image-x-byte-lsb-first-p image) t) + (image-swap-xy + (image-x-data image) data 0 0 bytes-per-line + (image-x-bytes-per-line image) bytes-per-line + height + (image-x-unit image) (image-x-byte-lsb-first-p image) + (image-x-bit-lsb-first-p image) + 32 t t)) + (with-vector (data buffer-bytes) + (setq name (string-downcase (string name))) + (with-open-file (fstream pathname :direction :output) + (format fstream "#define ~a_width ~d~%" name width) + (format fstream "#define ~a_height ~d~%" name height) + (unless (= depth 1) + (format fstream "#define ~a_depth ~d~%" name depth)) + (unless (zerop left-pad) + (format fstream "#define ~a_left_pad ~d~%" name left-pad)) + (do ((prop plist (cddr prop))) + ((endp prop)) + (when (and (not (member (car prop) '(:width :height))) + (numberp (cadr prop))) + (format fstream "#define ~a_~a ~d~%" + name + (substitute + #\_ #\- (string-downcase (string (car prop))) + :test #'char=) + (cadr prop)))) + (format fstream "static char ~a_bits[] = {" name) + (dotimes (i height) + (dotimes (j bytes-per-line) + (when (zerop (index-mod count 15)) + (terpri fstream) + (write-char #\space fstream)) + (write-string "0x" fstream) + ;; Faster than (format fstream "0x~2,'0x," byte) + (let ((byte (aref data count)) + (translate "0123456789abcdef")) + (declare (type card8 byte)) + (write-char (char translate (ldb (byte 4 4) byte)) fstream) + (write-char (char translate (ldb (byte 4 0) byte)) fstream)) + (index-incf count) + (unless (index= count last) + (write-char #\, fstream)))) + (format fstream "};~%" fstream)))))) + +(defun bitmap-image (&optional plist &rest patterns) + ;; Create an image containg pattern + ;; PATTERNS are bit-vector constants (e.g. #*10101) + ;; If the first parameter is a list, its used as the image property-list. + (declare (type (or list bit-vector) plist) + (type list patterns)) ;; list of bitvector + (declare (values image)) + (unless (listp plist) + (push plist patterns) + (setq plist nil)) + (let* ((width (length (first patterns))) + (height (length patterns)) + (bitarray (make-array (list height width) :element-type 'bit)) + (row 0)) + (declare (type card16 width height row) + (type pixarray-1 bitarray)) + (dolist (pattern patterns) + (declare (type simple-bit-vector pattern)) + (dotimes (col width) + (declare (type card16 col)) + (setf (aref bitarray row col) (the bit (aref pattern col)))) + (incf row)) + (create-image :width width :height height :plist plist :data bitarray))) + +(defun image-pixmap (drawable image &key gcontext width height depth) + ;; Create a pixmap containing IMAGE. Size defaults from the image. + ;; DEPTH is the pixmap depth. + ;; GCONTEXT is used for putting the image into the pixmap. + ;; If none is supplied, then one is created, used then freed. + (declare (type drawable drawable) + (type image image) + (type (or null gcontext) gcontext) + (type (or null card16) width height) + (type (or null card8) depth)) + (declare (values pixmap)) + (let* ((image-width (image-width image)) + (image-height (image-height image)) + (image-depth (image-depth image)) + (width (or width image-width)) + (height (or height image-height)) + (depth (or depth image-depth)) + (pixmap (create-pixmap :drawable drawable + :width width + :height height + :depth depth)) + (gc (or gcontext (create-gcontext + :drawable pixmap + :foreground 1 + :background 0)))) + (unless (= depth image-depth) + (if (= image-depth 1) + (unless gcontext (xlib::required-arg gcontext)) + (error "Pixmap depth ~d incompatable with image depth ~d" + depth image-depth))) + (put-image pixmap gc image :x 0 :y 0 :bitmap-p (and (= image-depth 1) gcontext)) + ;; Tile when image-width is less than the pixmap width, or + ;; the image-height is less than the pixmap height. + ;; ??? Would it be better to create a temporary pixmap and + ;; ??? let the server do the tileing? + (do ((x image-width (+ x image-width))) + ((>= x width)) + (copy-area pixmap gc 0 0 image-width image-height pixmap x 0) + (incf image-width image-width)) + (do ((y image-height (+ y image-height))) + ((>= y height)) + (copy-area pixmap gc 0 0 image-width image-height pixmap 0 y) + (incf image-height image-height)) + (unless gcontext (free-gcontext gc)) + pixmap)) + diff --git a/clx/input.lisp b/clx/input.lisp new file mode 100644 index 000000000..b2ed08220 --- /dev/null +++ b/clx/input.lisp @@ -0,0 +1,1927 @@ +;;; -*- 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) + +(export '( + event-listen + queue-event + process-event + make-event-handlers + event-handler + event-case + event-cond + discard-current-event + request-error + value-error + window-error + pixmap-error + atom-error + cursor-error + font-error + match-error + drawable-error + access-error + alloc-error + colormap-error + gcontext-error + id-choice-error + name-error + length-error + implementation-error + request-error + resource-error + unknown-error + access-error + alloc-error + atom-error + colormap-error + cursor-error + drawable-error + font-error + gcontext-error + id-choice-error + illegal-request-error + length-error + match-error + name-error + pixmap-error + value-error + window-error + implementation-error + #-ansi-common-lisp type-error + closed-display + lookup-error + connection-failure + reply-length-error + reply-timeout + sequence-error + unexpected-reply + missing-parameter + invalid-font + device-busy + get-external-event-code + define-extension + extension-opcode + define-error + decode-core-error + declare-event + )) + +;; 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 (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 (values (or nil 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 (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. + (declare (type display display) + (type stringable name)) + (declare (values card8)) + (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))))) + ;; 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 boolean force-output-p) + (dynamic-extent predicate-args)) + (declare (type function predicate) + (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) + (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 boolean force-output-p)) + (let ((event-process-p (not (eql timeout 0)))) + (declare (type 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) + (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 (or 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 (or current-event (display-event-queue-head display)) + 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-event-queue-head 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 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) + ;; 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. + (subst display '%buffer + (getf `(:display (the display ,display) + :event-key (the keyword ,event-key) + :event-code (the card8 (logand #x7f (read-card8 0))) + :send-event-p (the boolean (logbitp 7 (read-card8 0))) + ,@',(mapcar #'macroexpand get-code)) + variable))) + + (defun ,get-function (display event handler) + (declare (type display display) + (type reply-buffer event)) + (declare (type function handler) + (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) + (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) + (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) + (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 + (card32 time) + ((member16 :new-value :deleted) state)) + +(declare-event :selection-clear + (card16 sequence) + (card32 time) + (window (window event-window)) + (keyword selection) ;; keyword + ) + +(declare-event :selection-request + (card16 sequence) + (card32 time) + (window (window event-window) requestor) + (keyword selection target) + ((or null keyword) property) + ) + +(declare-event :selection-notify + (card16 sequence) + (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) + (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 boolean force-output-p) + (type symbol current-event-symbol) + (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))) + +(defvar *event-loop-version* 0) + +(defun dequeue-event (display event) + (declare (type display display) + (type reply-buffer event) + (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 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) + (ecase *event-loop-version* + ;; in version 0 discard-current-event dequeues the event. + (0 ) + ;; in version 1 event-loop-step-after dequeues the event. + (1 (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 ((*event-loop-version* 1) + (.display. ,display) + (.timeout. ,timeout) + (.force-output-p. ,force-output-p) + (.discard-p. ,discard-p)) + (declare (type display .display.) + (type (or null number) .timeout.) + (type 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) + (values 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) + (ecase *event-loop-version* + ;; in version 0 discard-current-event dequeues the event. + (0 (setf (reply-next (the reply-buffer event)) + (dequeue-event display event))) + ;; in version 1 event-loop-step-after dequeues the event. + (1 )) + ;; 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 boolean peek-p discard-p force-output-p)) + (declare (type t handler) + (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) + (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) + (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) + (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 (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 + (the boolean (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 #'(lambda (var) (list var)) 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 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 ansi-common-lisp excl lcl3.0) +(define-condition request-error (x-error) + (display + error-key + major + minor + sequence + current-sequence + 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 ansi-common-lisp excl lcl3.0) +(define-condition request-error (x-error) + (display + error-key + major + minor + sequence + current-sequence + asynchronous) + (:report report-request-error)) + +(define-condition resource-error (request-error) + (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) + (: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) + (: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) + (: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) + (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) + (:report (lambda (condition stream) + (format stream "Attempt to use closed display ~s" + (closed-display-display condition))))) + +(define-condition lookup-error (x-error) + (id display type 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 + minor-version + host + display + 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 + expected-length + 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 + 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 + req-sequence + 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 + msg-sequence + req-sequence + 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) + (: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) + (:report (lambda (condition stream) + (format stream "Can't access font ~s" (invalid-font-font condition))))) + +(define-condition device-busy (x-error) + (display) + (:report (lambda (condition stream) + (format stream "Device busy for display ~s" + (device-busy-display condition))))) + +(define-condition unimplemented-event (x-error) + (display + 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 + 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 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) + (: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 function 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 (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/clx/keysyms.lisp b/clx/keysyms.lisp new file mode 100644 index 000000000..96d160b83 --- /dev/null +++ b/clx/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/clx/macros.lisp b/clx/macros.lisp new file mode 100644 index 000000000..fa829cdb2 --- /dev/null +++ b/clx/macros.lisp @@ -0,0 +1,1078 @@ +;;; -*- 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. +;;; + +;;; CLX basicly implements a very low overhead remote procedure call +;;; to the server. This file contains macros which generate the code +;;; for both the client AND the server, given a specification of the +;;; interface. This was done to eliminate errors that may occur because +;;; the client and server code get/put bytes in different places, and +;;; it makes it easier to extend the protocol. + +;;; This is built on top of BUFFER + +(in-package :xlib) + +;;; This variable is used by the required-arg macro just to satisfy compilers. +(defvar *required-arg-dummy*) + +;;; An error signalling macro use to specify that keyword arguments are required. +(defmacro required-arg (name) + `(progn (x-error 'missing-parameter :parameter ',name) + *required-arg-dummy*)) + +(defmacro lround (index) + ;; Round up to the next 32 bit boundary + `(the array-index (logand (index+ ,index 3) -4))) + +(defmacro wround (index) + ;; Round up to the next 16 bit boundary + `(the array-index (logand (index+ ,index 1) -2))) + +;; +;; Data-type accessor functions +;; +;; These functions translate between lisp data-types and the byte, +;; half-word or word that gets transmitted across the client/server +;; connection + +(defun index-increment (type) + ;; Given a type, return its field width in bytes + (let* ((name (if (consp type) (car type) type)) + (increment (get name 'byte-width :not-found))) + (when (eq increment :not-found) + ;; Check for TYPE in a different package + (when (not (eq (symbol-package name) (find-package 'xlib))) + (setq name (xintern name)) + (setq increment (get name 'byte-width :not-found))) + (when (eq increment :not-found) + (error "~s isn't a known field accessor" name))) + increment)) + +(eval-when (eval compile load) +(defun getify (name) + (xintern name '-get)) + +(defun putify (name &optional predicate-p) + (xintern name '-put (if predicate-p '-predicating ""))) + + ;; Use &body so zmacs indents properly +(defmacro define-accessor (name (width) &body get-put-macros) + ;; The first body form defines the get macro + ;; The second body form defines the put macro + ;; The third body form is optional, and defines a put macro that does + ;; type checking and does a put when ok, else NIL when the type is incorrect. + ;; If no third body form is present, then these macros assume that + ;; (AND (TYPEP ,thing 'type) (PUT-type ,thing)) can be generated. + ;; these predicating puts are used by the OR accessor. + (declare (arglist name (width) get-macro put-macro &optional predicating-put-macro)) + (when (cdddr get-put-macros) + (error "Too many parameters to define-accessor: ~s" (cdddr get-put-macros))) + (let ((get-macro (or (first get-put-macros) (error "No GET macro form for ~s" name))) + (put-macro (or (second get-put-macros) (error "No PUT macro form for ~s" name)))) + `(within-definition (,name define-accessor) + (setf (get ',name 'byte-width) ,(and width (floor width 8))) + (defmacro ,(getify name) ,(car get-macro) + ,@(cdr get-macro)) + (defmacro ,(putify name) ,(car put-macro) + ,@(cdr put-macro)) + ,@(when *type-check?* + (let ((predicating-put (third get-put-macros))) + (when predicating-put + `((setf (get ',name 'predicating-put) t) + (defmacro ,(putify name t) ,(car predicating-put) + ,@(cdr predicating-put))))))))) +) ;; End eval-when + +(define-accessor card32 (32) + ((index) `(read-card32 ,index)) + ((index thing) `(write-card32 ,index ,thing))) + +(define-accessor card29 (32) + ((index) `(read-card29 ,index)) + ((index thing) `(write-card29 ,index ,thing))) + +(define-accessor card16 (16) + ((index) `(read-card16 ,index)) + ((index thing) `(write-card16 ,index ,thing))) + +(define-accessor card8 (8) + ((index) `(read-card8 ,index)) + ((index thing) `(write-card8 ,index ,thing))) + +(define-accessor integer (32) + ((index) `(read-int32 ,index)) + ((index thing) `(write-int32 ,index ,thing))) + +(define-accessor int16 (16) + ((index) `(read-int16 ,index)) + ((index thing) `(write-int16 ,index ,thing))) + +(define-accessor rgb-val (16) + ;; Used for color's + ((index) `(card16->rgb-val (read-card16 ,index))) + ((index thing) `(write-card16 ,index (rgb-val->card16 ,thing)))) + +(define-accessor angle (16) + ;; Used for drawing arcs + ((index) `(int16->radians (read-int16 ,index))) + ((index thing) `(write-int16 ,index (radians->int16 ,thing)))) + +(define-accessor bit (0) + ;; Like BOOLEAN, but tests bits + ;; only used by declare-event (:enter-notify :leave-notify) + ((index bit) + `(logbitp ,bit (read-card8 ,index))) + ((index thing bit) + (if (zerop bit) + `(write-card8 ,index (if ,thing 1 0)) + `(write-card8 ,index (dpb (if ,thing 1 0) (byte 1 ,bit) (read-card8 ,index)))))) + +(define-accessor boolean (8) + ((index) + `(plusp (read-card8 ,index))) + ((index thing) `(write-card8 ,index (if ,thing 1 0)))) + +(define-accessor drawable (32) + ((index &optional (buffer '%buffer)) + `(lookup-drawable ,buffer (read-card29 ,index))) + ((index thing) `(write-card29 ,index (drawable-id ,thing)))) + +(define-accessor window (32) + ((index &optional (buffer '%buffer)) + `(lookup-window ,buffer (read-card29 ,index))) + ((index thing) `(write-card29 ,index (window-id ,thing)))) + +(define-accessor pixmap (32) + ((index &optional (buffer '%buffer)) + `(lookup-pixmap ,buffer (read-card29 ,index))) + ((index thing) `(write-card29 ,index (pixmap-id ,thing)))) + +(define-accessor gcontext (32) + ((index &optional (buffer '%buffer)) + `(lookup-gcontext ,buffer (read-card29 ,index))) + ((index thing) `(write-card29 ,index (gcontext-id ,thing)))) + +(define-accessor cursor (32) + ((index &optional (buffer '%buffer)) + `(lookup-cursor ,buffer (read-card29 ,index))) + ((index thing) `(write-card29 ,index (cursor-id ,thing)))) + +(define-accessor colormap (32) + ((index &optional (buffer '%buffer)) + `(lookup-colormap ,buffer (read-card29 ,index))) + ((index thing) `(write-card29 ,index (colormap-id ,thing)))) + +(define-accessor font (32) + ((index &optional (buffer '%buffer)) + `(lookup-font ,buffer (read-card29 ,index))) + ;; The FONT-ID accessor may make a OpenFont request. Since we don't support recursive + ;; with-buffer-request, issue a compile time error, rather than barf at run-time. + ((index thing) + (declare (ignore index thing)) + (error "FONT-ID must be called OUTSIDE with-buffer-request. Use RESOURCE-ID instead."))) + +;; Needed to get and put xatom's in events +(define-accessor keyword (32) + ((index &optional (buffer '%buffer)) + `(atom-name ,buffer (read-card29 ,index))) + ((index thing &key (buffer '%buffer)) + `(write-card29 ,index (or (atom-id ,thing ,buffer) + (error "CLX implementation error in KEYWORD-PUT"))))) + +(define-accessor resource-id (32) + ((index) `(read-card29 ,index)) + ((index thing) `(write-card29 ,index ,thing))) + +(define-accessor resource-id-or-nil (32) + ((index) (let ((id (gensym))) + `(let ((,id (read-card29 ,index))) + (and (plusp ,id) ,id)))) + ((index thing) `(write-card29 ,index (or ,thing 0)))) + +(defmacro char-info-get (index) + `(make-char-info + :left-bearing (int16-get ,index) + :right-bearing (int16-get ,(+ index 2)) + :width (int16-get ,(+ index 4)) + :ascent (int16-get ,(+ index 6)) + :descent (int16-get ,(+ index 8)) + :attributes (card16-get ,(+ index 10)))) + +(define-accessor member8 (8) + ((index &rest keywords) + (let ((value (gensym))) + `(let ((,value (read-card8 ,index))) + (and (< ,value ,(length keywords)) + (svref ',(apply #'vector keywords) ,value))))) + ((index thing &rest keywords) + `(write-card8 ,index (position ,thing + #+lispm ',keywords ;; Lispm's prefer lists + #-lispm (the simple-vector ',(apply #'vector keywords)) + :test #'eq))) + ((index thing &rest keywords) + (let ((value (gensym))) + `(let ((,value (position ,thing + #+lispm ',keywords + #-lispm (the simple-vector ',(apply #'vector keywords)) + :test #'eq))) + (and ,value (write-card8 ,index ,value)))))) + +(define-accessor member16 (16) + ((index &rest keywords) + (let ((value (gensym))) + `(let ((,value (read-card16 ,index))) + (and (< ,value ,(length keywords)) + (svref ',(apply #'vector keywords) ,value))))) + ((index thing &rest keywords) + `(write-card16 ,index (position ,thing + #+lispm ',keywords ;; Lispm's prefer lists + #-lispm (the simple-vector ',(apply #'vector keywords)) + :test #'eq))) + ((index thing &rest keywords) + (let ((value (gensym))) + `(let ((,value (position ,thing + #+lispm ',keywords + #-lispm (the simple-vector ',(apply #'vector keywords)) + :test #'eq))) + (and ,value (write-card16 ,index ,value)))))) + +(define-accessor member (32) + ((index &rest keywords) + (let ((value (gensym))) + `(let ((,value (read-card29 ,index))) + (and (< ,value ,(length keywords)) + (svref ',(apply #'vector keywords) ,value))))) + ((index thing &rest keywords) + `(write-card29 ,index (position ,thing + #+lispm ',keywords ;; Lispm's prefer lists + #-lispm (the simple-vector ',(apply #'vector keywords)) + :test #'eq))) + ((index thing &rest keywords) + (if (cdr keywords) ;; IF more than one + (let ((value (gensym))) + `(let ((,value (position ,thing + #+lispm ',keywords + #-lispm (the simple-vector ',(apply #'vector keywords)) + :test #'eq))) + (and ,value (write-card29 ,index ,value)))) + `(and (eq ,thing ,(car keywords)) (write-card29 ,index 0))))) + +(deftype member-vector (vector) `(member ,@(coerce (symbol-value vector) 'list))) + +(define-accessor member-vector (32) + ((index membership-vector) + `(member-get ,index ,@(coerce (eval membership-vector) 'list))) + ((index thing membership-vector) + `(member-put ,index ,thing ,@(coerce (eval membership-vector) 'list))) + ((index thing membership-vector) + `(member-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))) + +(define-accessor member16-vector (16) + ((index membership-vector) + `(member16-get ,index ,@(coerce (eval membership-vector) 'list))) + ((index thing membership-vector) + `(member16-put ,index ,thing ,@(coerce (eval membership-vector) 'list))) + ((index thing membership-vector) + `(member16-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))) + +(define-accessor member8-vector (8) + ((index membership-vector) + `(member8-get ,index ,@(coerce (eval membership-vector) 'list))) + ((index thing membership-vector) + `(member8-put ,index ,thing ,@(coerce (eval membership-vector) 'list))) + ((index thing membership-vector) + `(member8-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))) + +(define-accessor boole-constant (32) + ;; this isn't member-vector because we need eql instead of eq + ((index) + (let ((value (gensym))) + `(let ((,value (read-card29 ,index))) + (and (< ,value ,(length *boole-vector*)) + (svref *boole-vector* ,value))))) + ((index thing) + `(write-card29 ,index (position ,thing (the simple-vector *boole-vector*)))) + ((index thing) + (let ((value (gensym))) + `(let ((,value (position ,thing (the simple-vector *boole-vector*)))) + (and ,value (write-card29 ,index ,value)))))) + +(define-accessor null (32) + ((index) `(if (zerop (read-card32 ,index)) nil (read-card32 ,index))) + ((index value) (declare (ignore value)) `(write-card32 ,index 0))) + +(define-accessor pad8 (8) + ((index) (declare (ignore index)) nil) + ((index value) (declare (ignore index value)) nil)) + +(define-accessor pad16 (16) + ((index) (declare (ignore index)) nil) + ((index value) (declare (ignore index value)) nil)) + +(define-accessor bit-vector256 (256) + ;; used for key-maps + ;; REAL-INDEX parameter provided so the default index can be over-ridden. + ;; This is needed for the :keymap-notify event where the keymap overlaps + ;; the window id. + ((index &optional (real-index index) data) + `(read-bitvector256 buffer-bbuf ,real-index ,data)) + ((index map &optional (real-index index) (buffer '%buffer)) + `(write-bitvector256 ,buffer (index+ buffer-boffset ,real-index) ,map))) + +(define-accessor string (nil) + ((length index &key reply-buffer) + `(read-sequence-char + ,(or reply-buffer '%reply-buffer) 'string ,length nil nil 0 ,index)) + ((index string &key buffer (start 0) end header-length appending) + (unless buffer (setq buffer '%buffer)) + (unless header-length (setq header-length (lround index))) + (let* ((real-end (if appending (or end `(length ,string)) (gensym))) + (form `(write-sequence-char ,buffer (index+ buffer-boffset ,header-length) + ,string ,start ,real-end))) + (if appending + form + `(let ((,real-end ,(or end `(length ,string)))) + (write-card16 2 (index-ceiling (index+ (index- ,real-end ,start) ,header-length) 4)) + ,form))))) + +(define-accessor sequence (nil) + ((&key length (format 'card32) result-type transform reply-buffer data index start) + `(,(ecase format + (card8 'read-sequence-card8) + (int8 'read-sequence-int8) + (card16 'read-sequence-card16) + (int16 'read-sequence-int16) + (card32 'read-sequence-card32) + (int32 'read-sequence-int32)) + ,(or reply-buffer '%reply-buffer) + ,result-type ,length ,transform ,data + ,@(when (or start index) `(,(or start 0))) + ,@(when index `(,index)))) + ((index data &key (format 'card32) (start 0) end transform buffer appending) + (unless buffer (setq buffer '%buffer)) + (let* ((real-end (if appending (or end `(length ,data)) (gensym))) + (writer (xintern 'write-sequence- format)) + (form `(,writer ,buffer (index+ buffer-boffset ,(lround index)) + ,data ,start ,real-end ,transform))) + (flet ((maker (size) + (if appending + form + (let ((idx `(index- ,real-end ,start))) + (unless (= size 1) + (setq idx `(index-ceiling ,idx ,size))) + `(let ((,real-end ,(or end `(length ,data)))) + (write-card16 2 (index+ ,idx ,(index-ceiling index 4))) + ,form))))) + (ecase format + ((card8 int8) + (maker 4)) + ((card16 int16) + (maker 2)) + ((card32 int32) + (maker 1))))))) + +(defmacro client-message-event-get-sequence () + '(let* ((format (read-card8 1)) + (sequence (make-array (ceiling 160 format) + :element-type `(unsigned-byte ,format)))) + (do ((i 12) + (j 0 (1+ j))) + ((>= i 32)) + (case format + (8 (setf (aref sequence j) (read-card8 i)) + (incf i)) + (16 (setf (aref sequence j) (read-card16 i)) + (incf i 2)) + (32 (setf (aref sequence j) (read-card32 i)) + (incf i 4)))) + sequence)) + +(defmacro client-message-event-put-sequence (format sequence) + `(ecase ,format + (8 (sequence-put 12 ,sequence + :format card8 + :end (min (length ,sequence) 20) + :appending t)) + (16 (sequence-put 12 ,sequence + :format card16 + :end (min (length ,sequence) 10) + :appending t)) + (32 (sequence-put 12 ,sequence + :format card32 + :end (min (length ,sequence) 5) + :appending t)))) + +;; Used only in declare-event +(define-accessor client-message-sequence (160) + ((index format) (declare (ignore index format)) `(client-message-event-get-sequence)) + ((index value format) (declare (ignore index)) + `(client-message-event-put-sequence ,format ,value))) + + +;;; +;;; Compound accessors +;;; Accessors that take other accessors as parameters +;;; +(define-accessor code (0) + ((index) (declare (ignore index)) '(read-card8 0)) + ((index value) (declare (ignore index)) `(write-card8 0 ,value)) + ((index value) (declare (ignore index)) `(write-card8 0 ,value))) + +(define-accessor length (0) + ((index) (declare (ignore index)) '(read-card16 2)) + ((index value) (declare (ignore index)) `(write-card16 2 ,value)) + ((index value) (declare (ignore index)) `(write-card16 2 ,value))) + +(deftype data () 'card8) + +(define-accessor data (0) + ;; Put data in byte 1 of the reqeust + ((index &optional stuff) (declare (ignore index)) + (if stuff + (if (consp stuff) + `(,(getify (car stuff)) 1 ,@(cdr stuff)) + `(,(getify stuff) 1)) + `(read-card8 1))) + ((index thing &optional stuff) + (if stuff + (if (consp stuff) + `(macrolet ((write-card32 (index value) index value)) + (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff)))) + `(,(putify stuff) 1 ,thing)) + `(write-card8 1 ,thing))) + ((index thing &optional stuff) + (if stuff + `(and (type? ,thing ',stuff) + ,(if (consp stuff) + `(macrolet ((write-card32 (index value) index value)) + (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff)))) + `(,(putify stuff) 1 ,thing))) + `(and (type? ,thing 'card8) (write-card8 1 ,thing))))) + +;; Macroexpand the result of OR-GET to allow the macros file to not be loaded +;; when using event-case. This is pretty gross. + +(defmacro or-expand (&rest forms &environment environment) + `(cond ,@(mapcar #'(lambda (forms) + (mapcar #'(lambda (form) + (macroexpand form environment)) + forms)) + forms))) + +;; +;; the OR type +;; +(define-accessor or (32) + ;; Select from among several types (usually NULL and something else) + ((index &rest type-list &environment environment) + (do ((types type-list (cdr types)) + (value (gensym)) + (result)) + ((endp types) + `(let ((,value (read-card32 ,index))) + (macrolet ((read-card32 (index) index ',value) + (read-card29 (index) index ',value)) + ,(macroexpand `(or-expand ,@(nreverse result)) environment)))) + (let ((item (car types)) + (args nil)) + (when (consp item) + (setq args (cdr item) + item (car item))) + (if (eq item 'null) ;; Special case for NULL + (push `((zerop ,value) nil) result) + (push + `((,(getify item) ,index ,@args)) + result))))) + + ((index value &rest type-list) + (do ((types type-list (cdr types)) + (result)) + ((endp types) + `(cond ,@(nreverse result) + ,@(when *type-check?* + `((t (x-type-error ,value '(or ,@type-list))))))) + (let* ((type (car types)) + (type-name type) + (args nil)) + (when (consp type) + (setq args (cdr type) + type-name (car type))) + (push + `(,@(cond ((get type-name 'predicating-put) nil) + ((or *type-check?* (cdr types)) `((type? ,value ',type))) + (t '(t))) + (,(putify type-name (get type-name 'predicating-put)) ,index ,value ,@args)) + result))))) + +;; +;; the MASK type... +;; is used to specify a subset of a collection of "optional" arguments. +;; A mask type consists of a 32 bit mask word followed by a word for each one-bit +;; in the mask. The MASK type is ALWAYS the LAST item in a request. +;; +(setf (get 'mask 'byte-width) nil) + +(defun mask-get (index type-values body-function) + (declare (type function body-function) + (downward-funarg body-function)) + ;; This is a function, because it must return more than one form (called by get-put-items) + ;; Functions that use this must have a binding for %MASK + (let* ((bit 0) + (result + (mapcar + #'(lambda (form) + (if (atom form) + form ;; Hack to allow BODY-FUNCTION to return keyword/value pairs + (prog1 + `(when (logbitp ,bit %mask) + ;; Execute form when bit is set + ,form) + (incf bit)))) + (get-put-items + (+ index 4) type-values nil + #'(lambda (type index item args) + (declare (ignore index)) + (funcall body-function type '(* (incf %index) 4) item args)))))) + ;; First form must load %MASK + `(,@(when (atom (car result)) + (list (pop result))) + (progn (setq %mask (read-card32 ,index)) + (setq %index ,(ceiling index 4)) + ,(car result)) + ,@(cdr result)))) + +;; MASK-PUT + +(defun mask-put (index type-values body-function) + (declare (type function body-function) + (downward-funarg body-function)) + ;; The MASK type writes a 32 bit mask with 1 bits for each non-nil value in TYPE-VALUES + ;; A 32 bit value follows for each non-nil value. + `((let ((%mask 0) + (%index ,index)) + ,@(let ((bit 1)) + (get-put-items + index type-values t + #'(lambda (type index item args) + (declare (ignore index)) + (if (or (symbolp item) (constantp item)) + `((unless (null ,item) + (setq %mask (logior %mask ,(shiftf bit (ash bit 1)))) + ,@(funcall body-function type + `(index-incf %index 4) item args))) + `((let ((.item. ,item)) + (unless (null .item.) + (setq %mask (logior %mask ,(shiftf bit (ash bit 1)))) + ,@(funcall body-function type + `(index-incf %index 4) '.item. args)))))))) + (write-card32 ,index %mask) + (write-card16 2 (index-ceiling (index-incf %index 4) 4)) + (incf (buffer-boffset %buffer) %index)))) + +(define-accessor progn (nil) + ;; Catch-all for inserting random code + ;; Note that code using this is then responsible for setting the request length + ((index statement) (declare (ignore index)) statement) + ((index statement) (declare (ignore index)) statement)) + + +; +; Wrapper macros, for use around the above +; +(defmacro type-check (value type) + value type + (when *type-check?* + `(unless (type? ,value ,type) + (x-type-error ,value ,type)))) + +(defmacro check-put (index value type &rest args &environment env) + (let* ((var (if (or (symbolp value) (constantp value)) value '.value.)) + (body + (if (or (null (macroexpand `(type-check ,var ',type) env)) + (member type '(or progn pad8 pad16)) + (constantp value)) + `(,(putify type) ,index ,var ,@args) + ;; Do type checking + (if (get type 'predicating-put) + `(or (,(putify type t) ,index ,var ,@args) + (x-type-error ,var ',(if args `(,type ,@args) type))) + `(if (type? ,var ',type) + (,(putify type) ,index ,var ,@args) + (x-type-error ,var ',(if args `(,type ,@args) type))))))) + (if (eq var value) + body + `(let ((,var ,value)) + ,body)))) + +(defun get-put-items (index type-args putp &optional body-function) + (declare (type (or null function) body-function) + (downward-funarg body-function)) + ;; Given a lists of the form (type item item ... item) + ;; Calls body-function with four arguments, a function name, + ;; index, item name, and optional arguments. + ;; The results are appended together and retured. + (unless body-function + (setq body-function + #'(lambda (type index item args) + `((check-put ,index ,item ,type ,@args))))) + (do* ((items type-args (cdr items)) + (type (caar items) (caar items)) + (args nil nil) + (result nil) + (sizes nil)) + ((endp items) (values result index sizes)) + (when (consp type) + (setq args (cdr type) + type (car type))) + (cond ((member type '(return buffer))) + ((eq type 'mask) ;; Hack to enable mask-get/put to return multiple values + (setq result + (append result (if putp + (mask-put index (cdar items) body-function) + (mask-get index (cdar items) body-function))) + index nil)) + (t (do* ((item (cdar items) (cdr item)) + (increment (index-increment type))) + ((endp item)) + (when (constantp index) + (case increment ;Round up index when needed + (2 (setq index (wround index))) + (4 (setq index (lround index))))) + (setq result + (append result (funcall body-function type index (car item) args))) + (when (constantp index) + ;; Variable length requests have null length increment. + ;; Variable length requests set the request size + ;; & maintain buffer pointers + (if (null increment) + (setq index nil) + (progn + (incf index increment) + (when (and increment (zerop increment)) (setq increment 1)) + (pushnew (* increment 8) sizes))))))))) + +(defmacro with-buffer-request-internal + ((buffer opcode &key length sizes &allow-other-keys) + &body type-args) + (declare (values request-number)) + (multiple-value-bind (code index item-sizes) + (get-put-items 4 type-args t) + (let ((length (if length `(index+ ,length *requestsize*) '*requestsize*)) + (sizes (remove-duplicates (append '(8 16) item-sizes sizes)))) + `(with-buffer-output (,buffer :length ,length :sizes ,sizes) + (setf (buffer-last-request ,buffer) buffer-boffset) + (write-card8 0 ,opcode) ;; Stick in the opcode + ,@code + ,@(when index + (setq index (lround index)) + `((write-card16 2 ,(ceiling index 4)) + (setf (buffer-boffset ,buffer) (index+ buffer-boffset ,index)))) + (buffer-new-request-number ,buffer))))) + +(defmacro with-buffer-request + ((buffer opcode &rest options &key inline gc-force &allow-other-keys) + &body type-args &environment env) + (declare (values request-number)) + (if (and (null inline) (macroexpand '(use-closures) env)) + `(flet ((.request-body. (.display.) + (declare (type display .display.)) + (with-buffer-request-internal (.display. ,opcode ,@options) + ,@type-args))) + #+ansi-common-lisp + (declare (dynamic-extent #'.request-body.)) + (,(if (eq (car (macroexpand '(with-buffer (buffer)) env)) 'progn) + 'with-buffer-request-function-nolock + 'with-buffer-request-function) + ,buffer ,gc-force #'.request-body.)) + `(let ((.display. ,buffer)) + (declare (type display .display.)) + (with-buffer (.display.) + ,@(when gc-force `((force-gcontext-changes-internal ,gc-force))) + (multiple-value-prog1 + (without-aborts + (with-buffer-request-internal (.display. ,opcode ,@options) + ,@type-args)) + (display-invoke-after-function .display.)))))) + +(defmacro with-buffer-request-and-reply + ((buffer opcode reply-size &key sizes multiple-reply inline) + type-args &body reply-forms &environment env) + (declare (indentation 0 4 1 4 2 1)) + (let* ((inner-reply-body + `(with-buffer-input (.reply-buffer. :display .display. + ,@(and sizes (list :sizes sizes))) + nil ,@reply-forms)) + (reply-body + (if (or (not (symbolp reply-size)) (constantp reply-size)) + inner-reply-body + `(let ((,reply-size (reply-data-size (the reply-buffer .reply-buffer.)))) + (declare (type array-index ,reply-size)) + ,inner-reply-body)))) + (if (and (null inline) (macroexpand '(use-closures) env)) + `(flet ((.request-body. (.display.) + (declare (type display .display.)) + (with-buffer-request-internal (.display. ,opcode) + ,@type-args)) + (.reply-body. (.display. .reply-buffer.) + (declare (type display .display.) + (type reply-buffer .reply-buffer.)) + (progn .display. .reply-buffer. nil) + ,reply-body)) + #+ansi-common-lisp + (declare (dynamic-extent #'.request-body. #'.reply-body.)) + (with-buffer-request-and-reply-function + ,buffer ,multiple-reply #'.request-body. #'.reply-body.)) + `(let ((.display. ,buffer) + (.pending-command. nil) + (.reply-buffer. nil)) + (declare (type display .display.) + (type (or null pending-command) .pending-command.) + (type (or null reply-buffer) .reply-buffer.)) + (unwind-protect + (progn + (with-buffer (.display.) + (setq .pending-command. (start-pending-command .display.)) + (without-aborts + (with-buffer-request-internal (.display. ,opcode) + ,@type-args)) + (buffer-force-output .display.) + (display-invoke-after-function .display.)) + ,@(if multiple-reply + `((loop + (setq .reply-buffer. (read-reply .display. .pending-command.)) + (when ,reply-body (return nil)) + (deallocate-reply-buffer (shiftf .reply-buffer. nil)))) + `((setq .reply-buffer. (read-reply .display. .pending-command.)) + ,reply-body))) + (when .reply-buffer. + (deallocate-reply-buffer .reply-buffer.)) + (when .pending-command. + (stop-pending-command .display. .pending-command.))))))) + +(defmacro compare-request ((index) &body body) + `(macrolet ((write-card32 (index item) `(= ,item (read-card32 ,index))) + (write-int32 (index item) `(= ,item (read-int32 ,index))) + (write-card29 (index item) `(= ,item (read-card29 ,index))) + (write-int29 (index item) `(= ,item (read-int29 ,index))) + (write-card16 (index item) `(= ,item (read-card16 ,index))) + (write-int16 (index item) `(= ,item (read-int16 ,index))) + (write-card8 (index item) `(= ,item (read-card8 ,index))) + (write-int8 (index item) `(= ,item (read-int8 ,index)))) + (macrolet ((type-check (value type) value type nil)) + (and ,@(get-put-items index body t))))) + +(defmacro put-items ((index) &body body) + `(progn ,@(get-put-items index body t))) + +(defmacro decode-type (type value) + ;; Given an integer and type, return the value + (let ((args nil)) + (when (consp type) + (setq args (cdr type) + type (car type))) + `(macrolet ((read-card29 (value) value) + (read-card32 (value) value) + (read-int32 (value) `(card32->int32 ,value)) + (read-card16 (value) value) + (read-int16 (value) `(card16->int16 ,value)) + (read-card8 (value) value) + (read-int8 (value) `(int8->card8 ,value))) + (,(getify type) ,value ,@args)))) + +(defmacro encode-type (type value) + ;; Given a value and type, return an integer + ;; When check-p, do type checking on value + (let ((args nil)) + (when (consp type) + (setq args (cdr type) + type (car type))) + `(macrolet ((write-card29 (index value) index value) + (write-card32 (index value) index value) + (write-int32 (index value) index `(int32->card32 ,value)) + (write-card16 (index value) index value) + (write-int16 (index value) index `(int16->card16 ,value)) + (write-card8 (index value) index value) + (write-int8 (index value) index `(int8->card8 ,value))) + (check-put 0 ,value ,type ,@args)))) + +(defmacro set-decode-type (type accessor value) + `(setf ,accessor (encode-type ,type ,value))) +(defsetf decode-type set-decode-type) + + +;;; +;;; Request codes +;;; + +(defconstant *x-createwindow* 1) +(defconstant *x-changewindowattributes* 2) +(defconstant *x-getwindowattributes* 3) +(defconstant *x-destroywindow* 4) +(defconstant *x-destroysubwindows* 5) +(defconstant *x-changesaveset* 6) +(defconstant *x-reparentwindow* 7) +(defconstant *x-mapwindow* 8) +(defconstant *x-mapsubwindows* 9) +(defconstant *x-unmapwindow* 10) +(defconstant *x-unmapsubwindows* 11) +(defconstant *x-configurewindow* 12) +(defconstant *x-circulatewindow* 13) +(defconstant *x-getgeometry* 14) +(defconstant *x-querytree* 15) +(defconstant *x-internatom* 16) +(defconstant *x-getatomname* 17) +(defconstant *x-changeproperty* 18) +(defconstant *x-deleteproperty* 19) +(defconstant *x-getproperty* 20) +(defconstant *x-listproperties* 21) +(defconstant *x-setselectionowner* 22) +(defconstant *x-getselectionowner* 23) +(defconstant *x-convertselection* 24) +(defconstant *x-sendevent* 25) +(defconstant *x-grabpointer* 26) +(defconstant *x-ungrabpointer* 27) +(defconstant *x-grabbutton* 28) +(defconstant *x-ungrabbutton* 29) +(defconstant *x-changeactivepointergrab* 30) +(defconstant *x-grabkeyboard* 31) +(defconstant *x-ungrabkeyboard* 32) +(defconstant *x-grabkey* 33) +(defconstant *x-ungrabkey* 34) +(defconstant *x-allowevents* 35) +(defconstant *x-grabserver* 36) +(defconstant *x-ungrabserver* 37) +(defconstant *x-querypointer* 38) +(defconstant *x-getmotionevents* 39) +(defconstant *x-translatecoords* 40) +(defconstant *x-warppointer* 41) +(defconstant *x-setinputfocus* 42) +(defconstant *x-getinputfocus* 43) +(defconstant *x-querykeymap* 44) +(defconstant *x-openfont* 45) +(defconstant *x-closefont* 46) +(defconstant *x-queryfont* 47) +(defconstant *x-querytextextents* 48) +(defconstant *x-listfonts* 49) +(defconstant *x-listfontswithinfo* 50) +(defconstant *x-setfontpath* 51) +(defconstant *x-getfontpath* 52) +(defconstant *x-createpixmap* 53) +(defconstant *x-freepixmap* 54) +(defconstant *x-creategc* 55) +(defconstant *x-changegc* 56) +(defconstant *x-copygc* 57) +(defconstant *x-setdashes* 58) +(defconstant *x-setcliprectangles* 59) +(defconstant *x-freegc* 60) +(defconstant *x-cleartobackground* 61) +(defconstant *x-copyarea* 62) +(defconstant *x-copyplane* 63) +(defconstant *x-polypoint* 64) +(defconstant *x-polyline* 65) +(defconstant *x-polysegment* 66) +(defconstant *x-polyrectangle* 67) +(defconstant *x-polyarc* 68) +(defconstant *x-fillpoly* 69) +(defconstant *x-polyfillrectangle* 70) +(defconstant *x-polyfillarc* 71) +(defconstant *x-putimage* 72) +(defconstant *x-getimage* 73) +(defconstant *x-polytext8* 74) +(defconstant *x-polytext16* 75) +(defconstant *x-imagetext8* 76) +(defconstant *x-imagetext16* 77) +(defconstant *x-createcolormap* 78) +(defconstant *x-freecolormap* 79) +(defconstant *x-copycolormapandfree* 80) +(defconstant *x-installcolormap* 81) +(defconstant *x-uninstallcolormap* 82) +(defconstant *x-listinstalledcolormaps* 83) +(defconstant *x-alloccolor* 84) +(defconstant *x-allocnamedcolor* 85) +(defconstant *x-alloccolorcells* 86) +(defconstant *x-alloccolorplanes* 87) +(defconstant *x-freecolors* 88) +(defconstant *x-storecolors* 89) +(defconstant *x-storenamedcolor* 90) +(defconstant *x-querycolors* 91) +(defconstant *x-lookupcolor* 92) +(defconstant *x-createcursor* 93) +(defconstant *x-createglyphcursor* 94) +(defconstant *x-freecursor* 95) +(defconstant *x-recolorcursor* 96) +(defconstant *x-querybestsize* 97) +(defconstant *x-queryextension* 98) +(defconstant *x-listextensions* 99) +(defconstant *x-setkeyboardmapping* 100) +(defconstant *x-getkeyboardmapping* 101) +(defconstant *x-changekeyboardcontrol* 102) +(defconstant *x-getkeyboardcontrol* 103) +(defconstant *x-bell* 104) +(defconstant *x-changepointercontrol* 105) +(defconstant *x-getpointercontrol* 106) +(defconstant *x-setscreensaver* 107) +(defconstant *x-getscreensaver* 108) +(defconstant *x-changehosts* 109) +(defconstant *x-listhosts* 110) +(defconstant *x-changeaccesscontrol* 111) +(defconstant *x-changeclosedownmode* 112) +(defconstant *x-killclient* 113) +(defconstant *x-rotateproperties* 114) +(defconstant *x-forcescreensaver* 115) +(defconstant *x-setpointermapping* 116) +(defconstant *x-getpointermapping* 117) +(defconstant *x-setmodifiermapping* 118) +(defconstant *x-getmodifiermapping* 119) +(defconstant *x-nooperation* 127) + +;;; Some macros for threaded lists + +(defmacro threaded-atomic-push (item list next type) + (let ((x (gensym)) + (y (gensym))) + `(let ((,x ,item)) + (declare (type ,type ,x)) + (loop + (let ((,y ,list)) + (declare (type (or null ,type) ,y) + (optimize (speed 3) (safety 0))) + (setf (,next ,x) ,y) + (when (conditional-store ,list ,y ,x) + (return ,x))))))) + +(defmacro threaded-atomic-pop (list next type) + (let ((y (gensym))) + `(loop + (let ((,y ,list)) + (declare (type (or null ,type) ,y) + (optimize (speed 3) (safety 0))) + (if (null ,y) + (return nil) + (when (conditional-store ,list ,y (,next (the ,type ,y))) + (setf (,next (the ,type ,y)) nil) + (return ,y))))))) + +(defmacro threaded-nconc (item list next type) + (let ((first (gensym)) + (x (gensym)) + (y (gensym)) + (z (gensym))) + `(let ((,z ,item) + (,first ,list)) + (declare (type ,type ,z) + (type (or null ,type) ,first) + (optimize (speed 3) (safety 0))) + (if (null ,first) + (setf ,list ,z) + (do* ((,x ,first ,y) + (,y (,next ,x) (,next ,x))) + ((null ,y) + (setf (,next ,x) ,z) + ,first) + (declare (type ,type ,x) + (type (or null ,type) ,y))))))) + +(defmacro threaded-push (item list next type) + (let ((x (gensym))) + `(let ((,x ,item)) + (declare (type ,type ,x) + (optimize (speed 3) (safety 0))) + (shiftf (,next ,x) ,list ,x) + ,x))) + +(defmacro threaded-pop (list next type) + (let ((x (gensym))) + `(let ((,x ,list)) + (declare (type (or null ,type) ,x) + (optimize (speed 3) (safety 0))) + (when ,x + (shiftf ,list (,next (the ,type ,x)) nil)) + ,x))) + +(defmacro threaded-enqueue (item head tail next type) + (let ((x (gensym))) + `(let ((,x ,item)) + (declare (type ,type ,x) + (optimize (speed 3) (safety 0))) + (if (null ,tail) + (threaded-nconc ,x ,head ,next ,type) + (threaded-nconc ,x (,next (the ,type ,tail)) ,next ,type)) + (setf ,tail ,x)))) + +(defmacro threaded-dequeue (head tail next type) + (let ((x (gensym))) + `(let ((,x ,head)) + (declare (type (or null ,type) ,x) + (optimize (speed 3) (safety 0))) + (when ,x + (when (eq ,x ,tail) + (setf ,tail (,next (the ,type ,x)))) + (setf ,head (,next (the ,type ,x)))) + ,x))) + +(defmacro threaded-requeue (item head tail next type) + (let ((x (gensym))) + `(let ((,x ,item)) + (declare (type ,type ,x) + (optimize (speed 3) (safety 0))) + (if (null ,tail) + (setf ,tail (setf ,head ,x)) + (shiftf (,next ,x) ,head ,x)) + ,x))) + +(defmacro threaded-dolist ((variable list next type) &body body) + `(block nil + (do* ((,variable ,list (,next (the ,type ,variable)))) + ((null ,variable)) + (declare (type (or null ,type) ,variable)) + ,@body))) + +(defmacro threaded-delete (item list next type) + (let ((x (gensym)) + (y (gensym)) + (z (gensym)) + (first (gensym))) + `(let ((,x ,item) + (,first ,list)) + (declare (type ,type ,x) + (type (or null ,type) ,first) + (optimize (speed 3) (safety 0))) + (when ,first + (if (eq ,first ,x) + (setf ,first (setf ,list (,next ,x))) + (do* ((,y ,first ,z) + (,z (,next ,y) (,next ,y))) + ((or (null ,z) (eq ,z ,x)) + (when (eq ,z ,x) + (setf (,next ,y) (,next ,x)))) + (declare (type ,type ,y)) + (declare (type (or null ,type) ,z))))) + (setf (,next ,x) nil) + ,first))) + +(defmacro threaded-length (list next type) + (let ((x (gensym)) + (count (gensym))) + `(do ((,x ,list (,next (the ,type ,x))) + (,count 0 (index1+ ,count))) + ((null ,x) + ,count) + (declare (type (or null ,type) ,x) + (type array-index ,count) + (optimize (speed 3) (safety 0)))))) + diff --git a/clx/manager.lisp b/clx/manager.lisp new file mode 100644 index 000000000..96832df3b --- /dev/null +++ b/clx/manager.lisp @@ -0,0 +1,851 @@ +;;; -*- 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) + +(export '(wm-name ;These are all setf'able accessor functions + wm-icon-name + wm-client-machine + wm-command + wm-hints + wm-normal-hints + icon-sizes + wm-protocols + wm-colormap-windows + + wm-size-hints + wm-size-hints-p + make-wm-size-hints + wm-size-hints-user-specified-position-p + wm-size-hints-user-specified-size-p + wm-size-hints-min-width + wm-size-hints-min-height + wm-size-hints-max-width + wm-size-hints-max-height + wm-size-hints-width-inc + wm-size-hints-height-inc + wm-size-hints-min-aspect + wm-size-hints-max-aspect + wm-size-hints-base-width + wm-size-hints-base-height + wm-size-hints-win-gravity + + wm-hints + wm-hints-p + make-wm-hints + wm-hints-input + wm-hints-initial-state + wm-hints-icon-pixmap + wm-hints-icon-window + wm-hints-icon-x + wm-hints-icon-y + wm-hints-icon-mask + wm-hints-window-group + wm-hints-flags + + transient-for + + set-wm-properties + iconify-window + withdraw-window + + get-wm-class + set-wm-class + rgb-colormaps + + cut-buffer ;; Setf'able + rotate-cut-buffers + + ;; Obsolete + wm-zoom-hints + wm-size-hints-x + wm-size-hints-y + wm-size-hints-width + wm-size-hints-height + set-standard-properties + get-standard-colormap + set-standard-colormap + )) + +(defun wm-name (window) + (declare (type window window)) + (declare (values string)) + (get-property window :WM_NAME :type :STRING :result-type 'string :transform #'card8->char)) + +(defsetf wm-name (window) (name) + (declare (type window window)) + (declare (values string)) + `(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 (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 (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 (values (or null name-string) (or null class-string))) + (let ((value (get-property window :WM_CLASS :type :STRING + :result-type 'string :transform #'card8->char))) + (declare (type (or null string) value)) + (when value + (let* ((name-len (position #.(card8->char 0) (the string value))) + (name (subseq (the string value) 0 name-len)) + (class (subseq (the string value) (1+ name-len) (1- (length value))))) + (values (and (plusp (length name)) name) + (and (plusp (length class)) class)))))) + +(defun set-wm-class (window resource-name resource-class) + (declare (type window window) + (type (or null stringable) resource-name resource-class)) + (set-string-property window :WM_CLASS + (concatenate 'string + (string (or resource-name "")) + #.(make-string 1 :initial-element (card8->char 0)) + (string (or resource-class "")) + #.(make-string 1 :initial-element (card8->char 0)))) + (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 (values list)) + (do* ((command-string (get-property window :WM_COMMAND :type :STRING + :result-type 'string :transform #'card8->char)) + (command nil) + (start 0 (1+ end)) + (end 0) + (len (length command-string))) + ((>= start len) (nreverse command)) + (setq end (position #.(card8->char 0) command-string :start start)) + (push (subseq command-string start end) command))) + +(defsetf wm-command set-wm-command) +(defun set-wm-command (window command) + ;; Uses PRIN1 to a string-stream with the following bindings: + ;; (*print-length* nil) (*print-level* nil) (*print-radix* nil) + ;; (*print-base* 10.) (*print-array* t) (*package* (find-package 'lisp)) + ;; each element of command is seperated with NULL characters. + ;; This enables (mapcar #'read-from-string (wm-command window)) + ;; to recover a lisp command. + (declare (type window window) + (type list command)) + (set-string-property window :WM_COMMAND + (with-output-to-string (stream) + (let ((*print-length* nil) + (*print-level* nil) + (*print-radix* nil) + (*print-base* 10.) + (*print-array* t) + (*package* (find-package 'lisp)) + #+ti (ticl:*print-structure* t)) + (dolist (c command) + (prin1 c stream) + (write-char #.(card8->char 0) stream))))) + 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 (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 (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 (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 (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) + ;; Defaulted T to put the burden of remembering these on widget programmers. + (user-specified-position-p nil :type boolean) ;; True when user specified x y + (user-specified-size-p nil :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)) + (declare (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 (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 (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 (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 (values (or null wm-size-hints))) + (when vector + (let ((usposition 0) ;User Specified position + (ussize 1) ;User Specified size + (pposition 2) ;Program specified position + (psize 3) ;Program specified size + (pminsize 4) ;Program specified minimum size + (pmaxsize 5) ;Program specified maximum size + (presizeinc 6) ;Program specified resize increments + (paspect 7) ;Program specfied min and max aspect ratios + (pbasesize 8) ;Program specified base size + (pwingravity 9) ;Program specified window gravity + ) + (let ((flags (aref vector 0)) + (hints (make-wm-size-hints))) + (declare (type card16 flags) + (type wm-size-hints hints)) + (when (or (logbitp usposition flags) + (logbitp pposition flags)) + (setf (wm-size-hints-user-specified-position-p hints) (logbitp usposition flags) + (wm-size-hints-x hints) (aref vector 1) + (wm-size-hints-y hints) (aref vector 2))) + (when (or (logbitp ussize flags) + (logbitp psize flags)) + (setf (wm-size-hints-user-specified-size-p hints) (logbitp usposition flags) + (wm-size-hints-width hints) (aref vector 3) + (wm-size-hints-height hints) (aref vector 4))) + (when (logbitp pminsize flags) + (setf (wm-size-hints-min-width hints) (aref vector 5) + (wm-size-hints-min-height hints) (aref vector 6))) + (when (logbitp pmaxsize flags) + (setf (wm-size-hints-max-width hints) (aref vector 7) + (wm-size-hints-max-height hints) (aref vector 8))) + (when (logbitp presizeinc flags) + (setf (wm-size-hints-width-inc hints) (aref vector 9) + (wm-size-hints-height-inc hints) (aref vector 10))) + (when (logbitp paspect 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 pbasesize flags) + (setf (wm-size-hints-base-width hints) (aref vector 15) + (wm-size-hints-base-height hints) (aref vector 16))) + (when (logbitp pwingravity flags) + (setf (wm-size-hints-win-gravity hints) + (decode-type (member-vector *win-gravity-vector*) (aref vector 17))))) + hints)))) + +(defun encode-wm-size-hints (hints) + (declare (type wm-size-hints hints)) + (declare (values simple-vector)) + (let ((usposition #b1) ;User Specified position + (ussize #b10) ;User Specified size + (pposition #b100) ;Program specified position + (psize #b1000) ;Program specified size + (pminsize #b10000) ;Program specified minimum size + (pmaxsize #b100000) ;Program specified maximum size + (presizeinc #b1000000) ;Program specified resize increments + (paspect #b10000000) ;Program specfied min and max aspect ratios + (pbasesize #b100000000) ;Program specfied base size + (pwingravity #b1000000000) ;Program specfied window gravity + ) + (let ((vector (make-array 18 :initial-element 0)) + (flags 0)) + (declare (type (simple-vector 18) vector) + (type card16 flags)) + (when (and (wm-size-hints-x hints) (wm-size-hints-y hints)) + (setq flags (if (wm-size-hints-user-specified-position-p hints) usposition pposition)) + (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)) + (setf flags (logior flags (if (wm-size-hints-user-specified-position-p hints) ussize psize)) + (aref vector 3) (wm-size-hints-width hints) + (aref vector 4) (wm-size-hints-height hints))) + + (when (and (wm-size-hints-min-width hints) (wm-size-hints-min-height hints)) + (setf flags (logior flags pminsize) + (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 flags (logior flags pmaxsize) + (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 flags (logior flags presizeinc) + (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 flags (logior flags paspect) + 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 flags (logior flags pbasesize) + (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 flags (logior flags pwingravity) + (aref vector 17) (encode-type + (member-vector *win-gravity-vector*) + (wm-size-hints-win-gravity 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 (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 + user-specified-size-p + 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 + 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 (or null boolean) user-specified-position-p user-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-input 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 + :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 user-specified-position-p (setf (wm-size-hints-user-specified-position-p size) + user-specified-position-p)) + (when user-specified-size-p (setf (wm-size-hints-user-specified-size-p size) + user-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 (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 (apply #'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 (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... +(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 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 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/clx/ms-patch.uu b/clx/ms-patch.uu new file mode 100644 index 000000000..b84726c5c --- /dev/null +++ b/clx/ms-patch.uu @@ -0,0 +1,57 @@ +begin 666 make-sequence-patch.lbin +M1D%33"!&24Q%.@I&05-,('9E<G-I;VX@,"XP,#4@*&]F(#@V,3$Q,BDL($Q/ +M5U1!1R V.# P,"X*1DE,12!)1#H@(B]M;V1S+W!A=&-H97,O8G5G+3(S-C@N +M;&)I;B([('9E<G-I;VX@3D5715-4.PIA=71H;W(@<F]G97([(&-R96%T960@ +M.#<P.#(V(#$W.C(T.C W+@I4:&ES(&9I;&4@:7,@=&AE(&]U='!U="!O9B!T +M:&4@3%5#240L($E.0RX@0V]M;6]N($QI<W @0V]M<&EL97(N"DEN=&5R;F%L +M(&9A<VP@<F5L96%S92!D871E($IU;F4@,C4L(#$Y.#8N"E-/55)#15,Z"B(O +M;6]D<R]P871C:&5S+V)U9RTR,S8X+FQI<W B.R!V97)S:6]N($Y%5T535#L* +M875T:&]R(')O9V5R.R!W<FET=&5N(#@W,#@R-B Q-SHR,SHU,BX*1DQ/050@ +M4$%204U%5$524SH@4F%D:7@Z(#(@4')E8VES:6]N<SH@," P(# @." R,R Q +M-C @," P(# @," P(# *1D5!5%5215,Z( I"24Y!4ED@1$%402!&3TQ,3U=3 +M.@H]* I)3BU004-+04=% 2@%3%5#240Z3"@A5D%,241!5$4M4T51545.0T4M +M4D5354Q4+5194$534$5#.Q@\_0*'#$8 F<0#$8 6<()&P XTZJ 4O#"!N +M__0B;0 18 0B:0 #( D" '# 6<$)$Q@"+'I =FYB1)N<IG$"U( 0J +M;O_\3^[_^"973M-/[O_PL>T %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<O#B\-2'H &B\( +M? $D;0 Q*FH $]S\_^0@;0 !3N@ !4Y>)&T -;7N_^QF &X("[_Z R +M#&<L0J<O#B\-2'H ("\M #DO+O_T? (D;0 ]*FH $]S\_^ @;0 !3N@ !4Y> +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 <B;O_T(FD R-N_^0 !R)N__0B +M:0 #(FD R-( =/[O_H0J<O#B\-2'H +"!N__0B: #(FD R\I <O+O_P +M? (D;0!%*FH $]S\_^ @;0 !3N@ !4Y>(&[_Y")M $E@!")I ,@"0( <, +M !9P0O#& (L>D !V;F+PE/[O_@N>[_X&<"8%P@;O_DN<AG$" ( @ !PP +M %G!"\,8!(D;0 UM>@ !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 <M2 $*F[__$_N__@F5T[3)&T 3;7N_^QF>B N_^@,@ 1F +M$BUM $T !"IN__Q/[O_X)E=.TR N_^@,@ AG*@R #&<B+6[_]/_P +M+6T .?_T? (D;0 ]*FH $R!M %/[O_P3N@ !2!N__0B: #(&D !RU(__1\ +M 21M %$J:@ 3(&T 4_N__1.Z %(&[_[+'M %5G!K'M %EF7B N_^@,@ +M QG+$*G+PXO#4AZ " O+0 Y+R[_]'P")&T /2IJ !/<_/_@(&T 4[H 5. +M7EB/(&[_]")H ,@:0 '+4C_]'P!)&T 42IJ !,@;0 !3^[_]$[H 4O+0!) +M(&[_[")N_^1@!")I ,@"0( <, !9P0D3& (L>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<O#B\-2'H '"\N__1\ 21M %TJ:@ 3W/S_X"!M %.Z %3EXM +M7__T+6P -__P3^[_\& ^XHM;O_T__ M;0 Y__1\ B1M #TJ:@ 3(&T 4_N +M__!.Z %N>[_\&<"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(')E<W5L="!S97%U96YC92!T>7!E<W!E8R@%15)23U+^!OX".07^ +M"/X6_A?^&/X)_@@H'5-)35!,12U614-43U(M5%E012U&4D]-+45465!%* 5! +M4E)!62@,4TE-4$Q%+4%24D%9* Y.3U)-04Q)6D4M5%E014$*14Y$($]&($9! +(4TP@1$%400I- + +end diff --git a/clx/provide.lisp b/clx/provide.lisp new file mode 100644 index 000000000..d6c9066c7 --- /dev/null +++ b/clx/provide.lisp @@ -0,0 +1,41 @@ +;;; -*- 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 <pathname-of-this-file>) +;;; + +(in-package :user) + +(provide :clx) + +;;; Load the defsystem file from the source directory. You may +;;; want to include an explicit extension (such as ".l" or ".lisp"). +;;; +(load "/src/local/clx/defsystem.l") + +;;; The binary files for a particular lisp implementation and architecture. +;;; +(let ((lisp + (or #+lucid "lucid" + #+excl "franz" + #+akcl "akcl" + #+kcl "kcl" + #+ibcl "ibcl" + (error "Can't figure out what lisp vendor this lisp is from."))) + (computer + (or #+(or sun3 (and sun (or mc68000 mc68020))) "sun3" + #+(or sun4 sparc) "sparc" + #+(and hp (or mc68000 mc68020)) "hp9000-300" + #+vax "vax" + (error "Can't figure out what computer vendor this computer is from.")))) + (xlib:load-clx (format nil "/src/local/clx/~A.~A/" lisp computer))) diff --git a/clx/requests.lisp b/clx/requests.lisp new file mode 100644 index 000000000..5f6ce462d --- /dev/null +++ b/clx/requests.lisp @@ -0,0 +1,1590 @@ +;;; -*- 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) + +(export '(create-window + destroy-window + destroy-subwindows + add-to-save-set + remove-from-save-set + reparent-window + map-window + map-subwindows + unmap-window + unmap-subwindows + circulate-window-up + circulate-window-down + query-tree + intern-atom + find-atom + atom-name + change-property + delete-property + get-property + rotate-properties + list-properties + set-selection-owner + selection-owner + selection-owner + convert-selection + send-event + grab-pointer + ungrab-pointer + grab-button + ungrab-button + change-active-pointer-grab + grab-keyboard + ungrab-keyboard + grab-key + ungrab-key + allow-events + grab-server + ungrab-server + with-server-grabbed + query-pointer + pointer-position + global-pointer-position + motion-events + translate-coordinates + warp-pointer + warp-pointer-relative + warp-pointer-if-inside + warp-pointer-relative-if-inside + set-input-focus + input-focus + query-keymap + create-pixmap + free-pixmap + clear-area + copy-area + copy-plane + create-colormap + free-colormap + copy-colormap-and-free + install-colormap + uninstall-colormap + installed-colormaps + alloc-color + alloc-color-cells + alloc-color-planes + free-colors + store-color + store-colors + query-colors + lookup-color + create-cursor + create-glyph-cursor + free-cursor + recolor-cursor + query-best-cursor + query-best-tile + query-best-stipple + query-extension + list-extensions + change-keyboard-control + keyboard-control + bell + pointer-mapping + set-pointer-mapping + pointer-mapping + change-pointer-control + pointer-control + set-screen-saver + screen-saver + activate-screen-saver + reset-screen-saver + add-access-host + remove-access-host + access-hosts + access-control + set-access-control + access-control + close-down-mode + set-close-down-mode + kill-client + kill-temporary-clients + no-operation + )) + +(defun create-window (&key + (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 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 (values window)) + (let* ((display (window-display parent)) + (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 (values (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 (values resource-id)) + (let ((keyword (if (keywordp name) name (kintern (string name))))) + (declare (type keyword keyword)) + (or (atom-id keyword display) + (let ((string (symbol-name keyword))) + (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 keyword 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 (values (or null resource-id))) + (let ((keyword (if (keywordp name) name (kintern (string name))))) + (declare (type keyword keyword)) + (or (atom-id keyword display) + (let ((string (symbol-name keyword))) + (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 keyword display) id)) + id))))) + +(defun atom-name (display atom-id) + (declare (type display display) + (type resource-id atom-id)) + (declare (values keyword)) + (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 t transform)) ;(or null (function (t) integer)) + (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 boolean delete-p) + (type t result-type) ;a sequence type + (type t transform)) ;(or null (function (integer) t)) + (declare (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 (values (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 (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 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 boolean owner-p sync-pointer-p sync-keyboard-p) + (type (or null window) confine-to) + (type (or null cursor) cursor) + (type timestamp time)) + (declare (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 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 boolean owner-p sync-pointer-p sync-keyboard-p) + (type timestamp time)) + (declare (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 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 (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 (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 (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 (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 (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 :parent :pointer-root) revert-to) + (type timestamp time)) + (with-buffer-request (display *x-setinputfocus*) + ((data (member :none :parent :pointer-root)) revert-to) + ((or window (member :none :pointer-root)) focus) + ((or null card32) time))) + +(defun input-focus (display) + (declare (type display display)) + (declare (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 (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 + (width (required-arg width)) + (height (required-arg height)) + (depth (required-arg depth)) + (drawable (required-arg drawable))) + (declare (type card8 depth) ;; required + (type card16 width height) ;; required + (type drawable drawable)) ;; required + (declare (values pixmap)) + (let* ((display (drawable-display drawable)) + (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 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 boolean alloc-p)) + (declare (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 (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 (values (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 (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 12) + :green (rgb-val-get 14) + :blue (rgb-val-get 16)) + (make-color :red (rgb-val-get 18) + :green (rgb-val-get 20) + :blue (rgb-val-get 22))))))))) + +(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 t result-type)) ;; CL type + (declare (values (sequence pixel) (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 boolean contiguous-p) + (type t result-type)) ;; CL type + (declare (values (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 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 boolean red-p green-p blue-p)) + (etypecase specs + (list + (do* ((spec specs (cddr spec)) + (pixel (car spec) (car spec)) + (color (cadr spec) (cadr spec))) + ((endp spec)) + (store-color colormap pixel color :red-p red-p :green-p green-p :blue-p blue-p))) + (vector + (do* ((i 0 (+ i 2)) + (len (length specs)) + (pixel (aref specs i) (aref specs i)) + (color (aref specs (1+ i)) (aref specs (1+ i)))) + ((>= i len)) + (store-color colormap pixel color :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 (values (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 (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 (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 (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 (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 (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 (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 (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 (values (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 (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 (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) + (inline rationalize16)) + (flet ((rationalize16 (number) + ;; Rationalize NUMBER into the ratio of two signed 16 bit numbers + (declare (type number number) + (inline rationalize16)) + (declare (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)))))) + + (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 (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 (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 (values (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 (values 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 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 (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/clx/resource.lisp b/clx/resource.lisp new file mode 100644 index 000000000..743c14f46 --- /dev/null +++ b/clx/resource.lisp @@ -0,0 +1,713 @@ +;;; -*- 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) + +(export '(resource-database + resource-database-timestamp + make-resource-database + resource-key + get-resource + get-search-table + get-search-resource + add-resource + delete-resource + map-resource + merge-resources + read-resources + write-resources + wm-resources + set-wm-resources + root-resources)) + +#+clue ;; for CLUE only +(defparameter *resource-subclassp* nil + "When non-nil and no match found, search superclasses.") + +;; 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) + (princ (resource-database-name database) stream) + (when (resource-database-value database) + (princ " " 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)))) + ))) + +(defun resource-key (stringable) + ;; Ensure STRINGABLE is a keyword. + (declare (type stringable stringable)) + (if (symbolp stringable) + (if (keywordp (the symbol stringable)) + stringable + (kintern (symbol-name (the symbol stringable)))) + (kintern (#-excl string-upcase + #+excl correct-case + (the string stringable))))) + +(defun stringable-equal (a b) + ;; Compare two stringables. + ;; Ignore case when comparing to a symbol. + (declare (type stringable a b)) + (declare (values boolean)) + (if (symbolp a) + (if (symbolp b) + (string= (the string (symbol-name (the symbol a))) + (the string (symbol-name (the symbol b)))) + (string-equal (the string (symbol-name (the symbol a))) + (the string b))) + (if (symbolp b) + (string-equal (the string a) + (the string (symbol-name (the symbol b)))) + (string= (the string a) + (the string 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 list name-list) ;; (list stringable) + (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 list name-list)) ;; (list stringable) + (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 list full-name full-class)) ;; (list stringable) + (declare (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))) + #+clue ;; for CLUE only + ((and *resource-subclassp* + (or loose tight) + (dolist (class (cluei::class-all-superclasses class)) + (when tight + (when (setq result + (get-entry-lookup tight class names classes)) + (return result))) + (when loose + (when (setq result + (get-entry-lookup loose class names classes)) + (return result)))))) + (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)) + #+clue ;; for CLUE only + (when *resource-subclassp* + (dolist (class (cluei::class-all-superclasses class)) + (when (setq result + (get-entry-lookup loose class names classes)) + (return-from get-entry 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 list full-name full-class)) ;; (list stringable) + (declare (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)) + #+clue ;; for CLUE only + (when *resource-subclassp* + (dolist (class (cluei::class-all-superclasses class)) + (declare (type symbol class)) + (setq class class) + (when tight + (get-tables-lookup tight class names classes)) + (when loose + (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)) + #+clue ;; for CLUE only + (when *resource-subclassp* + (dolist (class (cluei::class-all-superclasses 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) + (downward-funarg function) + (dynamic-extent args)) + (declare (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) + (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 (values resource-database)) + (map-resource #'add-resource database with-database) + with-database) + +(defun char-memq (key char) + ;; Used as a test function for POSITION + (declare (type string-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 + (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) boolean)) + test test-not)) + (declare (values resource-database)) + (resource-with-open-file (stream pathname) + (loop + (let ((string (read-line stream nil :eof))) + (declare (type string 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)) + (if (not (string-equal string "#INCLUDE" :start1 i :end1 term)) + (format t "~%Resource File error. Ignoring: ~a" string) + (let ((path (merge-pathnames + (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 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 (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))))))) + (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) 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) boolean)) + test test-not)) + (declare (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) 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) boolean)) test test-not) + (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) boolean)) test test-not) + (type (or null (function (string stream) t)) write) + (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 set-root-resources) + +(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/clx/sockcl.lisp b/clx/sockcl.lisp new file mode 100644 index 000000000..26c0eda34 --- /dev/null +++ b/clx/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 +;;; <kcldistribution>/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/clx/socket.c b/clx/socket.c new file mode 100644 index 000000000..f8c843ebc --- /dev/null +++ b/clx/socket.c @@ -0,0 +1,144 @@ +/* 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 <stdio.h> +#include <X11/Xos.h> +#include <X11/Xproto.h> +#include <errno.h> +#include <netinet/in.h> +#include <sys/ioctl.h> +#include <netdb.h> +#include <sys/socket.h> +#ifndef hpux +#include <netinet/tcp.h> +#endif + +extern int errno; /* Certain (broken) OS's don't have this */ + /* decl in errno.h */ + +#ifdef UNIXCONN +#include <sys/un.h> +#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 */ +void bcopy(); + +/* + * 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); + 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 */ + 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; + bcopy((char *)host_ptr->h_addr, + (char *)&inaddr.sin_addr, + sizeof(inaddr.sin_addr)); + } + 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/clx/text.lisp b/clx/text.lisp new file mode 100644 index 000000000..59415101c --- /dev/null +++ b/clx/text.lisp @@ -0,0 +1,1083 @@ +;;; -*- 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) + +(export '( + translation-function + translate-default + text-extents + text-width + draw-glyph + draw-glyphs + draw-image-glyph + draw-image-glyphs + display-keycode-range + set-modifier-mapping + modifier-mapping + keysym + change-keyboard-mapping + keyboard-mapping + keyboard-mapping + )) + +;; 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 (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) + (downward-funarg #+Genera * #-Genera translate)) + (declare (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 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 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))) + ((type? new-font 'font) (setq font 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))))))) + + (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) + (downward-funarg #+Genera * #-Genera translate)) + (declare (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 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 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))) + ((type? new-font 'font) (setq font 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))))) + (values width next-start))) + +#+clx-little-endian +(defun byte-swap-card16 (card16) + (declare (type card16 card16)) + (declare (values card16)) + (dpb card16 (byte 8 8) (ash card16 -8))) + +(defun text-extents-server (font string start end) + (declare (type font font) + (type string string) + (type array-index start end)) + (declare (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 card16 :start start :end end :appending t + #+clx-little-endian :transform + #+clx-little-endian ;; Byte swap for little-endian + #'byte-swap-card16) + 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 (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 card16 :start start :end end :appending t + #+clx-little-endian :transform + #+clx-little-endian ;; Byte swap for little-endian + #'byte-swap-card16) + 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 boolean width-only-p)) + (declare (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) + (array-register 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 0) + (descent 0) + (left #x7fff) + (right 0)) + ((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 0) + (descent 0) + (left #x7fff) + (right 0)) + ((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) + (downward-funarg #+Genera * #-Genera translate)) + (declare (values 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) + (downward-funarg #+Genera * #-Genera translate)) + (declare (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 int32 x y width) + (type array-index start end) + (type sequence sequence)) + (declare (values (or null array-index) (or null int32))) + (declare (type translation-function translate) + (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 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 end) + (type int32 width) + (type sequence sequence)) + (declare (values (or null array-index) (or null int32))) + (declare (type translation-function translate) + (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 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-card16 display (index+ boffset 2) buffer 0 dst-chunk + #+clx-little-endian ;; Byte swap for little-endian + #'byte-swap-card16) + (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) + (downward-funarg #+Genera * #-Genera translate)) + (declare (values 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 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 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) + (downward-funarg #+Genera * #-Genera translate)) + (declare (values (or null array-index) (or null int32))) + (unless end (setq end (length sequence))) + (ecase size + ((:default 8) + (draw-image-glyphs8 drawable gcontext x y sequence start end width translate)) + (16 + (draw-image-glyphs16 drawable gcontext x y sequence start end width translate)))) + +(defun draw-image-glyphs8 (drawable gcontext x y sequence start end width translate) + ;; 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) + (downward-funarg translate)) + (declare (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 width translate) + ;; 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) + (downward-funarg translate)) + (declare (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-card16 display (index+ buffer-boffset 16) buffer 0 chunk + #+clx-little-endian ;; Byte swap for little-endian + #'byte-swap-card16) + ;; 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 (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 +;; 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 (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 (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 (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/clx/translate.lisp b/clx/translate.lisp new file mode 100644 index 000000000..18434e4ba --- /dev/null +++ b/clx/translate.lisp @@ -0,0 +1,619 @@ +;;; -*- 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) + +(export '(define-keysym-set + keysym-set + define-keysym + undefine-keysym + default-keysym-translate + keysym + character->keysyms + keycode->keysym + keysym->character + default-keysym-index + keycode->character + state-keysym-p + mapping-notify + keysym-in-map-p + character-in-map-p + keysym->keycodes + )) + +(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) + (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) + (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 list) ; (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 string-char t) object) + (type keysym keysym) + (type (or null mask16 list) ;; (list (or keysym state-mask-key)) + modifiers) + (type (or null (member :modifiers) mask16 list) ;; (list (or keysym state-mask-key)) + mask) + (type (or null display) display) + (type (or null keysym) lowercase) + (type (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 (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 string-char t) object) + (type keysym keysym) + (type (or null mask16 list) ;; (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 (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 (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) + (values (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 (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) + (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 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 card16 state)) + (declare (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 (values 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 (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-translate (display state object) + ;; If object is a character, char-bits are set from state. + ;; + ;; [the following isn't implemented (should it be?)] + ;; If object is a list, it is an alist with entries: + ;; (string-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)) + (declare (values t)) ;; Object returned by keycode->character + (macrolet ((keystate-p (state keyword) + `(the boolean + (logbitp ,(position keyword *state-mask-vector*) + ,state)))) + (when (characterp object) + (when (keystate-p state :control) + (setf (char-bit object :control) 1)) + (when (state-keysymp display state left-meta-keysym) + (setf (char-bit object :meta) 1)) + (when (state-keysymp display state left-super-keysym) + (setf (char-bit object :super) 1)) + (when (state-keysymp display state left-hyper-keysym) + (setf (char-bit object :hyper) 1)))) + object) + +(defun default-keysym-index (display keycode state) + ;; Returns a keysym-index for use with keycode->character + (declare (values card8)) + (macrolet ((keystate-p (state keyword) + `(the boolean + (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 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 boolean uppercase-alphabetic-p) + (type boolean shift-lock-xors));;; If T, both SHIFT-LOCK and SHIFT is the same + ;;; as neither if the character is alphabetic. + (declare (values boolean)) + (macrolet ((keystate-p (state keyword) + `(the boolean + (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 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 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 (string-char card16 boolean card8) card8)) + keysym-index-function)) + (declare (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 (values 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 (values 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 (values 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 (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))))) -- GitLab