mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-02 23:50:56 -08:00
Code Issues Projects Releases Packages Wiki Activity

Remove old CLOCC CLX library

Browse source
This commit is contained in:
jjgarcia 2005-01-14 12:39:41 +00:00
parent ab4b13d9ee
commit ff99fe9fee
42 changed files with 0 additions and 25958 deletions
Download patch file Download diff file Expand all files Collapse all files

59
src/eclx/README
View file

@ -1,59 +0,0 @@
Requirements: (working == demo/hello hello-world works)
- clisp version 2.28 or higher (earlier versions have pathname problems)
- acl (untested by the author)
- lwl (untested by the author)
- cmucl
- sbcl with db-sockets with notes:
+ please do
(pushnew :db-sockets *features*)
after loading db-sockets)
+ there is a problem with home: as logical pathname, please do:
(setf (logical-pathname-translations "home")
'(("**;*.*.*" "/home/pvaneynd/**/*.*")
(";**;*.*.*" "/home/pvaneynd/**/*.*")))
Problems with:
-lwl: I don't know how to open the unix socket
-acl: Didn't have time to download the newst and greatest version yet and
my older licence expired :-(
How to compile and load clx without common-lisp-controller:
(load "compile-and-load")
To test:
(load "demo/hello")
(xlib::hello-world "")
With common-lisp-controller: (please note that the patches included in the clocc-port
subdirectory have not yet been send upstream, so the cvs and cclan version won't do)
Put the source in for example ~/common-lisp/src/clx and add the following to your
startup script ( ~/.sbclrc or ~/.cmucl-init.lisp)
|;;; -*- Mode: Lisp; Package: USER; Base: 10; Syntax: Common-Lisp -*-
|
|(load "/etc/sbclrc")
|
|(format t "Hello Peter!~%")
|
|(common-lisp-controller:add-project-directory
| #p"/home/pvaneynd/common-lisp/src/"
| #p"/home/pvaneynd/common-lisp/fasl-sbcl/"
| '("CLX")
| "/home/pvaneynd/common-lisp/systems/")
then you can do:
* (require :db-sockets)
* (pushnew :db-sockets *features*)
* (require :clocc-port)
* (mk:oos :clx :compile)
* (mk:oos :clx :load)
comments to:
Peter Van Eynde pvaneynd@debian.org

13
src/eclx/RELEASE-NOTES
View file

@ -1,13 +0,0 @@
This is the second release. Major changes include the addition of the
clxman-sources from Gilbert Baumann and the removal of the clocc-port
dependency.
Old notes:
This is a 'get it out of the door' release. The subsystems included have patches
that still have to be integrated with upstream.
Expect a more polished release soon. But in the mean time I would appriciate
bugreports on this release. If you do encounter problems, please recompile
with debug 3 and send a traceback.

635
src/eclx/attributes.lisp
View file

@ -1,635 +0,0 @@
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
;;; Window Attributes
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
#+cmu
(ext:file-comment
"$Header$")
;;; The special variable *window-attributes* is an alist containg:
;;; (drawable attributes attribute-changes geometry geometry-changes)
;;; Where DRAWABLE is the associated window or pixmap
;;; ATTRIBUTES is NIL or a reply-buffer containing the drawable's
;;; attributes for use by the accessors.
;;; ATTRIBUTE-CHANGES is NIL or an array. The first element
;;; of the array is a "value-mask", indicating which
;;; attributes have changed. The other elements are
;;; integers associated with the changed values, ready
;;; for insertion into a server request.
;;; GEOMETRY is like ATTRIBUTES, but for window geometry
;;; GEOMETRY-CHANGES is like ATTRIBUTE-CHANGES, but for window geometry
;;;
;;; Attribute and Geometry accessors and SETF's look on the special variable
;;; *window-attributes* for the drawable. If its not there, the accessor is
;;; NOT within a WITH-STATE, and a server request is made to get or put a value.
;;; If an entry is found in *window-attributes*, the cache buffers are used
;;; for the access.
;;;
;;; All WITH-STATE has to do (re)bind *Window-attributes* to a list including
;;; the new drawable. The caches are initialized to NIL and allocated as needed.
(in-package :xlib)
(eval-when (:compile-toplevel :load-toplevel :execute) ;needed by Franz Lisp
(defconstant +attribute-size+ 44)
(defconstant +geometry-size+ 24)
(defconstant +context-size+ (max +attribute-size+ +geometry-size+ (* 16 4))))
(defvar *window-attributes* nil) ;; Bound to an alist of (drawable . state) within WITH-STATE
;; Window Attribute reply buffer resource
(defvar *context-free-list* nil) ;; resource of free reply buffers
(defun allocate-context ()
(or (threaded-atomic-pop *context-free-list* reply-next reply-buffer)
(make-reply-buffer +context-size+)))
(defun deallocate-context (context)
(declare (type reply-buffer context))
(threaded-atomic-push context *context-free-list* reply-next reply-buffer))
(defmacro state-attributes (state) `(second ,state))
(defmacro state-attribute-changes (state) `(third ,state))
(defmacro state-geometry (state) `(fourth ,state))
(defmacro state-geometry-changes (state) `(fifth ,state))
(defmacro drawable-equal-function ()
(if (member 'drawable *clx-cached-types*)
''eq ;; Allows the compiler to use the microcoded ASSQ primitive on LISPM's
''drawable-equal))
(defmacro window-equal-function ()
(if (member 'window *clx-cached-types*)
''eq
''drawable-equal))
(defmacro with-state ((drawable) &body body)
;; Allows a consistent view to be obtained of data returned by GetWindowAttributes
;; and GetGeometry, and allows a coherent update using ChangeWindowAttributes and
;; ConfigureWindow. The body is not surrounded by a with-display. Within the
;; indefinite scope of the body, on a per-process basis in a multi-process
;; environment, the first call within an Accessor Group on the specified drawable
;; (the object, not just the variable) causes the complete results of the protocol
;; request to be retained, and returned in any subsequent accessor calls. Calls
;; within a Setf Group are delayed, and executed in a single request on exit from
;; the body. In addition, if a call on a function within an Accessor Group follows
;; a call on a function in the corresponding Setf Group, then all delayed setfs for
;; that group are executed, any retained accessor information for that group is
;; discarded, the corresponding protocol request is (re)issued, and the results are
;; (again) retained, and returned in any subsequent accessor calls.
;; Accessor Group A (for GetWindowAttributes):
;; window-visual, window-visual-info, window-class, window-gravity, window-bit-gravity,
;; window-backing-store, window-backing-planes, window-backing-pixel,
;; window-save-under, window-colormap, window-colormap-installed-p,
;; window-map-state, window-all-event-masks, window-event-mask,
;; window-do-not-propagate-mask, window-override-redirect
;; Setf Group A (for ChangeWindowAttributes):
;; window-gravity, window-bit-gravity, window-backing-store, window-backing-planes,
;; window-backing-pixel, window-save-under, window-event-mask,
;; window-do-not-propagate-mask, window-override-redirect, window-colormap,
;; window-cursor
;; Accessor Group G (for GetGeometry):
;; drawable-root, drawable-depth, drawable-x, drawable-y, drawable-width,
;; drawable-height, drawable-border-width
;; Setf Group G (for ConfigureWindow):
;; drawable-x, drawable-y, drawable-width, drawable-height, drawable-border-width,
;; window-priority
(let ((state-entry (gensym)))
;; alist of (drawable attributes attribute-changes geometry geometry-changes)
`(with-stack-list (,state-entry ,drawable nil nil nil nil)
(with-stack-list* (*window-attributes* ,state-entry *window-attributes*)
(multiple-value-prog1
(progn ,@body)
(cleanup-state-entry ,state-entry))))))
(defun cleanup-state-entry (state)
;; Return buffers to the free-list
(let ((entry (state-attributes state)))
(when entry (deallocate-context entry)))
(let ((entry (state-attribute-changes state)))
(when entry
(put-window-attribute-changes (car state) entry)
(deallocate-gcontext-state entry)))
(let ((entry (state-geometry state)))
(when entry (deallocate-context entry)))
(let ((entry (state-geometry-changes state)))
(when entry
(put-drawable-geometry-changes (car state) entry)
(deallocate-gcontext-state entry))))
(defun change-window-attribute (window number value)
;; Called from window attribute SETF's to alter an attribute value
;; number is the change-attributes request mask bit number
(declare (type window window)
(type card8 number)
(type card32 value))
(let ((state-entry nil)
(changes nil))
(if (and *window-attributes*
(setq state-entry (assoc window (the list *window-attributes*)
:test (window-equal-function))))
(progn ; Within a WITH-STATE - cache changes
(setq changes (state-attribute-changes state-entry))
(unless changes
(setq changes (allocate-gcontext-state))
(setf (state-attribute-changes state-entry) changes)
(setf (aref changes 0) 0)) ;; Initialize mask to zero
(setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit
(setf (aref changes (1+ number)) value)) ;; save value
; Send change to the server
(with-buffer-request ((window-display window) +x-changewindowattributes+)
(window window)
(card32 (ash 1 number) value)))))
;;
;; These two are twins (change-window-attribute change-drawable-geometry)
;; If you change one, you probably need to change the other...
;;
(defun change-drawable-geometry (drawable number value)
;; Called from drawable geometry SETF's to alter an attribute value
;; number is the change-attributes request mask bit number
(declare (type drawable drawable)
(type card8 number)
(type card29 value))
(let ((state-entry nil)
(changes nil))
(if (and *window-attributes*
(setq state-entry (assoc drawable (the list *window-attributes*)
:test (drawable-equal-function))))
(progn ; Within a WITH-STATE - cache changes
(setq changes (state-geometry-changes state-entry))
(unless changes
(setq changes (allocate-gcontext-state))
(setf (state-geometry-changes state-entry) changes)
(setf (aref changes 0) 0)) ;; Initialize mask to zero
(setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit
(setf (aref changes (1+ number)) value)) ;; save value
; Send change to the server
(with-buffer-request ((drawable-display drawable) +x-configurewindow+)
(drawable drawable)
(card16 (ash 1 number))
(card29 value)))))
(defun get-window-attributes-buffer (window)
(declare (type window window))
(let ((state-entry nil)
(changes nil))
(or (and *window-attributes*
(setq state-entry (assoc window (the list *window-attributes*)
:test (window-equal-function)))
(null (setq changes (state-attribute-changes state-entry)))
(state-attributes state-entry))
(let ((display (window-display window)))
(with-display (display)
;; When SETF's have been done, flush changes to the server
(when changes
(put-window-attribute-changes window changes)
(deallocate-gcontext-state (state-attribute-changes state-entry))
(setf (state-attribute-changes state-entry) nil))
;; Get window attributes
(with-buffer-request-and-reply (display +x-getwindowattributes+ size :sizes (8))
((window window))
(let ((repbuf (or (state-attributes state-entry) (allocate-context))))
(declare (type reply-buffer repbuf))
;; Copy into repbuf from reply buffer
(buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size)
(when state-entry (setf (state-attributes state-entry) repbuf))
repbuf)))))))
;;
;; These two are twins (get-window-attributes-buffer get-drawable-geometry-buffer)
;; If you change one, you probably need to change the other...
;;
(defun get-drawable-geometry-buffer (drawable)
(declare (type drawable drawable))
(let ((state-entry nil)
(changes nil))
(or (and *window-attributes*
(setq state-entry (assoc drawable (the list *window-attributes*)
:test (drawable-equal-function)))
(null (setq changes (state-geometry-changes state-entry)))
(state-geometry state-entry))
(let ((display (drawable-display drawable)))
(with-display (display)
;; When SETF's have been done, flush changes to the server
(when changes
(put-drawable-geometry-changes drawable changes)
(deallocate-gcontext-state (state-geometry-changes state-entry))
(setf (state-geometry-changes state-entry) nil))
;; Get drawable attributes
(with-buffer-request-and-reply (display +x-getgeometry+ size :sizes (8))
((drawable drawable))
(let ((repbuf (or (state-geometry state-entry) (allocate-context))))
(declare (type reply-buffer repbuf))
;; Copy into repbuf from reply buffer
(buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size)
(when state-entry (setf (state-geometry state-entry) repbuf))
repbuf)))))))
(defun put-window-attribute-changes (window changes)
;; change window attributes
;; Always from Called within a WITH-DISPLAY
(declare (type window window)
(type gcontext-state changes))
(let* ((display (window-display window))
(mask (aref changes 0)))
(declare (type display display)
(type mask32 mask))
(with-buffer-request (display +x-changewindowattributes+)
(window window)
(card32 mask)
(progn ;; Insert a word in the request for each one bit in the mask
(do ((bits mask (ash bits -1))
(request-size 2) ;Word count
(i 1 (index+ i 1))) ;Entry count
((zerop bits)
(card16-put 2 (index-incf request-size))
(index-incf (buffer-boffset display) (index* request-size 4)))
(declare (type mask32 bits)
(type array-index i request-size))
(when (oddp bits)
(card32-put (index* (index-incf request-size) 4) (aref changes i))))))))
;;
;; These two are twins (put-window-attribute-changes put-drawable-geometry-changes)
;; If you change one, you probably need to change the other...
;;
(defun put-drawable-geometry-changes (window changes)
;; change window attributes or geometry (depending on request-number...)
;; Always from Called within a WITH-DISPLAY
(declare (type window window)
(type gcontext-state changes))
(let* ((display (window-display window))
(mask (aref changes 0)))
(declare (type display display)
(type mask16 mask))
(with-buffer-request (display +x-configurewindow+)
(window window)
(card16 mask)
(progn ;; Insert a word in the request for each one bit in the mask
(do ((bits mask (ash bits -1))
(request-size 2) ;Word count
(i 1 (index+ i 1))) ;Entry count
((zerop bits)
(card16-put 2 (incf request-size))
(index-incf (buffer-boffset display) (* request-size 4)))
(declare (type mask16 bits)
(type fixnum request-size)
(type array-index i))
(when (oddp bits)
(card29-put (* (incf request-size) 4) (aref changes i))))))))
(defmacro with-attributes ((window &rest options) &body body)
`(let ((.with-attributes-reply-buffer. (get-window-attributes-buffer ,window)))
(declare (type reply-buffer .with-attributes-reply-buffer.))
(prog1
(with-buffer-input (.with-attributes-reply-buffer. ,@options) ,@body)
(unless *window-attributes*
(deallocate-context .with-attributes-reply-buffer.)))))
;;
;; These two are twins (with-attributes with-geometry)
;; If you change one, you probably need to change the other...
;;
(defmacro with-geometry ((window &rest options) &body body)
`(let ((.with-geometry-reply-buffer. (get-drawable-geometry-buffer ,window)))
(declare (type reply-buffer .with-geometry-reply-buffer.))
(prog1
(with-buffer-input (.with-geometry-reply-buffer. ,@options) ,@body)
(unless *window-attributes*
(deallocate-context .with-geometry-reply-buffer.)))))
;;;-----------------------------------------------------------------------------
;;; Group A: (for GetWindowAttributes)
;;;-----------------------------------------------------------------------------
(defun window-visual (window)
(declare (type window window))
(declare (clx-values resource-id))
(with-attributes (window :sizes 32)
(resource-id-get 8)))
(defun window-visual-info (window)
(declare (type window window))
(declare (clx-values visual-info))
(with-attributes (window :sizes 32)
(visual-info (window-display window) (resource-id-get 8))))
(defun window-class (window)
(declare (type window window))
(declare (clx-values (member :input-output :input-only)))
(with-attributes (window :sizes 16)
(member16-get 12 :copy :input-output :input-only)))
(defun set-window-background (window background)
(declare (type window window)
(type (or (member :none :parent-relative) pixel pixmap) background))
(cond ((eq background :none) (change-window-attribute window 0 0))
((eq background :parent-relative) (change-window-attribute window 0 1))
((integerp background) ;; Background pixel
(change-window-attribute window 0 0) ;; pixmap :NONE
(change-window-attribute window 1 background))
((type? background 'pixmap) ;; Background pixmap
(change-window-attribute window 0 (pixmap-id background)))
(t (x-type-error background '(or (member :none :parent-relative) integer pixmap))))
background)
(defsetf window-background set-window-background)
(defun set-window-border (window border)
(declare (type window window)
(type (or (member :copy) pixel pixmap) border))
(cond ((eq border :copy) (change-window-attribute window 2 0))
((type? border 'pixmap) ;; Border pixmap
(change-window-attribute window 2 (pixmap-id border)))
((integerp border) ;; Border pixel
(change-window-attribute window 3 border))
(t (x-type-error border '(or (member :copy) integer pixmap))))
border)
(defsetf window-border set-window-border)
(defun window-bit-gravity (window)
;; setf'able
(declare (type window window))
(declare (clx-values bit-gravity))
(with-attributes (window :sizes 8)
(member8-vector-get 14 *bit-gravity-vector*)))
(defun set-window-bit-gravity (window gravity)
(change-window-attribute
window 4 (encode-type (member-vector *bit-gravity-vector*) gravity))
gravity)
(defsetf window-bit-gravity set-window-bit-gravity)
(defun window-gravity (window)
;; setf'able
(declare (type window window))
(declare (clx-values win-gravity))
(with-attributes (window :sizes 8)
(member8-vector-get 15 *win-gravity-vector*)))
(defun set-window-gravity (window gravity)
(change-window-attribute
window 5 (encode-type (member-vector *win-gravity-vector*) gravity))
gravity)
(defsetf window-gravity set-window-gravity)
(defun window-backing-store (window)
;; setf'able
(declare (type window window))
(declare (clx-values (member :not-useful :when-mapped :always)))
(with-attributes (window :sizes 8)
(member8-get 1 :not-useful :when-mapped :always)))
(defun set-window-backing-store (window when)
(change-window-attribute
window 6 (encode-type (member :not-useful :when-mapped :always) when))
when)
(defsetf window-backing-store set-window-backing-store)
(defun window-backing-planes (window)
;; setf'able
(declare (type window window))
(declare (clx-values pixel))
(with-attributes (window :sizes 32)
(card32-get 16)))
(defun set-window-backing-planes (window planes)
(change-window-attribute window 7 (encode-type card32 planes))
planes)
(defsetf window-backing-planes set-window-backing-planes)
(defun window-backing-pixel (window)
;; setf'able
(declare (type window window))
(declare (clx-values pixel))
(with-attributes (window :sizes 32)
(card32-get 20)))
(defun set-window-backing-pixel (window pixel)
(change-window-attribute window 8 (encode-type card32 pixel))
pixel)
(defsetf window-backing-pixel set-window-backing-pixel)
(defun window-save-under (window)
;; setf'able
(declare (type window window))
(declare (clx-values (member :off :on)))
(with-attributes (window :sizes 8)
(member8-get 24 :off :on)))
(defun set-window-save-under (window when)
(change-window-attribute window 10 (encode-type (member :off :on) when))
when)
(defsetf window-save-under set-window-save-under)
(defun window-override-redirect (window)
;; setf'able
(declare (type window window))
(declare (clx-values (member :off :on)))
(with-attributes (window :sizes 8)
(member8-get 27 :off :on)))
(defun set-window-override-redirect (window when)
(change-window-attribute window 9 (encode-type (member :off :on) when))
when)
(defsetf window-override-redirect set-window-override-redirect)
(defun window-event-mask (window)
;; setf'able
(declare (type window window))
(declare (clx-values mask32))
(with-attributes (window :sizes 32)
(card32-get 36)))
(defsetf window-event-mask (window) (event-mask)
(let ((em (gensym)))
`(let ((,em ,event-mask))
(declare (type event-mask ,em))
(change-window-attribute ,window 11 (encode-event-mask ,em))
,em)))
(defun window-do-not-propagate-mask (window)
;; setf'able
(declare (type window window))
(declare (clx-values mask32))
(with-attributes (window :sizes 32)
(card32-get 40)))
(defsetf window-do-not-propagate-mask (window) (device-event-mask)
(let ((em (gensym)))
`(let ((,em ,device-event-mask))
(declare (type device-event-mask ,em))
(change-window-attribute ,window 12 (encode-device-event-mask ,em))
,em)))
(defun window-colormap (window)
(declare (type window window))
(declare (clx-values (or null colormap)))
(with-attributes (window :sizes 32)
(let ((id (resource-id-get 28)))
(if (zerop id) nil
(lookup-colormap (window-display window) id)))))
(defun set-window-colormap (window colormap)
(change-window-attribute
window 13 (encode-type (or (member :copy) colormap) colormap))
colormap)
(defsetf window-colormap set-window-colormap)
(defun window-cursor (window)
(declare (type window window))
(declare (clx-values cursor))
window
(error "~S can only be set" 'window-cursor))
(defun set-window-cursor (window cursor)
(change-window-attribute
window 14 (encode-type (or (member :none) cursor) cursor))
cursor)
(defsetf window-cursor set-window-cursor)
(defun window-colormap-installed-p (window)
(declare (type window window))
(declare (clx-values generalized-boolean))
(with-attributes (window :sizes 8)
(boolean-get 25)))
(defun window-all-event-masks (window)
(declare (type window window))
(declare (clx-values mask32))
(with-attributes (window :sizes 32)
(card32-get 32)))
(defun window-map-state (window)
(declare (type window window))
(declare (clx-values (member :unmapped :unviewable :viewable)))
(with-attributes (window :sizes 8)
(member8-get 26 :unmapped :unviewable :viewable)))
;;;-----------------------------------------------------------------------------
;;; Group G: (for GetGeometry)
;;;-----------------------------------------------------------------------------
(defun drawable-root (drawable)
(declare (type drawable drawable))
(declare (clx-values window))
(with-geometry (drawable :sizes 32)
(window-get 8 (drawable-display drawable))))
(defun drawable-x (drawable)
;; setf'able
(declare (type drawable drawable))
(declare (clx-values int16))
(with-geometry (drawable :sizes 16)
(int16-get 12)))
(defun set-drawable-x (drawable x)
(change-drawable-geometry drawable 0 (encode-type int16 x))
x)
(defsetf drawable-x set-drawable-x)
(defun drawable-y (drawable)
;; setf'able
(declare (type drawable drawable))
(declare (clx-values int16))
(with-geometry (drawable :sizes 16)
(int16-get 14)))
(defun set-drawable-y (drawable y)
(change-drawable-geometry drawable 1 (encode-type int16 y))
y)
(defsetf drawable-y set-drawable-y)
(defun drawable-width (drawable)
;; setf'able
;; Inside width, excluding border.
(declare (type drawable drawable))
(declare (clx-values card16))
(with-geometry (drawable :sizes 16)
(card16-get 16)))
(defun set-drawable-width (drawable width)
(change-drawable-geometry drawable 2 (encode-type card16 width))
width)
(defsetf drawable-width set-drawable-width)
(defun drawable-height (drawable)
;; setf'able
;; Inside height, excluding border.
(declare (type drawable drawable))
(declare (clx-values card16))
(with-geometry (drawable :sizes 16)
(card16-get 18)))
(defun set-drawable-height (drawable height)
(change-drawable-geometry drawable 3 (encode-type card16 height))
height)
(defsetf drawable-height set-drawable-height)
(defun drawable-depth (drawable)
(declare (type drawable drawable))
(declare (clx-values card8))
(with-geometry (drawable :sizes 8)
(card8-get 1)))
(defun drawable-border-width (drawable)
;; setf'able
(declare (type drawable drawable))
(declare (clx-values integer))
(with-geometry (drawable :sizes 16)
(card16-get 20)))
(defun set-drawable-border-width (drawable width)
(change-drawable-geometry drawable 4 (encode-type card16 width))
width)
(defsetf drawable-border-width set-drawable-border-width)
(defun set-window-priority (mode window sibling)
(declare (type (member :above :below :top-if :bottom-if :opposite) mode)
(type window window)
(type (or null window) sibling))
(with-state (window)
(change-drawable-geometry
window 6 (encode-type (member :above :below :top-if :bottom-if :opposite) mode))
(when sibling
(change-drawable-geometry window 5 (encode-type window sibling))))
mode)
(defsetf window-priority (window &optional sibling) (mode)
;; A bit strange, but retains setf form.
`(set-window-priority ,mode ,window ,sibling))

1551
src/eclx/buffer.lisp
View file

File diff suppressed because it is too large Load diff

187
src/eclx/bufmac.lisp
View file

@ -1,187 +0,0 @@
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
;;; This file contains macro definitions for the BUFFER object for Common-Lisp
;;; X windows version 11
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
#+cmu
(ext:file-comment
"$Header$")
(in-package :xlib)
;;; The read- macros are in buffer.lisp, because event-case depends on (most of) them.
(defmacro write-card8 (byte-index item)
`(aset-card8 (the card8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index)))
(defmacro write-int8 (byte-index item)
`(aset-int8 (the int8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index)))
(defmacro write-card16 (byte-index item)
#+clx-overlapping-arrays
`(aset-card16 (the card16 ,item) buffer-wbuf
(index+ buffer-woffset (index-ash ,byte-index -1)))
#-clx-overlapping-arrays
`(aset-card16 (the card16 ,item) buffer-bbuf
(index+ buffer-boffset ,byte-index)))
(defmacro write-int16 (byte-index item)
#+clx-overlapping-arrays
`(aset-int16 (the int16 ,item) buffer-wbuf
(index+ buffer-woffset (index-ash ,byte-index -1)))
#-clx-overlapping-arrays
`(aset-int16 (the int16 ,item) buffer-bbuf
(index+ buffer-boffset ,byte-index)))
(defmacro write-card32 (byte-index item)
#+clx-overlapping-arrays
`(aset-card32 (the card32 ,item) buffer-lbuf
(index+ buffer-loffset (index-ash ,byte-index -2)))
#-clx-overlapping-arrays
`(aset-card32 (the card32 ,item) buffer-bbuf
(index+ buffer-boffset ,byte-index)))
(defmacro write-int32 (byte-index item)
#+clx-overlapping-arrays
`(aset-int32 (the int32 ,item) buffer-lbuf
(index+ buffer-loffset (index-ash ,byte-index -2)))
#-clx-overlapping-arrays
`(aset-int32 (the int32 ,item) buffer-bbuf
(index+ buffer-boffset ,byte-index)))
(defmacro write-card29 (byte-index item)
#+clx-overlapping-arrays
`(aset-card29 (the card29 ,item) buffer-lbuf
(index+ buffer-loffset (index-ash ,byte-index -2)))
#-clx-overlapping-arrays
`(aset-card29 (the card29 ,item) buffer-bbuf
(index+ buffer-boffset ,byte-index)))
;; This is used for 2-byte characters, which may not be aligned on 2-byte boundaries
;; and always are written high-order byte first.
(defmacro write-char2b (byte-index item)
;; It is impossible to do an overlapping write, so only nonoverlapping here.
`(let ((%item ,item)
(%byte-index (index+ buffer-boffset ,byte-index)))
(declare (type card16 %item)
(type array-index %byte-index))
(aset-card8 (the card8 (ldb (byte 8 8) %item)) buffer-bbuf %byte-index)
(aset-card8 (the card8 (ldb (byte 8 0) %item)) buffer-bbuf (index+ %byte-index 1))))
(defmacro set-buffer-offset (value &environment env)
env
`(let ((.boffset. ,value))
(declare (type array-index .boffset.))
(setq buffer-boffset .boffset.)
#+clx-overlapping-arrays
,@(when (member 16 (macroexpand '(%buffer-sizes) env))
`((setq buffer-woffset (index-ash .boffset. -1))))
#+clx-overlapping-arrays
,@(when (member 32 (macroexpand '(%buffer-sizes) env))
`((setq buffer-loffset (index-ash .boffset. -2))))
#+clx-overlapping-arrays
.boffset.))
(defmacro advance-buffer-offset (value)
`(set-buffer-offset (index+ buffer-boffset ,value)))
(defmacro with-buffer-output ((buffer &key (sizes '(8 16 32)) length index) &body body)
(unless (listp sizes) (setq sizes (list sizes)))
`(let ((%buffer ,buffer))
(declare (type display %buffer))
,(declare-bufmac)
,(when length
`(when (index>= (index+ (buffer-boffset %buffer) ,length) (buffer-size %buffer))
(buffer-flush %buffer)))
(let* ((buffer-boffset (the array-index ,(or index `(buffer-boffset %buffer))))
#-clx-overlapping-arrays
(buffer-bbuf (buffer-obuf8 %buffer))
#+clx-overlapping-arrays
,@(append
(when (member 8 sizes)
`((buffer-bbuf (buffer-obuf8 %buffer))))
(when (or (member 16 sizes) (member 160 sizes))
`((buffer-woffset (index-ash buffer-boffset -1))
(buffer-wbuf (buffer-obuf16 %buffer))))
(when (member 32 sizes)
`((buffer-loffset (index-ash buffer-boffset -2))
(buffer-lbuf (buffer-obuf32 %buffer))))))
(declare (type array-index buffer-boffset))
#-clx-overlapping-arrays
(declare (type buffer-bytes buffer-bbuf))
#+clx-overlapping-arrays
,@(append
(when (member 8 sizes)
'((declare (type buffer-bytes buffer-bbuf))))
(when (member 16 sizes)
'((declare (type array-index buffer-woffset))
(declare (type buffer-words buffer-wbuf))))
(when (member 32 sizes)
'((declare (type array-index buffer-loffset))
(declare (type buffer-longs buffer-lbuf)))))
buffer-boffset
#-clx-overlapping-arrays
buffer-bbuf
#+clx-overlapping-arrays
,@(append
(when (member 8 sizes) '(buffer-bbuf))
(when (member 16 sizes) '(buffer-woffset buffer-wbuf))
(when (member 32 sizes) '(buffer-loffset buffer-lbuf)))
#+clx-overlapping-arrays
(macrolet ((%buffer-sizes () ',sizes))
,@body)
#-clx-overlapping-arrays
,@body)))
;;; This macro is just used internally in buffer
(defmacro writing-buffer-chunks (type args decls &body body)
(when (> (length body) 2)
(error "writing-buffer-chunks called with too many forms"))
(let* ((size (* 8 (index-increment type)))
(form #-clx-overlapping-arrays
(first body)
#+clx-overlapping-arrays ; XXX type dependencies
(or (second body)
(first body))))
`(with-buffer-output (buffer :index boffset :sizes ,(reverse (adjoin size '(8))))
;; Loop filling the buffer
(do* (,@args
;; Number of bytes needed to output
(len ,(if (= size 8)
`(index- end start)
`(index-ash (index- end start) ,(truncate size 16)))
(index- len chunk))
;; Number of bytes available in buffer
(chunk (index-min len (index- (buffer-size buffer) buffer-boffset))
(index-min len (index- (buffer-size buffer) buffer-boffset))))
((not (index-plusp len)))
(declare ,@decls
(type array-index len chunk))
,form
(index-incf buffer-boffset chunk)
;; Flush the buffer
(when (and (index-plusp len) (index>= buffer-boffset (buffer-size buffer)))
(setf (buffer-boffset buffer) buffer-boffset)
(buffer-flush buffer)
(setq buffer-boffset (buffer-boffset buffer))
#+clx-overlapping-arrays
,(case size
(16 '(setq buffer-woffset (index-ash buffer-boffset -1)))
(32 '(setq buffer-loffset (index-ash buffer-boffset -2))))))
(setf (buffer-boffset buffer) (lround buffer-boffset)))))

940
src/eclx/clx.lisp
View file

@ -1,940 +0,0 @@
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
#+cmu
(ext:file-comment
"$Header$")
;; Primary Interface Author:
;; Robert W. Scheifler
;; MIT Laboratory for Computer Science
;; 545 Technology Square, Room 418
;; Cambridge, MA 02139
;; rws@zermatt.lcs.mit.edu
;; Design Contributors:
;; Dan Cerys, Texas Instruments
;; Scott Fahlman, CMU
;; Charles Hornig, Symbolics
;; John Irwin, Franz
;; Kerry Kimbrough, Texas Instruments
;; Chris Lindblad, MIT
;; Rob MacLachlan, CMU
;; Mike McMahon, Symbolics
;; David Moon, Symbolics
;; LaMott Oren, Texas Instruments
;; Daniel Weinreb, Symbolics
;; John Wroclawski, MIT
;; Richard Zippel, Symbolics
;; Primary Implementation Author:
;; LaMott Oren, Texas Instruments
;; Implementation Contributors:
;; Charles Hornig, Symbolics
;; John Irwin, Franz
;; Chris Lindblad, MIT
;; Robert Scheifler, MIT
;;;
;;; Change history:
;;;
;;; Date Author Description
;;; -------------------------------------------------------------------------------------
;;; 04/07/87 R.Scheifler Created code stubs
;;; 04/08/87 L.Oren Started Implementation
;;; 05/11/87 L.Oren Included draft 3 revisions
;;; 07/07/87 L.Oren Untested alpha release to MIT
;;; 07/17/87 L.Oren Alpha release
;;; 08/**/87 C.Lindblad Rewrite of buffer code
;;; 08/**/87 et al Various random bug fixes
;;; 08/**/87 R.Scheifler General syntactic and portability cleanups
;;; 08/**/87 R.Scheifler Rewrite of gcontext caching and shadowing
;;; 09/02/87 L.Oren Change events from resource-ids to objects
;;; 12/24/87 R.Budzianowski KCL support
;;; 12/**/87 J.Irwin ExCL 2.0 support
;;; 01/20/88 L.Oren Add server extension mechanisms
;;; 01/20/88 L.Oren Only force output when blocking on input
;;; 01/20/88 L.Oren Uniform support for :event-window on events
;;; 01/28/88 L.Oren Add window manager property functions
;;; 01/28/88 L.Oren Add character translation facility
;;; 02/**/87 J.Irwin Allegro 2.2 support
;;; This is considered a somewhat changeable interface. Discussion of better
;;; integration with CLOS, support for user-specified subclassess of basic
;;; objects, and the additional functionality to match the C Xlib is still in
;;; progress. Bug reports should be addressed to bug-clx@expo.lcs.mit.edu.
;; Note: all of the following is in the package XLIB.
(in-package :xlib)
(pushnew :clx *features*)
(pushnew :xlib *features*)
(setf *features* (remove :no-clx *features*))
(defparameter *version* "MIT R5.02")
(pushnew :clx-mit-r4 *features*)
(pushnew :clx-mit-r5 *features*)
(defparameter *protocol-major-version* 11.)
(defparameter *protocol-minor-version* 0)
(defparameter *x-tcp-port*+ 6000) ;; add display number
(defparameter *protocol-families*
'(;; X11/X.h, Family*
(:internet . 0)
(:decnet . 1)
(:chaos . 2)
;; X11/Xauth.h "not part of X standard"
(:Local . 256)
(:Wild . 65535)
(:Netname . 254)
(:Krb5Principal . 253)
(:LocalHost . 252)))
;; Note: if you have read the Version 11 protocol document or C Xlib manual, most of
;; the relationships should be fairly obvious. We have no intention of writing yet
;; another moby document for this interface.
;; Types employed: display, window, pixmap, cursor, font, gcontext, colormap, color.
;; These types are defined solely by a functional interface; we do not specify
;; whether they are implemented as structures or flavors or ... Although functions
;; below are written using DEFUN, this is not an implementation requirement (although
;; it is a requirement that they be functions as opposed to macros or special forms).
;; It is unclear whether with-slots in the Common Lisp Object System must work on
;; them.
;; Windows, pixmaps, cursors, fonts, gcontexts, and colormaps are all represented as
;; compound objects, rather than as integer resource-ids. This allows applications
;; to deal with multiple displays without having an explicit display argument in the
;; most common functions. Every function uses the display object indicated by the
;; first argument that is or contains a display; it is an error if arguments contain
;; different displays, and predictable results are not guaranteed.
;; Each of window, pixmap, cursor, font, gcontext, and colormap have the following
;; five functions:
;(defun make-<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)
; (clx-values <mumble>)))
;(defun <mumble>-display (<mumble>)
; (declare (type <mumble> <mumble>)
; (clx-values display)))
;(defun <mumble>-id (<mumble>)
; (declare (type <mumble> <mumble>)
; (clx-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)
; (clx-values boolean)))
(deftype generalized-boolean () 't) ; (or null (not null))
(deftype card32 () '(unsigned-byte 32))
(deftype card29 () '(unsigned-byte 29))
(deftype card24 () '(unsigned-byte 24))
(deftype int32 () '(signed-byte 32))
(deftype card16 () '(unsigned-byte 16))
(deftype int16 () '(signed-byte 16))
(deftype card8 () '(unsigned-byte 8))
(deftype int8 () '(signed-byte 8))
(deftype card4 () '(unsigned-byte 4))
; Note that we are explicitly using a different rgb representation than what
; is actually transmitted in the protocol.
(deftype rgb-val () '(real 0 1))
; Note that we are explicitly using a different angle representation than what
; is actually transmitted in the protocol.
;;; From cmucl clx:
;;;
;;; This overrides the (probably incorrect) definition in clx.lisp. Since PI
;;; is irrational, there can't be a precise rational representation. In
;;; particular, the different float approximations will always be /=. This
;;; causes problems with type checking, because people might compute an
;;; argument in any precision. What we do is discard all the excess precision
;;; in the value, and see if the protocal encoding falls in the desired range
;;; (64'ths of a degree.)
;;;
(deftype angle () '(satisfies anglep))
(defun anglep (x)
(and (typep x 'real)
(<= (* -360 64)
(radians->int16 x)
(* 360 64))))
(deftype mask32 () 'card32)
(deftype mask16 () 'card16)
(deftype pixel () '(unsigned-byte 32))
(deftype image-depth () '(integer 0 32))
(deftype resource-id () 'card29)
(deftype keysym () 'card32)
; The following functions are provided by color objects:
; The intention is that IHS and YIQ and CYM interfaces will also exist.
; Note that we are explicitly using a different spectrum representation
; than what is actually transmitted in the protocol.
(def-clx-class (color (:constructor make-color-internal (red green blue))
(:copier nil) (:print-function print-color))
(red 0.0 :type rgb-val)
(green 0.0 :type rgb-val)
(blue 0.0 :type rgb-val))
(defun print-color (color stream depth)
(declare (type color color)
(ignore depth))
(print-unreadable-object (color stream :type t)
(prin1 (color-red color) stream)
(write-string " " stream)
(prin1 (color-green color) stream)
(write-string " " stream)
(prin1 (color-blue color) stream)))
(defun make-color (&key (red 1.0) (green 1.0) (blue 1.0) &allow-other-keys)
(declare (type rgb-val red green blue))
(declare (clx-values color))
(make-color-internal red green blue))
(defun color-rgb (color)
(declare (type color color))
(declare (clx-values red green blue))
(values (color-red color) (color-green color) (color-blue color)))
(def-clx-class (bitmap-format (:copier nil) (:print-function print-bitmap-format))
(unit 8 :type (member 8 16 32))
(pad 8 :type (member 8 16 32))
(lsb-first-p nil :type generalized-boolean))
(defun print-bitmap-format (bitmap-format stream depth)
(declare (type bitmap-format bitmap-format)
(ignore depth))
(print-unreadable-object (bitmap-format stream :type t)
(format stream "unit ~D pad ~D ~:[M~;L~]SB first"
(bitmap-format-unit bitmap-format)
(bitmap-format-pad bitmap-format)
(bitmap-format-lsb-first-p bitmap-format))))
(def-clx-class (pixmap-format (:copier nil) (:print-function print-pixmap-format))
(depth 0 :type image-depth)
(bits-per-pixel 8 :type (member 1 4 8 16 24 32))
(scanline-pad 8 :type (member 8 16 32)))
(defun print-pixmap-format (pixmap-format stream depth)
(declare (type pixmap-format pixmap-format)
(ignore depth))
(print-unreadable-object (pixmap-format stream :type t)
(format stream "depth ~D bits-per-pixel ~D scanline-pad ~D"
(pixmap-format-depth pixmap-format)
(pixmap-format-bits-per-pixel pixmap-format)
(pixmap-format-scanline-pad pixmap-format))))
(defparameter *atom-cache-size* 200)
(defparameter *resource-id-map-size* 500)
(def-clx-class (display (:include buffer)
(:constructor make-display-internal)
(:print-function print-display)
(:copier nil))
(host) ; Server Host
(display 0 :type integer) ; Display number on host
(after-function nil) ; Function to call after every request
(event-lock
(make-process-lock "CLX Event Lock")) ; with-event-queue lock
(event-queue-lock
(make-process-lock "CLX Event Queue Lock")) ; new-events/event-queue lock
(event-queue-tail ; last event in the event queue
nil :type (or null reply-buffer))
(event-queue-head ; Threaded queue of events
nil :type (or null reply-buffer))
(atom-cache (make-hash-table :test (atom-cache-map-test) :size *atom-cache-size*)
:type hash-table) ; Hash table relating atoms keywords
; to atom id's
(font-cache nil) ; list of font
(protocol-major-version 0 :type card16) ; Major version of server's X protocol
(protocol-minor-version 0 :type card16) ; minor version of servers X protocol
(vendor-name "" :type string) ; vendor of the server hardware
(resource-id-base 0 :type resource-id) ; resouce ID base
(resource-id-mask 0 :type resource-id) ; resource ID mask bits
(resource-id-byte nil) ; resource ID mask field (used with DPB & LDB)
(resource-id-count 0 :type resource-id) ; resource ID mask count
; (used for allocating ID's)
(resource-id-map (make-hash-table :test (resource-id-map-test)
:size *resource-id-map-size*)
:type hash-table) ; hash table maps resource-id's to
; objects (used in lookup functions)
(xid 'resourcealloc) ; allocator function
(byte-order #+clx-little-endian :lsbfirst ; connection byte order
#-clx-little-endian :msbfirst)
(release-number 0 :type card32) ; release of the server
(max-request-length 0 :type card16) ; maximum number 32 bit words in request
(default-screen) ; default screen for operations
(roots nil :type list) ; List of screens
(motion-buffer-size 0 :type card32) ; size of motion buffer
(xdefaults) ; contents of defaults from server
(image-lsb-first-p nil :type generalized-boolean)
(bitmap-format (make-bitmap-format) ; Screen image info
:type bitmap-format)
(pixmap-formats nil :type sequence) ; list of pixmap formats
(min-keycode 0 :type card8) ; minimum key-code
(max-keycode 0 :type card8) ; maximum key-code
(error-handler 'default-error-handler) ; Error handler function
(close-down-mode :destroy) ; Close down mode saved by Set-Close-Down-Mode
(authorization-name "" :type string)
(authorization-data "" :type (or (array (unsigned-byte 8)) string))
(last-width nil :type (or null card29)) ; Accumulated width of last string
(keysym-mapping nil ; Keysym mapping cached from server
:type (or null (array * (* *))))
(modifier-mapping nil :type list) ; ALIST of (keysym . state-mask) for all modifier keysyms
(keysym-translation nil :type list) ; An alist of (keysym object function)
; for display-local keysyms
(extension-alist nil :type list) ; extension alist, which has elements:
; (name major-opcode first-event first-error)
(event-extensions '#() :type vector) ; Vector mapping X event-codes to event keys
(performance-info) ; Hook for gathering performance info
(trace-history) ; Hook for debug trace
(plist nil :type list) ; hook for extension to hang data
;; These slots are used to manage multi-process input.
(input-in-progress nil) ; Some process reading from the stream.
; Updated with CONDITIONAL-STORE.
(pending-commands nil) ; Threaded list of PENDING-COMMAND objects
; for all commands awaiting replies.
; Protected by WITH-EVENT-QUEUE-INTERNAL.
(asynchronous-errors nil) ; Threaded list of REPLY-BUFFER objects
; containing error messages for commands
; which did not expect replies.
; Protected by WITH-EVENT-QUEUE-INTERNAL.
(report-asynchronous-errors ; When to report asynchronous errors
'(:immediately) :type list) ; The keywords that can be on this list
; are :IMMEDIATELY, :BEFORE-EVENT-HANDLING,
; and :AFTER-FINISH-OUTPUT
(event-process nil) ; Process ID of process awaiting events.
; Protected by WITH-EVENT-QUEUE.
(new-events nil :type (or null reply-buffer)) ; Pointer to the first new event in the
; event queue.
; Protected by WITH-EVENT-QUEUE.
(current-event-symbol ; Bound with PROGV by event handling macros
(list (gensym) (gensym)) :type cons)
(atom-id-map (make-hash-table :test (resource-id-map-test)
:size *atom-cache-size*)
:type hash-table)
)
(defun print-display-name (display stream)
(declare (type (or null display) display))
(cond (display
(princ (display-host display) stream)
(write-string ":" stream)
(princ (display-display display) stream))
(t
(write-string "(no display)" stream)))
display)
(defun print-display (display stream depth)
(declare (type display display)
(ignore depth))
(print-unreadable-object (display stream :type t)
(print-display-name display stream)
(write-string " (" stream)
(write-string (display-vendor-name display) stream)
(write-string " R" stream)
(prin1 (display-release-number display) stream)
(write-string ")" stream)))
;;(deftype drawable () '(or window pixmap))
(def-clx-class (drawable (:copier nil) (:print-function print-drawable))
(id 0 :type resource-id)
(display nil :type (or null display))
(plist nil :type list) ; Extension hook
)
(defun print-drawable (drawable stream depth)
(declare (type drawable drawable)
(ignore depth))
(print-unreadable-object (drawable stream :type t)
(print-display-name (drawable-display drawable) stream)
(write-string " " stream)
(prin1 (drawable-id drawable) stream)))
(def-clx-class (window (:include drawable) (:copier nil)
(:print-function print-drawable))
)
(def-clx-class (pixmap (:include drawable) (:copier nil)
(:print-function print-drawable))
)
(def-clx-class (visual-info (:copier nil) (:print-function print-visual-info))
(id 0 :type resource-id)
(display nil :type (or null display))
(class :static-gray :type (member :static-gray :static-color :true-color
:gray-scale :pseudo-color :direct-color))
(red-mask 0 :type pixel)
(green-mask 0 :type pixel)
(blue-mask 0 :type pixel)
(bits-per-rgb 1 :type card8)
(colormap-entries 0 :type card16)
(plist nil :type list) ; Extension hook
)
(defun print-visual-info (visual-info stream depth)
(declare (type visual-info visual-info)
(ignore depth))
(print-unreadable-object (visual-info stream :type t)
(prin1 (visual-info-bits-per-rgb visual-info) stream)
(write-string "-bit " stream)
(princ (visual-info-class visual-info) stream)
(write-string " " stream)
(print-display-name (visual-info-display visual-info) stream)
(write-string " " stream)
(prin1 (visual-info-id visual-info) stream)))
(def-clx-class (colormap (:copier nil) (:print-function print-colormap))
(id 0 :type resource-id)
(display nil :type (or null display))
(visual-info nil :type (or null visual-info))
)
(defun print-colormap (colormap stream depth)
(declare (type colormap colormap)
(ignore depth))
(print-unreadable-object (colormap stream :type t)
(when (colormap-visual-info colormap)
(princ (visual-info-class (colormap-visual-info colormap)) stream)
(write-string " " stream))
(print-display-name (colormap-display colormap) stream)
(write-string " " stream)
(prin1 (colormap-id colormap) stream)))
(def-clx-class (cursor (:copier nil) (:print-function print-cursor))
(id 0 :type resource-id)
(display nil :type (or null display))
)
(defun print-cursor (cursor stream depth)
(declare (type cursor cursor)
(ignore depth))
(print-unreadable-object (cursor stream :type t)
(print-display-name (cursor-display cursor) stream)
(write-string " " stream)
(prin1 (cursor-id cursor) stream)))
; Atoms are accepted as strings or symbols, and are always returned as keywords.
; Protocol-level integer atom ids are hidden, using a cache in the display object.
(deftype xatom () '(or string symbol))
(defparameter *predefined-atoms*
'#(nil :PRIMARY :SECONDARY :ARC :ATOM :BITMAP
:CARDINAL :COLORMAP :CURSOR
:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3
:CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7
:DRAWABLE :FONT :INTEGER :PIXMAP :POINT :RECTANGLE
:RESOURCE_MANAGER :RGB_COLOR_MAP :RGB_BEST_MAP
:RGB_BLUE_MAP :RGB_DEFAULT_MAP
:RGB_GRAY_MAP :RGB_GREEN_MAP :RGB_RED_MAP :STRING
:VISUALID :WINDOW :WM_COMMAND :WM_HINTS
:WM_CLIENT_MACHINE :WM_ICON_NAME :WM_ICON_SIZE
:WM_NAME :WM_NORMAL_HINTS :WM_SIZE_HINTS
:WM_ZOOM_HINTS :MIN_SPACE :NORM_SPACE :MAX_SPACE
:END_SPACE :SUPERSCRIPT_X :SUPERSCRIPT_Y
:SUBSCRIPT_X :SUBSCRIPT_Y
:UNDERLINE_POSITION :UNDERLINE_THICKNESS
:STRIKEOUT_ASCENT :STRIKEOUT_DESCENT
:ITALIC_ANGLE :X_HEIGHT :QUAD_WIDTH :WEIGHT
:POINT_SIZE :RESOLUTION :COPYRIGHT :NOTICE
:FONT_NAME :FAMILY_NAME :FULL_NAME :CAP_HEIGHT
:WM_CLASS :WM_TRANSIENT_FOR))
(deftype stringable () '(or string symbol))
(deftype fontable () '(or stringable font))
; Nil stands for CurrentTime.
(deftype timestamp () '(or null card32))
(defparameter *bit-gravity-vector*
'#(:forget :north-west :north :north-east :west
:center :east :south-west :south
:south-east :static))
(deftype bit-gravity ()
'(member :forget :north-west :north :north-east :west
:center :east :south-west :south :south-east :static))
(defparameter *win-gravity-vector*
'#(:unmap :north-west :north :north-east :west
:center :east :south-west :south :south-east
:static))
(deftype win-gravity ()
'(member :unmap :north-west :north :north-east :west
:center :east :south-west :south :south-east :static))
(deftype grab-status ()
'(member :success :already-grabbed :invalid-time :not-viewable))
; An association list.
(deftype alist (key-type-and-name datum-type-and-name)
(declare (ignore key-type-and-name datum-type-and-name))
'list)
(deftype clx-list (&optional element-type) (declare (ignore element-type)) 'list)
(deftype clx-sequence (&optional element-type) (declare (ignore element-type)) 'sequence)
; A sequence, containing zero or more repetitions of the given elements,
; with the elements expressed as (type name).
(deftype repeat-seq (&rest elts) elts 'sequence)
(deftype point-seq () '(repeat-seq (int16 x) (int16 y)))
(deftype seg-seq () '(repeat-seq (int16 x1) (int16 y1) (int16 x2) (int16 y2)))
(deftype rect-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)))
(deftype arc-seq ()
'(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)
(angle angle1) (angle angle2)))
(deftype gcontext-state () 'simple-vector)
(def-clx-class (gcontext (:copier nil) (:print-function print-gcontext))
;; The accessors convert to CLX data types.
(id 0 :type resource-id)
(display nil :type (or null display))
(drawable nil :type (or null drawable))
(cache-p t :type generalized-boolean)
(server-state (allocate-gcontext-state) :type gcontext-state)
(local-state (allocate-gcontext-state) :type gcontext-state)
(plist nil :type list) ; Extension hook
(next nil :type (or null gcontext))
)
(defun print-gcontext (gcontext stream depth)
(declare (type gcontext gcontext)
(ignore depth))
(print-unreadable-object (gcontext stream :type t)
(print-display-name (gcontext-display gcontext) stream)
(write-string " " stream)
(prin1 (gcontext-id gcontext) stream)))
(defparameter *event-mask-vector*
'#(:key-press :key-release :button-press :button-release
:enter-window :leave-window :pointer-motion :pointer-motion-hint
:button-1-motion :button-2-motion :button-3-motion :button-4-motion
:button-5-motion :button-motion :keymap-state :exposure :visibility-change
:structure-notify :resize-redirect :substructure-notify :substructure-redirect
:focus-change :property-change :colormap-change :owner-grab-button))
(deftype event-mask-class ()
'(member :key-press :key-release :owner-grab-button :button-press :button-release
:enter-window :leave-window :pointer-motion :pointer-motion-hint
:button-1-motion :button-2-motion :button-3-motion :button-4-motion
:button-5-motion :button-motion :exposure :visibility-change
:structure-notify :resize-redirect :substructure-notify :substructure-redirect
:focus-change :property-change :colormap-change :keymap-state))
(deftype event-mask ()
'(or mask32 (clx-list event-mask-class)))
(defparameter *pointer-event-mask-vector*
'#(%error %error :button-press :button-release
:enter-window :leave-window :pointer-motion :pointer-motion-hint
:button-1-motion :button-2-motion :button-3-motion :button-4-motion
:button-5-motion :button-motion :keymap-state))
(deftype pointer-event-mask-class ()
'(member :button-press :button-release
:enter-window :leave-window :pointer-motion :pointer-motion-hint
:button-1-motion :button-2-motion :button-3-motion :button-4-motion
:button-5-motion :button-motion :keymap-state))
(deftype pointer-event-mask ()
'(or mask32 (clx-list pointer-event-mask-class)))
(defparameter *device-event-mask-vector*
'#(:key-press :key-release :button-press :button-release :pointer-motion
:button-1-motion :button-2-motion :button-3-motion :button-4-motion
:button-5-motion :button-motion))
(deftype device-event-mask-class ()
'(member :key-press :key-release :button-press :button-release :pointer-motion
:button-1-motion :button-2-motion :button-3-motion :button-4-motion
:button-5-motion :button-motion))
(deftype device-event-mask ()
'(or mask32 (clx-list device-event-mask-class)))
(defparameter *state-mask-vector*
'#(:shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5
:button-1 :button-2 :button-3 :button-4 :button-5))
(deftype modifier-key ()
'(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5))
(deftype modifier-mask ()
'(or (member :any) mask16 (clx-list modifier-key)))
(deftype state-mask-key ()
'(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5)))
(defparameter *gcontext-components*
'(:function :plane-mask :foreground :background
:line-width :line-style :cap-style :join-style :fill-style
:fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode
:exposures :clip-x :clip-y :clip-mask :dash-offset :dashes
:arc-mode))
(deftype gcontext-key ()
'(member :function :plane-mask :foreground :background
:line-width :line-style :cap-style :join-style :fill-style
:fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode
:exposures :clip-x :clip-y :clip-mask :dash-offset :dashes
:arc-mode))
(deftype event-key ()
'(member :key-press :key-release :button-press :button-release :motion-notify
:enter-notify :leave-notify :focus-in :focus-out :keymap-notify
:exposure :graphics-exposure :no-exposure :visibility-notify
:create-notify :destroy-notify :unmap-notify :map-notify :map-request
:reparent-notify :configure-notify :gravity-notify :resize-request
:configure-request :circulate-notify :circulate-request :property-notify
:selection-clear :selection-request :selection-notify
:colormap-notify :client-message :mapping-notify))
(deftype error-key ()
'(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice
:illegal-request :implementation :length :match :name :pixmap :value :window))
(deftype draw-direction ()
'(member :left-to-right :right-to-left))
(defparameter *boole-vector*
'#(#.boole-clr #.boole-and #.boole-andc2 #.boole-1
#.boole-andc1 #.boole-2 #.boole-xor #.boole-ior
#.boole-nor #.boole-eqv #.boole-c2 #.boole-orc2
#.boole-c1 #.boole-orc1 #.boole-nand #.boole-set))
(deftype boole-constant ()
`(member ,boole-clr ,boole-and ,boole-andc2 ,boole-1
,boole-andc1 ,boole-2 ,boole-xor ,boole-ior
,boole-nor ,boole-eqv ,boole-c2 ,boole-orc2
,boole-c1 ,boole-orc1 ,boole-nand ,boole-set))
(def-clx-class (screen (:copier nil) (:print-function print-screen))
(root nil :type (or null window))
(width 0 :type card16)
(height 0 :type card16)
(width-in-millimeters 0 :type card16)
(height-in-millimeters 0 :type card16)
(depths nil :type (alist (image-depth depth) ((clx-list visual-info) visuals)))
(root-depth 1 :type image-depth)
(root-visual-info nil :type (or null visual-info))
(default-colormap nil :type (or null colormap))
(white-pixel 0 :type pixel)
(black-pixel 1 :type pixel)
(min-installed-maps 1 :type card16)
(max-installed-maps 1 :type card16)
(backing-stores :never :type (member :never :when-mapped :always))
(save-unders-p nil :type generalized-boolean)
(event-mask-at-open 0 :type mask32)
(plist nil :type list) ; Extension hook
)
(defun print-screen (screen stream depth)
(declare (type screen screen)
(ignore depth))
(print-unreadable-object (screen stream :type t)
(let ((display (drawable-display (screen-root screen))))
(print-display-name display stream)
(write-string "." stream)
(princ (position screen (display-roots display)) stream))
(write-string " " stream)
(prin1 (screen-width screen) stream)
(write-string "x" stream)
(prin1 (screen-height screen) stream)
(write-string "x" stream)
(prin1 (screen-root-depth screen) stream)
(when (screen-root-visual-info screen)
(write-string " " stream)
(princ (visual-info-class (screen-root-visual-info screen)) stream))))
(defun screen-root-visual (screen)
(declare (type screen screen)
(clx-values resource-id))
(visual-info-id (screen-root-visual-info screen)))
;; The list contains alternating keywords and integers.
(deftype font-props () 'list)
(def-clx-class (font-info (:copier nil) (:predicate nil))
(direction :left-to-right :type draw-direction)
(min-char 0 :type card16) ;; First character in font
(max-char 0 :type card16) ;; Last character in font
(min-byte1 0 :type card8) ;; The following are for 16 bit fonts
(max-byte1 0 :type card8) ;; and specify min&max values for
(min-byte2 0 :type card8) ;; the two character bytes
(max-byte2 0 :type card8)
(all-chars-exist-p nil :type generalized-boolean)
(default-char 0 :type card16)
(min-bounds nil :type (or null vector))
(max-bounds nil :type (or null vector))
(ascent 0 :type int16)
(descent 0 :type int16)
(properties nil :type font-props))
(def-clx-class (font (:constructor make-font-internal) (:copier nil)
(:print-function print-font))
(id-internal nil :type (or null resource-id)) ;; NIL when not opened
(display nil :type (or null display))
(reference-count 0 :type fixnum)
(name "" :type (or null string)) ;; NIL when ID is for a GContext
(font-info-internal nil :type (or null font-info))
(char-infos-internal nil :type (or null (simple-array int16 (*))))
(local-only-p t :type generalized-boolean) ;; When T, always calculate text extents locally
(plist nil :type list) ; Extension hook
)
(defun print-font (font stream depth)
(declare (type font font)
(ignore depth))
(print-unreadable-object (font stream :type t)
(if (font-name font)
(princ (font-name font) stream)
(write-string "(gcontext)" stream))
(write-string " " stream)
(print-display-name (font-display font) stream)
(when (font-id-internal font)
(write-string " " stream)
(prin1 (font-id font) stream))))
(defun font-id (font)
;; Get font-id, opening font if needed
(or (font-id-internal font)
(open-font-internal font)))
(defun font-font-info (font)
(or (font-font-info-internal font)
(query-font font)))
(defun font-char-infos (font)
(or (font-char-infos-internal font)
(progn (query-font font)
(font-char-infos-internal font))))
(defun make-font (&key id
display
(reference-count 0)
(name "")
(local-only-p t)
font-info-internal)
(make-font-internal :id-internal id
:display display
:reference-count reference-count
:name name
:local-only-p local-only-p
:font-info-internal font-info-internal))
; For each component (<name> <unspec> :type <type>) of font-info,
; there is a corresponding function:
;(defun font-<name> (font)
; (declare (type font font)
; (clx-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 (clx-values ,type))
(,accessor (font-font-info font)))))
fields))))
(make-font-info-accessors ignore
(direction draw-direction)
(min-char card16)
(max-char card16)
(min-byte1 card8)
(max-byte1 card8)
(min-byte2 card8)
(max-byte2 card8)
(all-chars-exist-p generalized-boolean)
(default-char card16)
(min-bounds vector)
(max-bounds vector)
(ascent int16)
(descent int16)
(properties font-props)))
(defun font-property (font name)
(declare (type font font)
(type keyword name))
(declare (clx-values (or null int32)))
(getf (font-properties font) name))
(macrolet ((make-mumble-equal (type)
;; When cached, EQ works fine, otherwise test resource id's and displays
(let ((predicate (xintern type '-equal))
(id (xintern type '-id))
(dpy (xintern type '-display)))
(if (member type *clx-cached-types*)
`(within-definition (,type make-mumble-equal)
(declaim (inline ,predicate))
(defun ,predicate (a b) (eq a b)))
`(within-definition (,type make-mumble-equal)
(defun ,predicate (a b)
(declare (type ,type a b))
(and (= (,id a) (,id b))
(eq (,dpy a) (,dpy b)))))))))
(make-mumble-equal window)
(make-mumble-equal pixmap)
(make-mumble-equal cursor)
(make-mumble-equal font)
(make-mumble-equal gcontext)
(make-mumble-equal colormap)
(make-mumble-equal drawable))
;;;
;;; Event-mask encode/decode functions
;;; Converts from keyword-lists to integer and back
;;;
(defun encode-mask (key-vector key-list key-type)
;; KEY-VECTOR is a vector containg bit-position keywords. The position of the
;; keyword in the vector indicates its bit position in the resulting mask
;; KEY-LIST is either a mask or a list of KEY-TYPE
;; Returns NIL when KEY-LIST is not a list or mask.
(declare (type (simple-array keyword (*)) key-vector)
(type (or mask32 list) key-list))
(declare (clx-values (or mask32 null)))
(typecase key-list
(mask32 key-list)
(list (let ((mask 0))
(dolist (key key-list mask)
(let ((bit (position key (the vector key-vector) :test #'eq)))
(unless bit
(x-type-error key key-type))
(setq mask (logior mask (ash 1 bit)))))))))
(defun decode-mask (key-vector mask)
(declare (type (simple-array keyword (*)) key-vector)
(type mask32 mask))
(declare (clx-values list))
(do ((m mask (ash m -1))
(bit 0 (1+ bit))
(len (length key-vector))
(result nil))
((or (zerop m) (>= bit len)) result)
(declare (type mask32 m)
(fixnum bit len)
(list result))
(when (oddp m)
(push (aref key-vector bit) result))))
(defun encode-event-mask (event-mask)
(declare (type event-mask event-mask))
(declare (clx-values mask32))
(or (encode-mask *event-mask-vector* event-mask 'event-mask-class)
(x-type-error event-mask 'event-mask)))
(defun make-event-mask (&rest keys)
;; This is only defined for core events.
;; Useful for constructing event-mask, pointer-event-mask, device-event-mask.
(declare (type (clx-list event-mask-class) keys))
(declare (clx-values mask32))
(encode-mask *event-mask-vector* keys 'event-mask-class))
(defun make-event-keys (event-mask)
;; This is only defined for core events.
(declare (type mask32 event-mask))
(declare (clx-values (clx-list event-mask-class)))
(decode-mask *event-mask-vector* event-mask))
(defun encode-device-event-mask (device-event-mask)
(declare (type device-event-mask device-event-mask))
(declare (clx-values mask32))
(or (encode-mask *device-event-mask-vector* device-event-mask
'device-event-mask-class)
(x-type-error device-event-mask 'device-event-mask)))
(defun encode-modifier-mask (modifier-mask)
(declare (type modifier-mask modifier-mask))
(declare (clx-values mask16))
(or (and (eq modifier-mask :any) #x8000)
(encode-mask *state-mask-vector* modifier-mask 'modifier-key)
(x-type-error modifier-mask 'modifier-mask)))
(defun encode-state-mask (state-mask)
(declare (type (or mask16 (clx-list state-mask-key)) state-mask))
(declare (clx-values mask16))
(or (encode-mask *state-mask-vector* state-mask 'state-mask-key)
(x-type-error state-mask '(or mask16 (clx-list state-mask-key)))))
(defun make-state-mask (&rest keys)
;; Useful for constructing modifier-mask, state-mask.
(declare (type (clx-list state-mask-key) keys))
(declare (clx-values mask16))
(encode-mask *state-mask-vector* keys 'state-mask-key))
(defun make-state-keys (state-mask)
(declare (type mask16 state-mask))
(declare (clx-values (clx-list state-mask-key)))
(decode-mask *state-mask-vector* state-mask))
(defun encode-pointer-event-mask (pointer-event-mask)
(declare (type pointer-event-mask pointer-event-mask))
(declare (clx-values mask32))
(or (encode-mask *pointer-event-mask-vector* pointer-event-mask
'pointer-event-mask-class)
(x-type-error pointer-event-mask 'pointer-event-mask)))

64
src/eclx/compile-and-load.lisp
View file

@ -1,64 +0,0 @@
;;; -*- Mode: Lisp; Package: USER; Base: 10; Syntax: Common-Lisp -*-
(in-package "COMMON-LISP-USER")
(pushnew :clx-debugging *features*)
;;; Aid function:
(defun comf (file)
(let ((output-file
(compile-file
(merge-pathnames
(pathname file)
*load-pathname*))))
(load output-file)))
(defvar *clocc-root*
(pathname-directory *load-pathname*))
(setf (logical-pathname-translations "clocc")
`(("src;port;sys;**;*" "**/*")
("**;*.*" "**/*.*")))
;;; First compile and load port:
(comf (make-pathname :directory '(:relative "clocc-port") :name "ext"))
(comf (make-pathname :directory '(:relative "clocc-port") :name "gray"))
(comf (make-pathname :directory '(:relative "clocc-port") :name "path"))
(comf (make-pathname :directory '(:relative "clocc-port") :name "sys"))
(comf (make-pathname :directory '(:relative "clocc-port") :name "net"))
(comf (make-pathname :directory '(:relative "clocc-port") :name "proc"))
;;; Then split-sequence
(comf (make-pathname :directory '(:relative "cclan") :name "split-sequence"))
;;; Then compile and load the true system:
(dolist (file (list
"package"
"depdefs"
"clx"
"dependent"
"macros" ; these are just macros
"bufmac" ; these are just macros
"buffer"
"display"
"gcontext"
"input"
"requests"
"fonts"
"graphics"
"text"
"attributes"
"translate"
"keysyms"
"manager"
"image"
"resource"))
(comf file))

77
src/eclx/debug/debug.lisp
View file

@ -1,77 +0,0 @@
;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES; Patch-file:T -*-
;;; CLX debugging code
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
;;; Created 04/09/87 14:30:41 by LaMott G. OREN
(in-package :xlib)
(export '(display-listen
readflush
check-buffer
check-finish
check-force
clear-next))
(defun display-listen (display)
(listen (display-input-stream display)))
(defun readflush (display)
;; Flushes Display's input stream, returning what was there
(let ((stream (display-input-stream display)))
(loop while (listen stream) collect (read-byte stream))))
;;-----------------------------------------------------------------------------
;; The following are useful display-after functions
(defun check-buffer (display)
;; Ensure the output buffer in display is correct
(with-buffer-output (display :length :none :sizes (8 16))
(do* ((i 0 (+ i length))
request
length)
((>= i buffer-boffset)
(unless (= i buffer-boffset)
(warn "Buffer size ~d Requests end at ~d" buffer-boffset i)))
(let ((buffer-boffset 0)
#+clx-overlapping-arrays
(buffer-woffset 0))
(setq request (card8-get i))
(setq length (* 4 (card16-get (+ i 2)))))
(when (zerop request)
(warn "Zero request in buffer")
(return nil))
(when (zerop length)
(warn "Zero length in buffer")
(return nil)))))
(defun check-finish (display)
(check-buffer display)
(display-finish-output display))
(defun check-force (display)
(check-buffer display)
(display-force-output display))
(defun clear-next (display)
;; Never append requests
(setf (display-last-request display) nil))
;; End of file

1243
src/eclx/debug/describe.lisp
View file

File diff suppressed because it is too large Load diff

237
src/eclx/debug/event-test.lisp
View file

@ -1,237 +0,0 @@
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: (XTEST (XLIB LISP)); Base: 10; Lowercase: Yes -*-
(in-package :xtest :use '(:xlib :lisp))
(defstruct event
key ; Event key
display ; Display event was reported to
;; The following are from the CLX event
code
state
time
event-window
root
drawable
window
child
parent
root-x
root-y
x
y
width
height
border-width
override-redirect-p
same-screen-p
configure-p
hint-p
kind
mode
keymap
focus-p
count
major
minor
above-sibling
place
atom
selection
requestor
target
property
colormap
new-p
installed-p
format
type
data
send-event-p
)
(defun process-input (display &optional timeout)
"Process one event"
(declare (type display display) ; The display (from initialize-clue)
(type (or null number) timeout) ; optional timeout in seconds
(values (or null character))) ; Returns NIL only if timeout exceeded
(let ((event (make-event)))
(setf (event-display event) display)
(macrolet ((set-event (&rest parameters)
`(progn ,@(mapcar #'(lambda (parm)
`(setf (,(intern (concatenate 'string
(string 'event-)
(string parm)))
event) ,parm))
parameters)))
(dispatch (contact)
`(dispatch-event event event-key send-event-p ,contact)))
(let ((result
(xlib:event-case (display :timeout timeout :force-output-p t)
((:key-press :key-release :button-press :button-release)
(code time root window child root-x root-y x y
state same-screen-p event-key send-event-p)
(set-event code time root window child root-x root-y x y
state same-screen-p)
(dispatch window))
(:motion-notify
(hint-p time root window child root-x root-y x y
state same-screen-p event-key send-event-p)
(set-event hint-p time root window child root-x root-y x y
state same-screen-p)
(dispatch window))
((:enter-notify :leave-notify)
(kind time root window child root-x root-y x y
state mode focus-p same-screen-p event-key send-event-p)
(set-event kind time root window child root-x root-y x y
state mode focus-p same-screen-p)
(dispatch window))
((:focus-in :focus-out)
(kind window mode event-key send-event-p)
(set-event kind window mode)
(dispatch window))
(:keymap-notify
(window keymap event-key send-event-p)
(set-event window keymap)
(dispatch window))
(:exposure
(window x y width height count event-key send-event-p)
(set-event window x y width height count)
(dispatch window))
(:graphics-exposure
(drawable x y width height count major minor event-key send-event-p)
(set-event drawable x y width height count major minor)
(dispatch drawable))
(:no-exposure
(drawable major minor event-key send-event-p)
(set-event drawable major minor)
(dispatch drawable))
(:visibility-notify
(window state event-key send-event-p)
(set-event window state)
(dispatch window))
(:create-notify
(parent window x y width height border-width
override-redirect-p event-key send-event-p)
(set-event parent window x y width height border-width
override-redirect-p)
(dispatch parent))
(:destroy-notify
(event-window window event-key send-event-p)
(set-event event-window window)
(dispatch event-window))
(:unmap-notify
(event-window window configure-p event-key send-event-p)
(set-event event-window window configure-p)
(dispatch event-window))
(:map-notify
(event-window window override-redirect-p event-key send-event-p)
(set-event event-window window override-redirect-p)
(dispatch event-window))
(:map-request
(parent window event-key send-event-p)
(set-event parent window)
(dispatch parent))
(:reparent-notify
(event-window window parent x y override-redirect-p event-key send-event-p)
(set-event event-window window parent x y override-redirect-p)
(dispatch event-window))
(:configure-notify
(event-window window above-sibling x y width height border-width
override-redirect-p event-key send-event-p)
(set-event event-window window above-sibling x y width height
border-width override-redirect-p)
(dispatch event-window))
(:configure-request
(parent window above-sibling x y width height border-width event-key send-event-p)
(set-event parent window above-sibling x y width height border-width)
(dispatch parent))
(:gravity-notify
(event-window window x y event-key send-event-p)
(set-event event-window window x y)
(dispatch event-window))
(:resize-request
(window width height event-key send-event-p)
(set-event window width height)
(dispatch window))
(:circulate-notify
(event-window window parent place event-key send-event-p)
(set-event event-window window parent place)
(dispatch event-window))
(:circulate-request
(parent window place event-key send-event-p)
(set-event parent window place)
(dispatch parent))
(:property-notify
(window atom time state event-key send-event-p)
(set-event window atom time state)
(dispatch window))
(:selection-clear
(time window selection event-key send-event-p)
(set-event time window selection)
(dispatch window))
(:selection-request
(time window requestor selection target property event-key send-event-p)
(set-event time window requestor selection target property)
(dispatch window))
(:selection-notify
(time window selection target property event-key send-event-p)
(set-event time window selection target property)
(dispatch window))
(:colormap-notify
(window colormap new-p installed-p event-key send-event-p)
(set-event window colormap new-p installed-p)
(dispatch window))
(:client-message
(format window type data event-key send-event-p)
(set-event format window type data)
(dispatch window))
(:mapping-notify
(request start count)
(mapping-notify display request start count)) ;; Special case
)))
(and result t)))))
(defun event-case-test (display)
;; Tests universality of display, event-key, event-code, send-event-p and event-window
(event-case (display)
((key-press key-release button-press button-release motion-notify
enter-notify leave-notify focus-in focus-out keymap-notify
exposure graphics-exposure no-exposure visibility-notify
create-notify destroy-notify unmap-notify map-notify map-request
reparent-notify configure-notify gravity-notify resize-request
configure-request circulate-notify circulate-request property-notify
selection-clear selection-request selection-notify colormap-notify client-message)
(display event-key event-code send-event-p event-window)
(print (list display event-key event-code send-event-p event-window)))
(mapping-notify ;; mapping-notify doesn't have event-window
(display event-key event-code send-event-p)
(print (list display event-key event-code send-event-p)))
))

266
src/eclx/debug/keytrans.lisp
View file

@ -1,266 +0,0 @@
;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
;;; CLX keysym-translation test programs
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
(in-package :xlib)
(defun list-missing-keysyms ()
;; Lists explorer characters which have no keysyms
(dotimes (i 256)
(unless (character->keysyms (int-char i))
(format t "~%(define-keysym ~@c ~d)" (int-char i) i))))
(defun list-multiple-keysyms ()
;; Lists characters with more than one keysym
(dotimes (i 256)
(when (cdr (character->keysyms (int-char i)))
(format t "~%Character ~@c [~d] has keysyms" (int-char i) i)
(dolist (keysym (character->keysyms (int-char i)))
(format t " ~d ~d" (ldb (byte 8 8) keysym) (ldb (byte 8 0) keysym))))))
(defun check-lowercase-keysyms ()
;; Checks for keysyms with incorrect :lowercase parameters
(maphash #'(lambda (key mapping)
(let* ((value (car mapping))
(char (keysym-mapping-object value)))
(if (and (characterp char) (both-case-p char)
(= (char-int char) (char-int (char-upcase char))))
;; uppercase alphabetic character
(unless (eq (keysym-mapping-lowercase value)
(char-int (char-downcase char)))
(let ((lowercase (keysym-mapping-lowercase value))
(should-be (char-downcase char)))
(format t "~%Error keysym ~3d ~3d (~@c) has :Lowercase ~3d ~3d (~s) Should be ~3d ~3d (~@c)"
(ldb (byte 8 8) key)
(ldb (byte 8 0) key)
char
(and lowercase (ldb (byte 8 8) lowercase))
(and lowercase (ldb (byte 8 0) lowercase))
(int-char lowercase)
(ldb (byte 8 8) (char-int should-be))
(ldb (byte 8 0) (char-int should-be))
should-be)))
(when (keysym-mapping-lowercase value)
(let ((lowercase (keysym-mapping-lowercase value)))
(format t "~%Error keysym ~3d ~3d (~@c) has :lowercase ~3d ~3d (~@c) and shouldn't"
(ldb (byte 8 8) key)
(ldb (byte 8 0) key)
char
(and lowercase (ldb (byte 8 8) (char-int lowercase)))
(and lowercase (ldb (byte 8 0) (char-int lowercase)))
lowercase
))))))
*keysym->character-map*))
(defun print-all-keysyms ()
(let ((all nil))
(maphash #'(lambda (key value) (push (cons key value) all)) *keysym->character-map*)
(setq all (sort all #'< :key #'car))
(format t "~%~d keysyms:" (length all))
(dolist (keysym all)
(format t "~%~3d ~3d~{ ~s~}"
(ldb (byte 8 8) (car keysym))
(ldb (byte 8 0) (car keysym))
(cadr keysym))
(dolist (mapping (cddr keysym))
(format t "~%~7@t~{ ~s~}" mapping)))))
(defun keysym-mappings (keysym &key display (mask-format #'identity))
;; Return all the keysym mappings for keysym.
;; Returns a list of argument lists that are argument-lists to define-keysym.
;; The following will re-create the mappings for KEYSYM:
;; (dolist (mapping (keysym-mappings) keysym)
;; (apply #'define-keysym mapping))
(let ((mappings (append (and display (cdr (assoc keysym (display-keysym-translation display))))
(gethash keysym *keysym->character-map*)))
(result nil))
(dolist (mapping mappings)
(let ((object (keysym-mapping-object mapping))
(translate (keysym-mapping-translate mapping))
(lowercase (keysym-mapping-lowercase mapping))
(modifiers (keysym-mapping-modifiers mapping))
(mask (keysym-mapping-mask mapping)))
(push (append (list object keysym)
(when translate (list :translate translate))
(when lowercase (list :lowercase lowercase))
(when modifiers (list :modifiers (funcall mask-format modifiers)))
(when mask (list :mask (funcall mask-format mask))))
result)))
(nreverse result)))
#+comment
(defun print-keysym-mappings (keysym &optional display)
(format t "~%(keysym ~d ~3d) "
(ldb (byte 8 8) keysym)
(ldb (byte 8 0) keysym))
(dolist (mapping (keysym-mappings keysym :display display))
(format t "~16t~{ ~s~}~%" mapping)))
(defun print-keysym-mappings (keysym &optional display)
(flet ((format-mask (mask)
(cond ((numberp mask)
`(make-state-mask ,@(make-state-keys mask)))
((atom mask) mask)
(t `(list ,@(mapcar
#'(lambda (item)
(if (numberp item)
`(keysym ,(keysym-mapping-object
(car (gethash item *keysym->character-map*))))
item))
mask))))))
(dolist (mapping (keysym-mappings keysym :display display :mask-format #'format-mask))
(format t "~%(define-keysym ~s (keysym ~d ~3d)~{ ~s~})"
(car mapping)
(ldb (byte 8 8) keysym)
(ldb (byte 8 0) keysym)
(cdr mapping)))))
(defun keysym-test (host)
;; Server key-press Loop-back test
(let* ((display (open-display host))
(width 400)
(height 400)
(screen (display-default-screen display))
(black (screen-black-pixel screen))
(white (screen-white-pixel screen))
(win (create-window
:parent (screen-root screen)
:background black
:border white
:border-width 1
:colormap (screen-default-colormap screen)
:bit-gravity :center
:event-mask '(:exposure :key-press)
:x 20 :y 20
:width width :height height))
#+comment
(gc (create-gcontext
:drawable win
:background black
:foreground white)))
(initialize-extensions display)
(map-window win) ; Map the window
;; Handle events
(unwind-protect
(dotimes (state 64)
(do ((code (display-min-keycode display) (1+ code)))
((> code (display-max-keycode display)))
(send-event win :key-press '(:key-press) :code code :state state
:window win :root (screen-root screen) :time 0
:x 1 :y 2 :root-x 10 :root-y 20 :same-screen-p t)
(event-case (display :force-output-p t :discard-p t)
(exposure ;; Come here on exposure events
(window count)
(when (zerop count) ;; Ignore all but the last exposure event
(clear-area window))
nil)
(key-press (display code state)
(princ (keycode->character display code state))
t))))
(close-display display))))
(defun keysym-echo (host &optional keymap-p)
;; Echo characters typed to a window
(let* ((display (open-display host))
(width 400)
(height 400)
(screen (display-default-screen display))
(black (screen-black-pixel screen))
(white (screen-white-pixel screen))
(win (create-window
:parent (screen-root screen)
:background black
:border white
:border-width 1
:colormap (screen-default-colormap screen)
:bit-gravity :center
:event-mask '(:exposure :key-press :keymap-state :enter-window)
:x 20 :y 20
:width width :height height))
(gc (create-gcontext
:drawable win
:background black
:foreground white)))
(initialize-extensions display)
(map-window win) ; Map the window
;; Handle events
(unwind-protect
(event-case (display :force-output-p t :discard-p t)
(exposure ;; Come here on exposure events
(window count)
(when (zerop count) ;; Ignore all but the last exposure event
(clear-area window)
(draw-glyphs window gc 10 10 "Press <escape> to exit"))
nil)
(key-press (display code state)
(let ((char (keycode->character display code state)))
(format t "~%Code: ~s State: ~s Char: ~s" code state char)
;; (PRINC char) (PRINC " ")
(when keymap-p
(let ((keymap (query-keymap display)))
(unless (character-in-map-p display char keymap)
(print "character-in-map-p failed")
(print-keymap keymap))))
;; (when (eql char #\0) (setq disp display) (break))
(eql char #\escape)))
(keymap-notify (keymap)
(print "Keymap-notify") ;; we never get here. Server bug?
(when (keysym-in-map-p display 65 keymap)
(print "Found A"))
(when (character-in-map-p display #\b keymap)
(print "Found B")))
(enter-notify (event-window) (format t "~%Enter ~s" event-window)))
(close-display display))))
(defun print-keymap (keymap)
(do ((j 32 (+ j 32))) ;; first 32 bits is for window
((>= j 256))
(format t "~% ~3d: " j)
(do ((i j (1+ i)))
((>= i (+ j 32)))
(when (zerop (logand i 7))
(princ " "))
(princ (aref keymap i)))))
(defun define-keysym-test (&key display printp
(modifiers (list (keysym :left-meta))) (mask :modifiers))
(let* ((keysym 067)
(args `(baz ,keysym :modifiers ,modifiers ,@(and mask `(:mask ,mask))))
(original (copy-tree (keysym-mappings keysym :display display))))
(when printp (print-keysym-mappings 67) (terpri))
(apply #'define-keysym args)
(when printp (print-keysym-mappings 67) (terpri))
(let ((is (keysym-mappings keysym :display display))
(should-be (append original (list args))))
(unless (equal is should-be)
(cerror "Ignore" "define-keysym error. ~%is: ~s ~%Should be: ~s" is should-be)))
(apply #'undefine-keysym args)
(when printp (print-keysym-mappings 67) (terpri))
(let ((is (keysym-mappings keysym :display display)))
(unless (equal is original)
(cerror "Ignore" "undefine-keysym error. ~%is: ~s ~%Should be: ~s" is original)))))
(define-keysym-test)
(define-keysym-test :modifiers (make-state-mask :shift :lock))
(define-keysym-test :modifiers (list :shift (keysym :left-meta) :control))
(define-keysym-test :modifiers (make-state-mask :shift :lock) :mask nil)

456
src/eclx/debug/trace.lisp
View file

@ -1,456 +0,0 @@
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
;; Trace works by substituting trace functions for the display-write/input functions.
;; The trace functions maintain a database of requests sent to the server in the
;; trace-history display property. This is an alist of (id . byte-vector) where
;; id is the request number for writes, :reply for replies, :event for events and
;; :error for errors. The alist is kept in reverse order (most recent first)
;; In a multiprocessing system is it very helpful to know what process wrote or
;; read certain requests. Thus I have modified the format of the trace-history
;; list. It is now an alist of: ((id . more-info) . byte-vector).
;; (more-info is a list returned by the trace-more-info function).
;; Also added the ability to suspend and resume tracing without destroying the
;; trace history. Renamed 'display-trace' to 'show-trace' to avoid confusion.
;; 7feb91 -- jdi
;;; Created 09/14/87 by LaMott G. OREN
(in-package :xlib)
(eval-when (load eval)
(export '(trace-display
suspend-display-tracing
resume-display-tracing
untrace-display
show-trace
display-trace ; for backwards compatibility
describe-request
describe-event
describe-reply
describe-error
describe-trace)))
(defun trace-display (display)
"Start a trace on DISPLAY.
If display is already being traced, this discards previous history.
See show-trace and describe-trace."
(declare (type display display))
(unless (getf (display-plist display) 'write-function)
(bind-io-hooks display))
(setf (display-trace-history display) nil)
t)
(defun suspend-display-tracing (display)
"Tracing is suspended, but history is not cleared."
(if (getf (display-plist display) 'suspend-display-tracing)
(warn "Tracing is already suspend for ~s" display)
(progn
(unbind-io-hooks display)
(setf (getf (display-plist display) 'suspend-display-tracing) t))))
(defun resume-display-tracing (display)
"Used to resume tracing after suspending"
(if (getf (display-plist display) 'suspend-display-tracing)
(progn
(bind-io-hooks display)
(remf (display-plist display) 'suspend-display-tracing))
(warn "Tracing was not suspended for ~s" display)))
(defun untrace-display (display)
"Stop tracing DISPLAY."
(declare (type display display))
(if (not (getf (display-plist display) 'suspend-display-tracing))
(unbind-io-hooks display)
(remf (display-plist display) 'suspend-display-tracing))
(setf (display-trace-history display) nil))
;; Assumes tracing is not already on.
(defun bind-io-hooks (display)
(let ((write-function (display-write-function display))
(input-function (display-input-function display)))
;; Save origional write/input functions so we can untrace
(setf (getf (display-plist display) 'write-function) write-function)
(setf (getf (display-plist display) 'input-function) input-function)
;; Set new write/input functions that will record what's sent to the server
(setf (display-write-function display)
#'(lambda (vector display start end)
(trace-write-hook vector display start end)
(funcall write-function vector display start end)))
(setf (display-input-function display)
#'(lambda (display vector start end timeout)
(let ((result (funcall input-function
display vector start end timeout)))
(unless result
(trace-read-hook display vector start end))
result)))))
(defun unbind-io-hooks (display)
(let ((write-function (getf (display-plist display) 'write-function))
(input-function (getf (display-plist display) 'input-function)))
(when write-function
(setf (display-write-function display) write-function))
(when input-function
(setf (display-input-function display) input-function))
(remf (display-plist display) 'write-function)
(remf (display-plist display) 'input-function)))
(defun byte-ref16 (vector index)
#+clx-little-endian
(logior (the card16
(ash (the card8 (aref vector (index+ index 1))) 8))
(the card8
(aref vector index)))
#-clx-little-endian
(logior (the card16
(ash (the card8 (aref vector index)) 8))
(the card8
(aref vector (index+ index 1)))))
(defun byte-ref32 (a i)
(declare (type buffer-bytes a)
(type array-index i))
(declare (values card32))
(declare-buffun)
#+clx-little-endian
(the card32
(logior (the card32
(ash (the card8 (aref a (index+ i 3))) 24))
(the card29
(ash (the card8 (aref a (index+ i 2))) 16))
(the card16
(ash (the card8 (aref a (index+ i 1))) 8))
(the card8
(aref a i))))
#-clx-little-endian
(the card32
(logior (the card32
(ash (the card8 (aref a i)) 24))
(the card29
(ash (the card8 (aref a (index+ i 1))) 16))
(the card16
(ash (the card8 (aref a (index+ i 2))) 8))
(the card8
(aref a (index+ i 3))))))
(defun trace-write-hook (vector display start end)
;; Called only by buffer-flush. Start should always be 0
(unless (zerop start)
(format *debug-io* "write-called with non-zero start: ~d" start))
(let* ((history (display-trace-history display))
(request-number (display-request-number display))
(last-history (car history)))
;; There may be several requests in the buffer, and the last one may be
;; incomplete. The first one may be the completion of a previous request.
;; We can detect incomplete requests by comparing the expected length of
;; the last request with the actual length.
(when (and last-history (numberp (caar last-history)))
(let* ((last-length (index* 4 (byte-ref16 (cdr last-history) 2)))
(append-length (min (- last-length (length (cdr last-history)))
(- end start))))
(when (plusp append-length)
;; Last history incomplete - append to last
(setf (cdr last-history)
(concatenate '(vector card8) (cdr last-history)
(subseq vector start (+ start append-length))))
(index-incf start append-length))))
;; Copy new requests into the history
(do* ((new-history nil)
(i start (+ i length))
request
length)
((>= i end)
;; add in sequence numbers
(dolist (entry new-history)
(setf (caar entry) request-number)
(decf request-number))
(setf (display-trace-history display)
(nconc new-history history)))
(setq request (aref vector i))
(setq length (index* 4 (byte-ref16 vector (+ i 2))))
(when (zerop length)
(warn "Zero length in buffer")
(return nil))
(push (cons (cons 0 (trace-more-info display request vector
i (min (+ i length) end)))
(subseq vector i (min (+ i length) end))) new-history)
(when (zerop request)
(warn "Zero length in buffer")
(return nil)))))
(defun trace-read-hook (display vector start end)
;; Reading is done with an initial length of 32 (with start = 0)
;; This may be followed by several other reads for long replies.
(let* ((history (display-trace-history display))
(last-history (car history))
(length (- end start)))
(when (and history (eq (caar last-history) :reply))
(let* ((last-length (index+ 32 (index* 4 (byte-ref32 (cdr last-history) 4))))
(append-length (min (- last-length (length (cdr last-history)))
(- end start))))
(when (plusp append-length)
(setf (cdr last-history)
(concatenate '(vector card8) (cdr last-history)
(subseq vector start (+ start append-length))))
(index-incf start append-length)
(index-decf length append-length))))
;; Copy new requests into the history
(when (plusp length)
(let ((reply-type (case (aref vector start) (0 :error) (1 :reply)
(otherwise :event))))
(push (cons (cons reply-type
(trace-more-info display reply-type vector start
(+ start length)))
(subseq vector start (+ start length)))
(display-trace-history display))))))
(defun trace-more-info (display request-id vector start end)
;; Currently only returns current process.
#+allegro
(list mp::*current-process*))
(defun show-trace (display &key length show-process)
"Display the trace history for DISPLAY.
The default is to show ALL history entries.
When the LENGTH parameter is used, only the last LENGTH entries are
displayed."
(declare (type display display))
(dolist (hist (reverse (subseq (display-trace-history display)
0 length)))
(let* ((id (caar hist))
(more-info (cdar hist))
(vector (cdr hist))
(length (length vector))
(request (aref vector 0)))
(format t "~%~5d " id)
(case id
(:error
(trace-error-print display more-info vector))
(:event
(format t "~a (~d) Sequence ~d"
(if (< request (length *event-key-vector*))
(aref *event-key-vector* request)
"Unknown")
request
(byte-ref16 vector 2))
(when show-process
#+allegro
(format t ", Proc ~a" (mp::process-name (car more-info)))))
(:reply
(format t "To ~d length ~d"
(byte-ref16 vector 2) length)
(let ((actual-length (index+ 32 (index* 4 (byte-ref32 vector 4)))))
(unless (= length actual-length)
(format t " Should be ~d **************" actual-length)))
(when show-process
#+allegro
(format t ", Proc ~a" (mp::process-name (car more-info)))))
(otherwise
(format t "~a (~d) length ~d"
(request-name request) request length)
(when show-process
#+allegro
(format t ", Proc ~a" (mp::process-name (car more-info)))))))))
;; For backwards compatibility
(defun display-trace (&rest args)
(apply 'show-trace args))
(defun find-trace (display type sequence &optional (number 0))
(dolist (history (display-trace-history display))
(when (and (symbolp (caar history))
(= (logandc2 (aref (cdr history) 0) 128) type)
(= (byte-ref16 (cdr history) 2) sequence)
(minusp (decf number)))
(return (cdr history)))))
(defun describe-error (display sequence)
"Describe the error associated with request SEQUENCE."
(let ((vector (find-trace display 0 sequence)))
(if vector
(progn
(terpri)
(trace-error-print display nil vector))
(format t "Error with sequence ~d not found." sequence))))
(defun trace-error-print (display more-info vector
&optional (stream *standard-output*))
(let ((event (allocate-event)))
;; Copy into event from reply buffer
(buffer-replace (reply-ibuf8 event)
vector
0
*replysize*)
(reading-event (event)
(let* ((type (read-card8 0))
(error-code (read-card8 1))
(sequence (read-card16 2))
(resource-id (read-card32 4))
(minor-code (read-card16 8))
(major-code (read-card8 10))
(current-sequence (ldb (byte 16 0) (buffer-request-number display)))
(error-key
(if (< error-code (length *xerror-vector*))
(aref *xerror-vector* error-code)
'unknown-error))
(params
(case error-key
((colormap-error cursor-error drawable-error font-error gcontext-error
id-choice-error pixmap-error window-error)
(list :resource-id resource-id))
(atom-error
(list :atom-id resource-id))
(value-error
(list :value resource-id))
(unknown-error
;; Prevent errors when handler is a sequence
(setq error-code 0)
(list :error-code error-code)))))
type
(let ((condition
(apply #+lispm #'si:make-condition
#+allegro #'make-condition
#-(or lispm allegro) #'make-condition
error-key
:error-key error-key
:display display
:major major-code
:minor minor-code
:sequence sequence
:current-sequence current-sequence
params)))
(princ condition stream)
(deallocate-event event)
condition)))))
(defun describe-request (display sequence)
"Describe the request with sequence number SEQUENCE"
#+ti (si:load-if "clx:debug;describe")
(let ((request (assoc sequence (display-trace-history display)
:test #'(lambda (item key)
(eql item (car key))))))
(if (null request)
(format t "~%Request number ~d not found in trace history" sequence)
(let* ((vector (cdr request))
(len (length vector))
(hist (make-reply-buffer len)))
(buffer-replace (reply-ibuf8 hist) vector 0 len)
(print-history-description hist)))))
(defun describe-reply (display sequence)
"Print the reply to request SEQUENCE.
(The current implementation doesn't print very pretty)"
(let ((vector (find-trace display 1 sequence))
(*print-array* t))
(if vector
(print vector)
(format t "~%Reply not found"))))
(defun event-number (name)
(if (integerp name)
(let ((name (logandc2 name 128)))
(if (typep name '(integer 0 63))
(aref *event-key-vector* name))
name)
(position (string name) *event-key-vector* :test #'equalp :key #'string)))
(defun describe-event (display name sequence &optional (number 0))
"Describe the event with event-name NAME and sequence number SEQUENCE.
If there is more than one event, return NUMBER in the sequence."
(declare (type display display)
(type (or stringable (integer 0 63)) name)
(integer sequence))
(let* ((event (event-number name))
(vector (and event (find-trace display event sequence number))))
(if (not event)
(format t "~%~s isn't an event name" name)
(if (not vector)
(if (and (plusp number) (setq vector (find-trace display event sequence 0)))
(do ((i 1 (1+ i))
(last-vector))
(nil)
(if (setq vector (find-trace display event sequence i))
(setq last-vector vector)
(progn
(format t "~%Event number ~d not found, last event was ~d"
number (1- i))
(return (trace-event-print display last-vector)))))
(format t "~%Event ~s not found"
(aref *event-key-vector* event)))
(trace-event-print display vector)))))
(defun trace-event-print (display vector)
(let* ((event (allocate-event))
(event-code (ldb (byte 7 0) (aref vector 0)))
(event-decoder (aref *event-handler-vector* event-code)))
;; Copy into event from reply buffer
(setf (event-code event) event-code)
(buffer-replace (reply-ibuf8 event)
vector
0
*replysize*)
(prog1 (funcall event-decoder display event
#'(lambda (&rest args &key send-event-p &allow-other-keys)
(setq args (copy-list args))
(remf args :display)
(remf args :event-code)
(unless send-event-p (remf args :send-event-p))
args))
(deallocate-event event))))
(defun describe-trace (display &optional length)
"Display the trace history for DISPLAY.
The default is to show ALL history entries.
When the LENGTH parameter is used, only the last LENGTH entries are
displayed."
(declare (type display display))
#+ti (si:load-if "clx:debug;describe")
(dolist (hist (reverse (subseq (display-trace-history display)
0 length)))
(let* ((id (car hist))
(vector (cdr hist))
(length (length vector)))
(format t "~%~5d " id)
(case id
(:error
(trace-error-print display nil vector))
(:event
(let ((event (trace-event-print display vector)))
(when event (format t "from ~d ~{ ~s~}"
(byte-ref16 vector 2) event))))
(:reply
(format t "To ~d length ~d"
(byte-ref16 vector 2) length)
(let ((actual-length (index+ 32 (index* 4 (byte-ref32 vector 4)))))
(unless (= length actual-length)
(format t " Should be ~d **************" actual-length)))
(let ((*print-array* t)
(*print-base* 16.))
(princ " ")
(princ vector)))
(otherwise
(let* ((len (length vector))
(hist (make-reply-buffer len)))
(buffer-replace (reply-ibuf8 hist) vector 0 len)
(print-history-description hist)))))))
;; End of file

167
src/eclx/debug/util.lisp
View file

@ -1,167 +0,0 @@
;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES; -*-
;; CLX utilities
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
;;; Created 04/09/87 14:30:41 by LaMott G. OREN
(in-package :xlib)
(export '(display-root
display-black
display-white
report-events
describe-window
describe-gc
degree
radian
display-refresh
root-tree
window-tree))
(defun display-root (display) (screen-root (display-default-screen display)))
(defun display-black (display) (screen-black-pixel (display-default-screen display)))
(defun display-white (display) (screen-white-pixel (display-default-screen display)))
(defun report-events (display)
(loop
(unless
(process-event display :handler #'(lambda (&rest args) (print args)) :discard-p t :timeout 0.001)
(return nil))))
(defun describe-window (window)
(macrolet ((da (attribute &key (transform 'progn) (format "~s"))
(let ((func (intern (concatenate 'string (string 'window-)
(string attribute)) 'xlib)))
`(format t "~%~22a ~?" ',attribute ,format (list (,transform (,func window))))))
(dg (attribute &key (transform 'progn) (format "~s"))
(let ((func (intern (concatenate 'string (string 'drawable-)
(string attribute)) 'xlib)))
`(format t "~%~22a ~?" ',attribute ,format (list (,transform (,func window)))))))
(with-state (window)
(when (window-p window)
(da visual :format "#x~x")
(da class)
(da gravity)
(da bit-gravity)
(da backing-store)
(da backing-planes :format "#x~x")
(da backing-pixel)
(da save-under)
(da colormap)
(da colormap-installed-p)
(da map-state)
(da all-event-masks :transform make-event-keys :format "~{~<~%~1:;~s ~>~}")
(da event-mask :transform make-event-keys :format "~{~<~%~1:;~s ~>~}")
(da do-not-propagate-mask :transform make-event-keys :format "~{~<~%~1:;~s ~>~}")
(da override-redirect)
)
(dg root)
(dg depth)
(dg x)
(dg y)
(dg width)
(dg height)
(dg border-width)
)))
(defun describe-gc (gc)
(macrolet ((dgc (name &key (transform 'progn) (format "~s"))
(let ((func (intern (concatenate 'string (string 'gcontext-)
(string name)) 'xlib)))
`(format t "~%~22a ~?" ',name ,format (list (,transform (,func gc)))))))
(dgc function)
(dgc plane-mask)
(dgc foreground)
(dgc background)
(dgc line-width)
(dgc line-style)
(dgc cap-style)
(dgc join-style)
(dgc fill-style)
(dgc fill-rule)
(dgc tile)
(dgc stipple)
(dgc ts-x)
(dgc ts-y)
(dgc font) ;; See below
(dgc subwindow-mode)
(dgc exposures)
(dgc clip-x)
(dgc clip-y)
;; (dgc clip-ordering)
(dgc clip-mask)
(dgc dash-offset)
(dgc dashes)
(dgc arc-mode)
))
(defun degree (degrees)
(* degrees (/ pi 180)))
(defun radian (radians)
(round (* radians (/ 180 pi))))
(defun display-refresh (host)
;; Useful for when the system writes to the screen (sometimes scrolling!)
(let ((display (open-display host)))
(unwind-protect
(let ((screen (display-default-screen display)))
(let ((win (create-window :parent (screen-root screen) :x 0 :y 0 :override-redirect :on
:width (screen-width screen) :height (screen-height screen)
:background (screen-black-pixel screen))))
(map-window win)
(display-finish-output display)
(unmap-window win)
(destroy-window win)
(display-finish-output display)))
(close-display display))))
(defun root-tree (host)
(let ((display (open-display host)))
(unwind-protect
(window-tree (screen-root (display-default-screen display)))
(close-display display)))
(values))
(defun window-tree (window &optional (depth 0))
;; Print the window tree and properties starting from WINDOW
;; Returns a list of windows in the order that they are printed.
(declare (arglist window)
(type window window)
(values (list window)))
(let ((props (mapcar #'(lambda (prop)
(multiple-value-bind (data type format)
(get-property window prop)
(case type
(:string (setq data (coerce data 'string))))
(list prop format type data)))
(list-properties window)))
(result (list window)))
(with-state (window)
(format t "~%~v@t#x~x~20,20t X~3d Y~3d W~4d H~3d ~s" depth (window-id window)
(drawable-x window) (drawable-y window)
(drawable-width window) (drawable-height window)
(window-map-state window)))
(dolist (prop props)
(format t "~%~v@t~{~s ~}" (+ depth 2) prop))
(dolist (w (query-tree window))
(setq result (nconc result (window-tree w (+ depth 2)))))
result))

39
src/eclx/demo/bezier.lisp
View file

@ -1,39 +0,0 @@
;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
;;; CLX interface for Bezier Spline Extension.
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
(in-package :xlib)
(export 'draw-curves)
(define-extension "bezier")
(defun draw-curves (drawable gcontext points)
;; Draw Bezier splines on drawable using gcontext.
;; Points are a list of (x0 y0 x1 y1 x2 y2 x3 y3)
(declare (type drawable drawable)
(type gcontext gcontext)
(type sequence points))
(let* ((display (drawable-display drawable))
(opcode (extension-opcode display "bezier")))
(with-buffer-request (display opcode :gc-force gcontext)
((data card8) 1) ;; X_PolyBezier - The minor_opcode for PolyBezier
(drawable drawable)
(gcontext gcontext)
((sequence :format int16) points))))

81
src/eclx/demo/beziertest.lisp
View file

@ -1,81 +0,0 @@
;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
;;; CLX Bezier Spline Extension demo program
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
(in-package :xlib)
(defun bezier-test (host &optional (pathname "/usr/X.V11R1/extensions/test/datafile"))
;; Display the part picture in /extensions/test/datafile
(let* ((display (open-display host))
(width 800)
(height 800)
(screen (display-default-screen display))
(black (screen-black-pixel screen))
(white (screen-white-pixel screen))
(win (create-window
:parent (screen-root screen)
:background black
:border white
:border-width 1
:colormap (screen-default-colormap screen)
:bit-gravity :center
:event-mask '(:exposure :key-press)
:x 20 :y 20
:width width :height height))
(gc (create-gcontext
:drawable win
:background black
:foreground white))
(lines (make-array (* 500 4) :fill-pointer 0 :element-type 'card16))
(curves (make-array (* 500 8) :fill-pointer 0 :element-type 'card16)))
;; Read the data
(with-open-file (stream pathname)
(loop
(case (read-char stream nil :eof)
(#\l (dotimes (i 4) (vector-push-extend (read stream) lines)))
(#\b (dotimes (i 8) (vector-push-extend (read stream) curves)))
((#\space #\newline #\tab))
(otherwise (return)))))
;; The data points were created to fit in a 2048x2048 square,
;; this means scale_factor will always be small enough so that
;; we don't need to worry about overflows.
(let ((factor (ash (min width height) 5)))
(dotimes (i (length lines))
(setf (svref lines i)
(ash (* (svref lines i) factor) -16)))
(dotimes (i (length curves))
(setf (svref curves i)
(ash (* (svref curves i) factor) -16))))
(map-window win) ; Map the window
;; Handle events
(unwind-protect
(loop
(event-case (display :force-output-p t)
(exposure ;; Come here on exposure events
(window count)
(when (zerop count) ;; Ignore all but the last exposure event
(clear-area window)
(draw-segments win gc lines)
(draw-curves win gc curves)
(draw-glyphs win gc 10 10 "Press any key to exit")
;; Returning non-nil causes event-case to exit
t))
(key-press () (return-from bezier-test t))))
(close-display display))))

65
src/eclx/demo/hello.lisp
View file

@ -1,65 +0,0 @@
;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*-
(in-package :xlib)
(defun hello-world (host &rest args &key (string "Hello World") (font "fixed"))
;; CLX demo, says STRING using FONT in its own window on HOST
(let ((display nil)
(abort t))
(unwind-protect
(progn
(setq display (open-display host))
(multiple-value-prog1
(let* ((screen (display-default-screen display))
(black (screen-black-pixel screen))
(white (screen-white-pixel screen))
(font (open-font display font))
(border 1) ; Minimum margin around the text
(width (+ (text-width font string) (* 2 border)))
(height (+ (max-char-ascent font) (max-char-descent font) (* 2 border)))
(x (truncate (- (screen-width screen) width) 2))
(y (truncate (- (screen-height screen) height) 2))
(window (create-window :parent (screen-root screen)
:x x :y y :width width :height height
:background black
:border white
:border-width 1
:colormap (screen-default-colormap screen)
:bit-gravity :center
:event-mask '(:exposure :button-press)))
(gcontext (create-gcontext :drawable window
:background black
:foreground white
:font font)))
;; Set window manager hints
(set-wm-properties window
:name 'hello-world
:icon-name string
:resource-name string
:resource-class 'hello-world
:command (list* 'hello-world host args)
:x x :y y :width width :height height
:min-width width :min-height height
:input :off :initial-state :normal)
(map-window window) ; Map the window
;; Handle events
(event-case (display :discard-p t :force-output-p t)
(exposure ;; Come here on exposure events
(window count)
(when (zerop count) ;; Ignore all but the last exposure event
(with-state (window)
(let ((x (truncate (- (drawable-width window) width) 2))
(y (truncate (- (+ (drawable-height window)
(max-char-ascent font))
(max-char-descent font))
2)))
;; Draw text centered in widnow
(clear-area window)
(draw-glyphs window gcontext x y string)))
;; Returning non-nil causes event-case to exit
nil))
(button-press () t))) ;; Pressing any mouse-button exits
(setq abort nil)))
;; Ensure display is closed when done
(when display
(close-display display :abort abort)))))

382
src/eclx/demo/menu.lisp
View file

@ -1,382 +0,0 @@
;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*-
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1988 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
(in-package :xlib)
;;;----------------------------------------------------------------------------------+
;;; |
;;; These functions demonstrate a simple menu implementation described in |
;;; Kimbrough, Kerry, "Windows to the Future", Lisp Pointers, Oct-Nov, 1987. |
;;; See functions JUST-SAY-LISP and POP-UP for demonstrations. |
;;; |
;;;----------------------------------------------------------------------------------+
(defstruct (menu)
"A simple menu of text strings."
(title "choose an item:")
item-alist ;((item-window item-string))
window
gcontext
width
title-width
item-width
item-height
(geometry-changed-p t)) ;nil iff unchanged since displayed
(defun create-menu (parent-window text-color background-color text-font)
(make-menu
;; Create menu graphics context
:gcontext (CREATE-GCONTEXT :drawable parent-window
:foreground text-color
:background background-color
:font text-font)
;; Create menu window
:window (CREATE-WINDOW
:parent parent-window
:class :input-output
:x 0 ;temporary value
:y 0 ;temporary value
:width 16 ;temporary value
:height 16 ;temporary value
:border-width 2
:border text-color
:background background-color
:save-under :on
:override-redirect :on ;override window mgr when positioning
:event-mask (MAKE-EVENT-MASK :leave-window
:exposure))))
(defun menu-set-item-list (menu &rest item-strings)
;; Assume the new items will change the menu's width and height
(setf (menu-geometry-changed-p menu) t)
;; Destroy any existing item windows
(dolist (item (menu-item-alist menu))
(DESTROY-WINDOW (first item)))
;; Add (item-window item-string) elements to item-alist
(setf (menu-item-alist menu)
(let (alist)
(dolist (item item-strings (nreverse alist))
(push (list (CREATE-WINDOW
:parent (menu-window menu)
:x 0 ;temporary value
:y 0 ;temporary value
:width 16 ;temporary value
:height 16 ;temporary value
:background (GCONTEXT-BACKGROUND (menu-gcontext menu))
:event-mask (MAKE-EVENT-MASK :enter-window
:leave-window
:button-press
:button-release))
item)
alist)))))
(defparameter *menu-item-margin* 4
"Minimum number of pixels surrounding menu items.")
(defun menu-recompute-geometry (menu)
(when (menu-geometry-changed-p menu)
(let* ((menu-font (GCONTEXT-FONT (menu-gcontext menu)))
(title-width (TEXT-EXTENTS menu-font (menu-title menu)))
(item-height (+ (FONT-ASCENT menu-font) (FONT-DESCENT menu-font)))
(item-width 0)
(items (menu-item-alist menu))
menu-width)
;; Find max item string width
(dolist (next-item items)
(setf item-width (max item-width
(TEXT-EXTENTS menu-font (second next-item)))))
;; Compute final menu width, taking margins into account
(setf menu-width (max title-width
(+ item-width *menu-item-margin* *menu-item-margin*)))
(let ((window (menu-window menu))
(delta-y (+ item-height *menu-item-margin*)))
;; Update width and height of menu window
(WITH-STATE (window)
(setf (DRAWABLE-WIDTH window) menu-width
(DRAWABLE-HEIGHT window) (+ *menu-item-margin*
(* (1+ (length items))
delta-y))))
;; Update width, height, position of item windows
(let ((item-left (round (- menu-width item-width) 2))
(next-item-top delta-y))
(dolist (next-item items)
(let ((window (first next-item)))
(WITH-STATE (window)
(setf (DRAWABLE-HEIGHT window) item-height
(DRAWABLE-WIDTH window) item-width
(DRAWABLE-X window) item-left
(DRAWABLE-Y window) next-item-top)))
(incf next-item-top delta-y))))
;; Map all item windows
(MAP-SUBWINDOWS (menu-window menu))
;; Save item geometry
(setf (menu-item-width menu) item-width
(menu-item-height menu) item-height
(menu-width menu) menu-width
(menu-title-width menu) title-width
(menu-geometry-changed-p menu) nil))))
(defun menu-refresh (menu)
(let* ((gcontext (menu-gcontext menu))
(baseline-y (FONT-ASCENT (GCONTEXT-FONT gcontext))))
;; Show title centered in "reverse-video"
(let ((fg (GCONTEXT-BACKGROUND gcontext))
(bg (GCONTEXT-FOREGROUND gcontext)))
(WITH-GCONTEXT (gcontext :foreground fg :background bg)
(DRAW-IMAGE-GLYPHS
(menu-window menu)
gcontext
(round (- (menu-width menu)
(menu-title-width menu)) 2) ;start x
baseline-y ;start y
(menu-title menu))))
;; Show each menu item (position is relative to item window)
(dolist (item (menu-item-alist menu))
(DRAW-IMAGE-GLYPHS
(first item) gcontext
0 ;start x
baseline-y ;start y
(second item)))))
(defun menu-choose (menu x y)
;; Display the menu so that first item is at x,y.
(menu-present menu x y)
(let ((items (menu-item-alist menu))
(mw (menu-window menu))
selected-item)
;; Event processing loop
(do () (selected-item)
(EVENT-CASE ((DRAWABLE-DISPLAY mw) :force-output-p t)
(:exposure (count)
;; Discard all but final :exposure then display the menu
(when (zerop count) (menu-refresh menu))
t)
(:button-release (event-window)
;;Select an item
(setf selected-item (second (assoc event-window items)))
t)
(:enter-notify (window)
;;Highlight an item
(let ((position (position window items :key #'first)))
(when position
(menu-highlight-item menu position)))
t)
(:leave-notify (window kind)
(if (eql mw window)
;; Quit if pointer moved out of main menu window
(setf selected-item (when (eq kind :ancestor) :none))
;; Otherwise, unhighlight the item window left
(let ((position (position window items :key #'first)))
(when position
(menu-unhighlight-item menu position))))
t)
(otherwise ()
;;Ignore and discard any other event
t)))
;; Erase the menu
(UNMAP-WINDOW mw)
;; Return selected item string, if any
(unless (eq selected-item :none) selected-item)))
(defun menu-highlight-item (menu position)
(let* ((box-margin (round *menu-item-margin* 2))
(left (- (round (- (menu-width menu) (menu-item-width menu)) 2)
box-margin))
(top (- (* (+ *menu-item-margin* (menu-item-height menu))
(1+ position))
box-margin))
(width (+ (menu-item-width menu) box-margin box-margin))
(height (+ (menu-item-height menu) box-margin box-margin)))
;; Draw a box in menu window around the given item.
(DRAW-RECTANGLE (menu-window menu)
(menu-gcontext menu)
left top
width height)))
(defun menu-unhighlight-item (menu position)
;; Draw a box in the menu background color
(let ((gcontext (menu-gcontext menu)))
(WITH-GCONTEXT (gcontext :foreground (gcontext-background gcontext))
(menu-highlight-item menu position))))
(defun menu-present (menu x y)
;; Make sure menu geometry is up-to-date
(menu-recompute-geometry menu)
;; Try to center first item at the given location, but
;; make sure menu is completely visible in its parent
(let ((menu-window (menu-window menu)))
(multiple-value-bind (tree parent) (QUERY-TREE menu-window)
(declare (ignore tree))
(WITH-STATE (parent)
(let* ((parent-width (DRAWABLE-WIDTH parent))
(parent-height (DRAWABLE-HEIGHT parent))
(menu-height (+ *menu-item-margin*
(* (1+ (length (menu-item-alist menu)))
(+ (menu-item-height menu) *menu-item-margin*))))
(menu-x (max 0 (min (- parent-width (menu-width menu))
(- x (round (menu-width menu) 2)))))
(menu-y (max 0 (min (- parent-height menu-height)
(- y (round (menu-item-height menu) 2/3)
*menu-item-margin*)))))
(WITH-STATE (menu-window)
(setf (DRAWABLE-X menu-window) menu-x
(DRAWABLE-Y menu-window) menu-y)))))
;; Make menu visible
(MAP-WINDOW menu-window)))
(defun just-say-lisp (host &optional (font-name "fixed"))
(let* ((display (OPEN-DISPLAY host))
(screen (first (DISPLAY-ROOTS display)))
(fg-color (SCREEN-BLACK-PIXEL screen))
(bg-color (SCREEN-WHITE-PIXEL screen))
(nice-font (OPEN-FONT display font-name))
(a-menu (create-menu (screen-root screen) ;the menu's parent
fg-color bg-color nice-font)))
(setf (menu-title a-menu) "Please pick your favorite language:")
(menu-set-item-list a-menu "Fortran" "APL" "Forth" "Lisp")
;; Bedevil the user until he picks a nice programming language
(unwind-protect
(do (choice)
((and (setf choice (menu-choose a-menu 100 100))
(string-equal "Lisp" choice))))
(CLOSE-DISPLAY display))))
(defun pop-up (host strings &key (title "Pick one:") (font "fixed"))
(let* ((display (OPEN-DISPLAY host))
(screen (first (DISPLAY-ROOTS display)))
(fg-color (SCREEN-BLACK-PIXEL screen))
(bg-color (SCREEN-WHITE-PIXEL screen))
(font (OPEN-FONT display font))
(parent-width 400)
(parent-height 400)
(parent (CREATE-WINDOW :parent (SCREEN-ROOT screen)
:override-redirect :on
:x 100 :y 100
:width parent-width :height parent-height
:background bg-color
:event-mask (MAKE-EVENT-MASK :button-press
:exposure)))
(a-menu (create-menu parent fg-color bg-color font))
(prompt "Press a button...")
(prompt-gc (CREATE-GCONTEXT :drawable parent
:foreground fg-color
:background bg-color
:font font))
(prompt-y (FONT-ASCENT font))
(ack-y (- parent-height (FONT-DESCENT font))))
(setf (menu-title a-menu) title)
(apply #'menu-set-item-list a-menu strings)
;; Present main window
(MAP-WINDOW parent)
(flet ((display-centered-text
(window string gcontext height width)
(multiple-value-bind (w a d l r fa fd) (text-extents gcontext string)
(declare (ignore a d l r))
(let ((box-height (+ fa fd)))
;; Clear previous text
(CLEAR-AREA window
:x 0 :y (- height fa)
:width width :height box-height)
;; Draw new text
(DRAW-IMAGE-GLYPHS window gcontext (round (- width w) 2) height string)))))
(unwind-protect
(loop
(EVENT-CASE (display :force-output-p t)
(:exposure (count)
;; Display prompt
(when (zerop count)
(display-centered-text
parent
prompt
prompt-gc
prompt-y
parent-width))
t)
(:button-press (x y)
;; Pop up the menu
(let ((choice (menu-choose a-menu x y)))
(if choice
(display-centered-text
parent
(format nil "You have selected ~a." choice)
prompt-gc
ack-y
parent-width)
(display-centered-text
parent
"No selection...try again."
prompt-gc
ack-y
parent-width)))
t)
(otherwise ()
;;Ignore and discard any other event
t)))
(CLOSE-DISPLAY display)))))

97
src/eclx/demo/qix.lisp
View file

@ -1,97 +0,0 @@
;;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
;;;;
;;;; Title: The famous swirling vectors using CLX
;;;; Created: Wed Feb 14 15:51:39 1996
;;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
;;;; Copyright: None, since this code is not worth it.
;;;; -- TODO --
;;;;
;;;; o react on resize events
;;;; o possibly react on iconify events by stoping
;;;; o maybe pressing 'q' should terminate it
;;;; o window documentation line is needed
;;;; o maybe add a root window option
;;;; o or a spline option?!
;;;;
(in-package :xlib)
(defvar *offset* 3)
(defvar *delta* 6)
(defun check-bounds (val del max)
(cond ((< val 0) (+ (random *delta*) *offset*))
((> val max) (- (+ (random *delta*) *offset*)))
(t del)))
;; IHMO this is worth to be added to the standard.
(defun make-circular (x) (nconc x x))
(defstruct qix
lines dims deltas coords)
(defun gen-qix (nlines width height)
(make-qix :lines (make-circular (make-list nlines))
:dims (list width height width height)
:deltas (list #3=(+ *offset* (random *delta*)) #3# #3# #3#)
:coords (list #1=(random width) #2=(random height) #1# #2#) ))
(defun step-qix (qix win gc white-pixel black-pixel)
(when (car (qix-lines qix))
(setf (xlib:gcontext-foreground gc) white-pixel)
(apply #'xlib:draw-line win gc (car (qix-lines qix)))
(setf (xlib:gcontext-foreground gc) black-pixel))
(map-into (qix-coords qix) #'+ (qix-coords qix) (qix-deltas qix))
(map-into (qix-deltas qix) #'check-bounds
(qix-coords qix) (qix-deltas qix) (qix-dims qix))
(apply #'xlib:draw-line win gc (qix-coords qix))
;; push 'em into
(unless (car (qix-lines qix)) (setf (car (qix-lines qix)) (make-list 4)))
(map-into (car (qix-lines qix)) #'identity (qix-coords qix))
(setf (qix-lines qix) (cdr (qix-lines qix))) )
(defun draw-qix (dpy win gc width height white-pixel black-pixel
delay nqixs nlines)
(let ((qixs nil) (n nlines))
(dotimes (k nqixs) (push (gen-qix nlines width height) qixs))
(loop
(dolist (k qixs)
(step-qix k win gc white-pixel black-pixel))
(xlib:display-force-output dpy)
(sleep delay)
(setq n (- n 1))
(if (<= n 0) (return)))))
(defun qix (&key host display dpy
(width 400) (height 400) (delay 0.05) (nqixs 3) (nlines 80))
#+ignore (setf (values host display) (x-host-display))
(let* ((dp1 (or dpy (xlib:open-display host))) ;:display display)))
(scr (first (xlib:display-roots dp1)))
(root-win (xlib:screen-root scr))
(white-pixel (xlib:screen-white-pixel scr))
(black-pixel (xlib:screen-black-pixel scr))
(win (xlib:create-window :parent root-win :x 10 :y 10
:width width :height height
:background white-pixel))
(gcon (xlib:create-gcontext :drawable win
:foreground black-pixel
:background white-pixel)))
(xlib:map-window win)
(xlib:display-finish-output dp1)
(format t "~&Qix uses the following parameters:~% :dpy: ~s
:host ~s :display ~s
:width ~d :height ~d :delay ~f :nqixs ~d :nlines ~d~%"
dp1 host display width height delay nqixs nlines)
(draw-qix dp1 win gcon width height white-pixel black-pixel
delay nqixs nlines)
(xlib:unmap-window win)
(xlib:destroy-window win)
;;clean-up
(unless dpy (xlib:close-display dp1))))
;; since we have no herald, simply dump it:
#+nil
(format t "~& The famous swirling vectors.~%
(xlib::qix :host :display :dpy :width :height :delay :nqixs :nlines)
~% Call (xlib::qix :host \"\") or (xlib::qix :host \"\" :delay 0).~%")

26
src/eclx/demo/shape-test.lisp
View file

@ -1,26 +0,0 @@
;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*-
;;; Copyright BRIAN SPILSBURY <zhivago@iglou.com>
;;; Placed in the public domain, no warranty
(in-package :xlib)
(defun shape-test (&optional (host ""))
(let* ((d (xlib:open-display host))
(s (first (xlib:display-roots d)))
(r (xlib:screen-root s))
(w (xlib:create-window :x 0 :y 0 :parent r :width 100 :height 100))
(p (xlib:create-pixmap :width 100 :height 100 :depth 1 :drawable w))
(g (xlib:create-gcontext :drawable p :foreground 0)))
(multiple-value-bind (b? bx by bw bh c? cx cy cw ch) (xlib:shape-query-extents w)
(print (list b? bx by bw bh c? cx cy cw ch)))
(setf (xlib:window-background w) 0)
(xlib:draw-rectangle p g 0 0 100 100 t)
(setf (xlib:gcontext-foreground g) 1)
(xlib:draw-arc p g 0 0 100 100 0.0 (* 2 pi) t)
(xlib:shape-combine-mask w xlib:shape-bounding 0 0 p xlib::shape-set)
(xlib:map-window w)
(xlib:display-finish-output d)
(multiple-value-bind (b? bx by bw bh c? cx cy cw ch) (xlib:shape-query-extents w)
(print (list b? bx by bw bh c? cx cy cw ch)))))

58
src/eclx/demo/zoid.lisp
View file

@ -1,58 +0,0 @@
;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
;;; CLX interface for Trapezoid Extension.
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
(in-package :xlib)
(export '(draw-filled-trapezoids
gcontext-trapezoid-alignment ;; Setf'able
))
(define-extension "ZoidExtension")
(defun draw-filled-trapezoids (drawable gcontext points)
;; Draw trapezoids on drawable using gcontext.
;; Points are a list of either (y1 y2 y3 y4 x1 x2) ;; x-aligned
;; or (x1 x2 x3 x4 y1 y2) ;; y-aligned
;; Alignment is determined by the GCONTEXT [see gcontext-trapezoid-alignment]
;; Alignment is set with the ALIGNMENT keyword argument, which may be
;; :X, :Y, or NIL (use previous alignment)
(declare (type drawable drawable)
(type gcontext gcontext)
(type sequence points))
(let* ((display (drawable-display drawable))
(opcode (extension-opcode display "ZoidExtension")))
(with-buffer-request (display opcode :gc-force gcontext)
((data card8) 1) ;; X_PolyFillZoid
(drawable drawable)
(gcontext gcontext)
((sequence :format int16) points))))
(define-gcontext-accessor trapezoid-alignment :default :x
:set-function set-trapezoid-alignment)
(defun set-trapezoid-alignment (gcontext alignment)
(declare (type (member :x :y) alignment))
(let* ((display (gcontext-display gcontext))
(opcode (extension-opcode display "ZoidExtension")))
(with-buffer-request (display opcode)
((data card8) 2) ;; X_SetZoidAlignment
(gcontext gcontext)
((member8 %error :x :y) alignment))))

394
src/eclx/depdefs.lisp
View file

@ -1,394 +0,0 @@
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
;; This file contains some of the system dependent code for CLX
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
#+cmu
(ext:file-comment
"$Header$")
(in-package :xlib)
;;;-------------------------------------------------------------------------
;;; Declarations
;;;-------------------------------------------------------------------------
;;; CLX-VALUES value1 value2 ... -- Documents the values returned by the function.
(declaim (declaration clx-values))
;;; ARGLIST arg1 arg2 ... -- Documents the arglist of the function. Overrides
;;; the documentation that might get generated by the real arglist of the
;;; function.
(declaim (declaration arglist))
;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to
;;; indent calls to the function or macro containing the declaration.
(declaim (declaration indentation))
;;;-------------------------------------------------------------------------
;;; Declaration macros
;;;-------------------------------------------------------------------------
;;; WITH-VECTOR (variable type) &body body --- ensures the variable is a local
;;; and then does a type declaration and array register declaration
(defmacro with-vector ((var type) &body body)
`(let ((,var ,var))
(declare (type ,type ,var))
,@body))
;;; WITHIN-DEFINITION (name type) &body body --- Includes definitions for
;;; Meta-.
(defmacro within-definition ((name type) &body body)
(declare (ignore name type))
`(progn ,@body))
;;;-------------------------------------------------------------------------
;;; CLX can maintain a mapping from X server ID's to local data types. If
;;; one takes the view that CLX objects will be instance variables of
;;; objects at the next higher level, then PROCESS-EVENT will typically map
;;; from resource-id to higher-level object. In that case, the lower-level
;;; CLX mapping will almost never be used (except in rare cases like
;;; query-tree), and only serve to consume space (which is difficult to
;;; GC), in which case always-consing versions of the make-<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).
;;;--------------------------------------------------------------------------
(defparameter *clx-cached-types*
'( drawable
window
pixmap
; gcontext
cursor
colormap
font))
(defmacro resource-id-map-test ()
'#'eql)
; (eq fixnum fixnum) is not guaranteed.
(defmacro atom-cache-map-test ()
'#'eq)
(defmacro keysym->character-map-test ()
'#'eql)
;;; You must define this to match the real byte order. It is used by
;;; overlapping array and image code.
#+cmu
(eval-when (:compile-toplevel :execute :load-toplevel)
(ecase #.(c:backend-byte-order c:*backend*)
(:big-endian)
(:little-endian (pushnew :clx-little-endian *features*))))
(deftype buffer-bytes () `(simple-array (unsigned-byte 8) (*)))
;;; This defines a type which is a subtype of the integers.
;;; This type is used to describe all variables that can be array indices.
;;; It is here because it is used below.
;;; This is inclusive because start/end can be 1 past the end.
(deftype array-index () `(integer 0 ,array-dimension-limit))
;; this is the best place to define these?
(progn
(defun make-index-typed (form)
(if (constantp form) form `(the array-index ,form)))
(defun make-index-op (operator args)
`(the array-index
(values
,(case (length args)
(0 `(,operator))
(1 `(,operator
,(make-index-typed (first args))))
(2 `(,operator
,(make-index-typed (first args))
,(make-index-typed (second args))))
(otherwise
`(,operator
,(make-index-op operator (subseq args 0 (1- (length args))))
,(make-index-typed (first (last args)))))))))
(defmacro index+ (&rest numbers) (make-index-op '+ numbers))
(defmacro index-logand (&rest numbers) (make-index-op 'logand numbers))
(defmacro index-logior (&rest numbers) (make-index-op 'logior numbers))
(defmacro index- (&rest numbers) (make-index-op '- numbers))
(defmacro index* (&rest numbers) (make-index-op '* numbers))
(defmacro index1+ (number) (make-index-op '1+ (list number)))
(defmacro index1- (number) (make-index-op '1- (list number)))
(defmacro index-incf (place &optional (delta 1))
(make-index-op 'incf (list place delta)))
(defmacro index-decf (place &optional (delta 1))
(make-index-op 'decf (list place delta)))
(defmacro index-min (&rest numbers) (make-index-op 'min numbers))
(defmacro index-max (&rest numbers) (make-index-op 'max numbers))
(defmacro index-floor (number divisor)
(make-index-op 'floor (list number divisor)))
(defmacro index-ceiling (number divisor)
(make-index-op 'ceiling (list number divisor)))
(defmacro index-truncate (number divisor)
(make-index-op 'truncate (list number divisor)))
(defmacro index-mod (number divisor)
(make-index-op 'mod (list number divisor)))
(defmacro index-ash (number count)
(make-index-op 'ash (list number count)))
(defmacro index-plusp (number) `(plusp (the array-index ,number)))
(defmacro index-zerop (number) `(zerop (the array-index ,number)))
(defmacro index-evenp (number) `(evenp (the array-index ,number)))
(defmacro index-oddp (number) `(oddp (the array-index ,number)))
(defmacro index> (&rest numbers)
`(> ,@(mapcar #'make-index-typed numbers)))
(defmacro index= (&rest numbers)
`(= ,@(mapcar #'make-index-typed numbers)))
(defmacro index< (&rest numbers)
`(< ,@(mapcar #'make-index-typed numbers)))
(defmacro index>= (&rest numbers)
`(>= ,@(mapcar #'make-index-typed numbers)))
(defmacro index<= (&rest numbers)
`(<= ,@(mapcar #'make-index-typed numbers)))
)
;;;; Stuff for BUFFER definition
(defconstant +replysize+ 32.)
;; used in defstruct initializations to avoid compiler warnings
(defvar *empty-bytes* (make-sequence 'buffer-bytes 0))
(declaim (type buffer-bytes *empty-bytes*))
(defstruct (reply-buffer (:conc-name reply-) (:constructor make-reply-buffer-internal)
(:copier nil) (:predicate nil))
(size 0 :type array-index) ;Buffer size
;; Byte (8 bit) input buffer
(ibuf8 *empty-bytes* :type buffer-bytes)
;; Word (16bit) input buffer
(next nil :type (or null reply-buffer))
(data-size 0 :type array-index)
)
(defconstant +buffer-text16-size+ 256)
(deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,+buffer-text16-size+)))
;; These are here because.
(defparameter *xlib-package* (find-package :xlib))
(defun xintern (&rest parts)
(intern (apply #'concatenate 'string (mapcar #'string parts)) *xlib-package*))
(defparameter *keyword-package* (find-package :keyword))
(defun kintern (name)
(intern (string name) *keyword-package*))
;;; Pseudo-class mechanism.
(eval-when (:execute :compile-toplevel :load-toplevel)
(defvar *def-clx-class-use-defclass*
#+(and cmu pcl) '(XLIB:DRAWABLE XLIB:WINDOW XLIB:PIXMAP)
#+(and cmu (not pcl)) nil
#-(or cmu) nil
"Controls whether DEF-CLX-CLASS uses DEFCLASS.
If it is a list, it is interpreted by DEF-CLX-CLASS to be a list of type names
for which DEFCLASS should be used.
If it is not a list, then DEFCLASS is always used.
If it is NIL, then DEFCLASS is never used, since NIL is the empty list.")
)
(defmacro def-clx-class ((name &rest options) &body slots)
(if (or (not (listp *def-clx-class-use-defclass*))
(member name *def-clx-class-use-defclass*))
(let ((clos-package (find-package :common-lisp))
(constructor t)
(constructor-args t)
(include nil)
(print-function nil)
(copier t)
(predicate t))
(dolist (option options)
(ecase (pop option)
(:constructor
(setf constructor (pop option))
(setf constructor-args (if (null option) t (pop option))))
(:include
(setf include (pop option)))
(:print-function
(setf print-function (pop option)))
(:copier
(setf copier (pop option)))
(:predicate
(setf predicate (pop option)))))
(flet ((cintern (&rest symbols)
(intern (apply #'concatenate 'simple-string
(mapcar #'symbol-name symbols))
*package*))
(kintern (symbol)
(intern (symbol-name symbol) (find-package :keyword)))
(closintern (symbol)
(intern (symbol-name symbol) clos-package)))
(when (eq constructor t)
(setf constructor (cintern 'make- name)))
(when (eq copier t)
(setf copier (cintern 'copy- name)))
(when (eq predicate t)
(setf predicate (cintern name '-p)))
(when include
(setf slots (append (get include 'def-clx-class) slots)))
(let* ((n-slots (length slots))
(slot-names (make-list n-slots))
(slot-initforms (make-list n-slots))
(slot-types (make-list n-slots)))
(dotimes (i n-slots)
(let ((slot (elt slots i)))
(setf (elt slot-names i) (pop slot))
(setf (elt slot-initforms i) (pop slot))
(setf (elt slot-types i) (getf slot :type t))))
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (get ',name 'def-clx-class) ',slots))
;; From here down are the system-specific expansions:
(within-definition (,name def-clx-class)
(,(closintern 'defclass)
,name ,(and include `(,include))
(,@(map 'list
#'(lambda (slot-name slot-initform slot-type)
`(,slot-name
:initform ,slot-initform :type ,slot-type
:accessor ,(cintern name '- slot-name)
,@(when (and constructor
(or (eq constructor-args t)
(member slot-name
constructor-args)))
`(:initarg ,(kintern slot-name)))
))
slot-names slot-initforms slot-types)))
,(when constructor
(if (eq constructor-args t)
`(defun ,constructor (&rest args)
(apply #',(closintern 'make-instance)
',name args))
`(defun ,constructor ,constructor-args
(,(closintern 'make-instance) ',name
,@(mapcan #'(lambda (slot-name)
(and (member slot-name slot-names)
`(,(kintern slot-name) ,slot-name)))
constructor-args)))))
,(when predicate
`(defun ,predicate (object)
(typep object ',name)))
,(when copier
`(,(closintern 'defmethod) ,copier ((.object. ,name))
(,(closintern 'with-slots) ,slot-names .object.
(,(closintern 'make-instance) ',name
,@(mapcan #'(lambda (slot-name)
`(,(kintern slot-name) ,slot-name))
slot-names)))))
,(when print-function
`(,(closintern 'defmethod)
,(closintern 'print-object)
((object ,name) stream)
(,print-function object stream 0))))))))
`(within-definition (,name def-clx-class)
(defstruct (,name ,@options)
,@slots))))
;; We need this here so we can define DISPLAY for CLX.
;;
;; This structure is :INCLUDEd in the DISPLAY structure.
;; Overlapping (displaced) arrays are provided for byte
;; half-word and word access on both input and output.
;;
(def-clx-class (buffer (:constructor nil) (:copier nil) (:predicate nil))
;; Lock for multi-processing systems
(lock (make-process-lock "CLX Buffer Lock"))
(output-stream nil :type (or null stream))
;; Buffer size
(size 0 :type array-index)
(request-number 0 :type (unsigned-byte 16))
;; Byte position of start of last request
;; used for appending requests and error recovery
(last-request nil :type (or null array-index))
;; Byte position of start of last flushed request
(last-flushed-request nil :type (or null array-index))
;; Current byte offset
(boffset 0 :type array-index)
;; Byte (8 bit) output buffer
(obuf8 *empty-bytes* :type buffer-bytes)
;; Holding buffer for 16-bit text
(tbuf16 (make-sequence 'buffer-text16 +buffer-text16-size+ :initial-element 0))
;; Probably EQ to Output-Stream
(input-stream nil :type (or null stream))
;; T when the host connection has gotten errors
(dead nil :type (or null (not null)))
;; T makes buffer-flush a noop. Manipulated with with-buffer-flush-inhibited.
(flush-inhibit nil :type (or null (not null)))
;; Change these functions when using shared memory buffers to the server
;; Function to call when writing the buffer
(write-function 'buffer-write-default)
;; Function to call when flushing the buffer
(force-output-function 'buffer-force-output-default)
;; Function to call when closing a connection
(close-function 'buffer-close-default)
;; Function to call when reading the buffer
(input-function 'buffer-read-default)
;; Function to call to wait for data to be input
(input-wait-function 'buffer-input-wait-default)
;; Function to call to listen for input data
(listen-function 'buffer-listen-default)
)
;;-----------------------------------------------------------------------------
;; Image stuff
;;-----------------------------------------------------------------------------
(defconstant +image-bit-lsb-first-p+
#+clx-little-endian t
#-clx-little-endian nil)
(defconstant +image-byte-lsb-first-p+
#+clx-little-endian t
#-clx-little-endian nil)
(defconstant +image-unit+ 32)
(defconstant +image-pad+ 32)

1460
src/eclx/dependent.lisp
View file

File diff suppressed because it is too large Load diff

642
src/eclx/display.lisp
View file

@ -1,642 +0,0 @@
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
#+cmu
(ext:file-comment
"$Header$")
(in-package :xlib)
;;; Authorizaton
;;; shamelessly stolen from the cmucl sources:
;;; integrated patches by Hannu Rummukainen and Scott Fahlman
;;; X11 Authorization: to prevent malicious users from snooping on an
;;; display, X servers may require connection requests to be
;;; authorized. The X server (or display manager) will create a random
;;; key on startup, and store it as an entry in a file generally named
;;; $HOME/.Xauthority (see the function AUTHORITY-PATHNAME). Clients
;;; must extract from this file the "magic cookie" that corresponds to
;;; the server they wish to connect to, and send it as authorization
;;; data when opening the display.
;;;
;;; Users can manipulate the contents of their .Xauthority file using
;;; the xauth command.
;;;
;;; The function GET-BEST-AUTHORIZATION is responsible for parsing the
;;; .Xauthority file and extracting the cookie for DISPLAY on HOST.
;;; The HOST argument is the hostname of the target display as a
;;; string, and DISPLAY is a number. The PROTOCOL argument determines
;;; whether the server connection is using an Internet protocol
;;; (values of :tcp or :internet) or a non-network protocol such as
;;; Unix domain sockets (value of :local). GET-BEST-AUTHORITY returns
;;; two strings: an authorization name (very likely the string
;;; "MIT-MAGIC-COOKIE-1") and an authorization key, represented as
;;; fixnums in a vector. If the function fails to find an appropriate
;;; cookie, it returns two empty strings.
;;;
;;; The format of the .Xauthority file is documented in the XFree
;;; sources, in the file xc/lib/Xau/README.
(defparameter *known-authorizations* '("MIT-MAGIC-COOKIE-1"))
(defun read-xauth-entry (stream)
(labels ((read-short (stream &optional (eof-errorp t))
(let ((high-byte (read-byte stream eof-errorp)))
(and high-byte
(dpb high-byte (byte 8 8) (read-byte stream)))))
(read-short-length-string (stream)
(let ((length (read-short stream)))
(let ((string (make-string length)))
(dotimes (k length)
(setf (schar string k) (card8->char (read-byte stream))))
string)))
(read-short-length-vector (stream)
(let ((length (read-short stream)))
(let ((vector (make-array length :element-type '(unsigned-byte 8))))
(dotimes (k length)
(setf (aref vector k) (read-byte stream)))
vector))))
(let ((family (read-short stream nil)))
(if (null family)
(list nil nil nil nil nil)
(let* ((address (read-short-length-vector stream))
(number (parse-integer (read-short-length-string stream)))
(name (read-short-length-string stream))
(data (read-short-length-vector stream))
(family (or (car (rassoc family *protocol-families*)) family)))
(list
family
(ecase family
(:local (map 'string #'code-char address))
(:internet (coerce address 'list)))
number name data))))))
(defun get-best-authorization (host display protocol)
;; parse .Xauthority, extract the cookie for DISPLAY on HOST.
;; PROTOCOL determines whether the server connection is using an
;; Internet protocol (value of :internet) or a non-network
;; protocol such as Unix domain sockets (value of :local). Returns
;; two strings: an authorization name (very likely the string
;; "MIT-MAGIC-COOKIE-1") and an authorization key, represented as
;; fixnums in a vector. If we fail to find an appropriate cookie,
;; return two empty strings.
(let ((pathname (authority-pathname)))
(when pathname
(with-open-file (stream pathname :element-type '(unsigned-byte 8)
:if-does-not-exist nil)
(when stream
(let* ((host-address (and (eql protocol :internet)
(rest (host-address host protocol))))
(best-name nil)
(best-pos nil)
(best-data nil))
;; Check for the localhost address, in which case we're
;; really FamilyLocal.
(when (or (eql protocol :local)
(and (eql protocol :internet)
(equal host-address '(127 0 0 1))))
(setq host-address (get-host-name))
(setq protocol :local))
(loop
(destructuring-bind (family address number name data)
(read-xauth-entry stream)
(unless family (return))
(when (and (eql family protocol)
(equal host-address address)
(= number display)
(let ((pos1 (position name *known-authorizations*
:test #'string=)))
(and pos1
(or (null best-pos)
(< pos1 best-pos)))))
(setf best-name name
best-pos (position name *known-authorizations*
:test #'string=)
best-data data))))
(when best-name
(return-from get-best-authorization
(values best-name best-data)))))))
(values "" "")))
;;
;; Resource id management
;;
(defun initialize-resource-allocator (display)
;; Find the resource-id-byte (appropriate for LDB & DPB) from the resource-id-mask
(let ((id-mask (display-resource-id-mask display)))
(unless (zerop id-mask) ;; zero mask is an error
(do ((first 0 (index1+ first))
(mask id-mask (the mask32 (ash mask -1))))
((oddp mask)
(setf (display-resource-id-byte display)
(byte (integer-length mask) first)))
(declare (type array-index first)
(type mask32 mask))))))
(defun resourcealloc (display)
;; Allocate a resource-id for in DISPLAY
(declare (type display display))
(declare (clx-values resource-id))
(dpb (incf (display-resource-id-count display))
(display-resource-id-byte display)
(display-resource-id-base display)))
(defmacro allocate-resource-id (display object type)
;; Allocate a resource-id for OBJECT in DISPLAY
(if (member (eval type) *clx-cached-types*)
`(let ((id (funcall (display-xid ,display) ,display)))
(save-id ,display id ,object)
id)
`(funcall (display-xid ,display) ,display)))
(defmacro deallocate-resource-id (display id type)
;; Deallocate a resource-id for OBJECT in DISPLAY
(when (member (eval type) *clx-cached-types*)
`(deallocate-resource-id-internal ,display ,id)))
(defun deallocate-resource-id-internal (display id)
(remhash id (display-resource-id-map display)))
(defun lookup-resource-id (display id)
;; Find the object associated with resource ID
(gethash id (display-resource-id-map display)))
(defun save-id (display id object)
;; Register a resource-id from another display.
(declare (type display display)
(type integer id)
(type t object))
(declare (clx-values object))
(setf (gethash id (display-resource-id-map display)) object))
;; Define functions to find the CLX data types given a display and resource-id
;; If the data type is being cached, look there first.
(macrolet ((generate-lookup-functions (useless-name &body types)
`(within-definition (,useless-name generate-lookup-functions)
,@(mapcar
#'(lambda (type)
`(defun ,(xintern 'lookup- type)
(display id)
(declare (type display display)
(type resource-id id))
(declare (clx-values ,type))
,(if (member type *clx-cached-types*)
`(let ((,type (lookup-resource-id display id)))
(cond ((null ,type) ;; Not found, create and save it.
(setq ,type (,(xintern 'make- type)
:display display :id id))
(save-id display id ,type))
;; Found. Check the type
,(cond ((null +type-check?+)
`(t ,type))
((member type '(window pixmap))
`((type? ,type 'drawable) ,type))
(t `((type? ,type ',type) ,type)))
,@(when +type-check?+
`((t (x-error 'lookup-error
:id id
:display display
:type ',type
:object ,type))))))
;; Not being cached. Create a new one each time.
`(,(xintern 'make- type)
:display display :id id))))
types))))
(generate-lookup-functions ignore
drawable
window
pixmap
gcontext
cursor
colormap
font))
(defun id-atom (id display)
;; Return the cached atom for an atom ID
(declare (type resource-id id)
(type display display))
(declare (clx-values (or null keyword)))
(gethash id (display-atom-id-map display)))
(defun atom-id (atom display)
;; Return the ID for an atom in DISPLAY
(declare (type xatom atom)
(type display display))
(declare (clx-values (or null resource-id)))
(gethash (if (or (null atom) (keywordp atom)) atom (kintern atom))
(display-atom-cache display)))
(defun set-atom-id (atom display id)
;; Set the ID for an atom in DISPLAY
(declare (type xatom atom)
(type display display)
(type resource-id id))
(declare (clx-values resource-id))
(let ((atom (if (or (null atom) (keywordp atom)) atom (kintern atom))))
(setf (gethash id (display-atom-id-map display)) atom)
(setf (gethash atom (display-atom-cache display)) id)
id))
(defsetf atom-id set-atom-id)
(defun initialize-predefined-atoms (display)
(dotimes (i (length *predefined-atoms*))
(declare (type resource-id i))
(setf (atom-id (svref *predefined-atoms* i) display) i)))
(defun visual-info (display visual-id)
(declare (type display display)
(type resource-id visual-id)
(clx-values visual-info))
(when (zerop visual-id)
(return-from visual-info nil))
(dolist (screen (display-roots display))
(declare (type screen screen))
(dolist (depth (screen-depths screen))
(declare (type cons depth))
(dolist (visual-info (rest depth))
(declare (type visual-info visual-info))
(when (funcall (resource-id-map-test) visual-id (visual-info-id visual-info))
(return-from visual-info visual-info)))))
(error "Visual info not found for id #x~x in display ~s." visual-id display))
;;
;; Display functions
;;
(defmacro with-display ((display &key timeout inline)
&body body)
;; This macro is for use in a multi-process environment. It provides exclusive
;; access to the local display object for multiple request generation. It need not
;; provide immediate exclusive access for replies; that is, if another process is
;; waiting for a reply (while not in a with-display), then synchronization need not
;; (but can) occur immediately. Except where noted, all routines effectively
;; contain an implicit with-display where needed, so that correct synchronization
;; is always provided at the interface level on a per-call basis. Nested uses of
;; this macro will work correctly. This macro does not prevent concurrent event
;; processing; see with-event-queue.
`(with-buffer (,display
,@(and timeout `(:timeout ,timeout))
,@(and inline `(:inline ,inline)))
,@body))
(defmacro with-event-queue ((display &key timeout inline)
&body body &environment env)
;; exclusive access to event queue
`(macrolet ((with-event-queue ((display &key timeout) &body body)
;; Speedup hack for lexically nested with-event-queues
`(progn
(progn ,display ,@(and timeout `(,timeout)) nil)
,@body)))
,(if (and (null inline) (macroexpand '(use-closures) env))
`(flet ((.with-event-queue-body. () ,@body))
(declare (dynamic-extent #'.with-event-queue-body.))
(with-event-queue-function
,display ,timeout #'.with-event-queue-body.))
(let ((disp (if (or (symbolp display) (constantp display))
display
'.display.)))
`(let (,@(unless (eq disp display) `((,disp ,display))))
(holding-lock ((display-event-lock ,disp) ,disp "CLX Event Lock"
,@(and timeout `(:timeout ,timeout)))
,@body))))))
(defun with-event-queue-function (display timeout function)
(declare (type display display)
(type (or null number) timeout)
(type function function)
(dynamic-extent function))
(with-event-queue (display :timeout timeout :inline t)
(funcall function)))
(defmacro with-event-queue-internal ((display &key timeout) &body body)
;; exclusive access to the internal event queues
(let ((disp (if (or (symbolp display) (constantp display)) display '.display.)))
`(let (,@(unless (eq disp display) `((,disp ,display))))
(holding-lock ((display-event-queue-lock ,disp) ,disp "CLX Event Queue Lock"
,@(and timeout `(:timeout ,timeout)))
,@body))))
(defun open-default-display ()
"Opens the default display"
(destructuring-bind (host display screen protocol)
(get-default-display)
(declare (ignore screen))
(open-display host :display display :protocol protocol)))
(defun open-display (host &key (display 0) protocol authorization-name authorization-data)
;; Implementation specific routine to setup the buffer for a specific host and display.
;; This must interface with the local network facilities, and will probably do special
;; things to circumvent the network when displaying on the local host.
;;
;; A string must be acceptable as a host, but otherwise the possible types
;; for host and protocol are not constrained, and will likely be very
;; system dependent. The default protocol is system specific. Authorization,
;; if any, is assumed to come from the environment somehow.
(declare (type integer display))
(declare (clx-values display))
;; Get the authorization mechanism from the environment. Handle the
;; special case of a host name of "" and "unix" which means the
;; protocol is :local
(when (member host '("" "unix") :test #'equal)
(setf protocol :local))
(when (null authorization-name)
(multiple-value-setq (authorization-name authorization-data)
(get-best-authorization host
display
protocol)))
;; PROTOCOL is the network protocol now _alwas_ :TCP
(let* ((stream (open-x-stream host display protocol))
(disp (make-buffer *output-buffer-size* #'make-display-internal
:host host :display display
:output-stream stream :input-stream stream))
(ok-p nil))
(unwind-protect
(progn
(display-connect disp
:authorization-name authorization-name
:authorization-data authorization-data)
(setf (display-authorization-name disp) authorization-name)
(setf (display-authorization-data disp) authorization-data)
(initialize-resource-allocator disp)
(initialize-predefined-atoms disp)
(initialize-extensions disp)
(setq ok-p t))
(unless ok-p (close-display disp :abort t)))
disp))
(defun display-force-output (display)
; Output is normally buffered, this forces any buffered output to the server.
(declare (type display display))
(with-display (display)
(buffer-force-output display)))
(defun close-display (display &key abort)
;; Close the host connection in DISPLAY
(declare (type display display))
(close-buffer display :abort abort))
(defun display-connect (display &key authorization-name authorization-data)
(with-buffer-output (display :sizes (8 16))
(card8-put
0
(ecase (display-byte-order display)
(:lsbfirst #x6c) ;; Ascii lowercase l - Least Significant Byte First
(:msbfirst #x42))) ;; Ascii uppercase B - Most Significant Byte First
(card16-put 2 *protocol-major-version*)
(card16-put 4 *protocol-minor-version*)
(card16-put 6 (length authorization-name))
(card16-put 8 (length authorization-data))
(write-sequence-char display 12 authorization-name)
(if (stringp authorization-data)
(write-sequence-char display (lround (+ 12 (length authorization-name)))
authorization-data)
(write-sequence-card8 display (lround (+ 12 (length authorization-name)))
authorization-data)))
(buffer-force-output display)
(let ((reply-buffer nil))
(declare (type (or null reply-buffer) reply-buffer))
(unwind-protect
(progn
(setq reply-buffer (allocate-reply-buffer #x1000))
(with-buffer-input (reply-buffer :sizes (8 16 32))
(buffer-input display buffer-bbuf 0 8)
(let ((success (boolean-get 0))
(reason-length (card8-get 1))
(major-version (card16-get 2))
(minor-version (card16-get 4))
(total-length (card16-get 6))
vendor-length
num-roots
num-formats)
(declare (ignore total-length))
(unless success
(x-error 'connection-failure
:major-version major-version
:minor-version minor-version
:host (display-host display)
:display (display-display display)
:reason
(progn (buffer-input display buffer-bbuf 0 reason-length)
(string-get reason-length 0 :reply-buffer reply-buffer))))
(buffer-input display buffer-bbuf 0 32)
(setf (display-protocol-major-version display) major-version)
(setf (display-protocol-minor-version display) minor-version)
(setf (display-release-number display) (card32-get 0))
(setf (display-resource-id-base display) (card32-get 4))
(setf (display-resource-id-mask display) (card32-get 8))
(setf (display-motion-buffer-size display) (card32-get 12))
(setq vendor-length (card16-get 16))
(setf (display-max-request-length display) (card16-get 18))
(setq num-roots (card8-get 20))
(setq num-formats (card8-get 21))
;; Get the image-info
(setf (display-image-lsb-first-p display) (zerop (card8-get 22)))
(let ((format (display-bitmap-format display)))
(declare (type bitmap-format format))
(setf (bitmap-format-lsb-first-p format) (zerop (card8-get 23)))
(setf (bitmap-format-unit format) (card8-get 24))
(setf (bitmap-format-pad format) (card8-get 25)))
(setf (display-min-keycode display) (card8-get 26))
(setf (display-max-keycode display) (card8-get 27))
;; 4 bytes unused
;; Get the vendor string
(buffer-input display buffer-bbuf 0 (lround vendor-length))
(setf (display-vendor-name display)
(string-get vendor-length 0 :reply-buffer reply-buffer))
;; Initialize the pixmap formats
(dotimes (i num-formats) ;; loop gathering pixmap formats
(declare (ignorable i))
(buffer-input display buffer-bbuf 0 8)
(push (make-pixmap-format :depth (card8-get 0)
:bits-per-pixel (card8-get 1)
:scanline-pad (card8-get 2))
; 5 unused bytes
(display-pixmap-formats display)))
(setf (display-pixmap-formats display)
(nreverse (display-pixmap-formats display)))
;; Initialize the screens
(dotimes (i num-roots)
(declare (ignorable i))
(buffer-input display buffer-bbuf 0 40)
(let* ((root-id (card32-get 0))
(root (make-window :id root-id :display display))
(root-visual (card32-get 32))
(default-colormap-id (card32-get 4))
(default-colormap
(make-colormap :id default-colormap-id :display display))
(screen
(make-screen
:root root
:default-colormap default-colormap
:white-pixel (card32-get 8)
:black-pixel (card32-get 12)
:event-mask-at-open (card32-get 16)
:width (card16-get 20)
:height (card16-get 22)
:width-in-millimeters (card16-get 24)
:height-in-millimeters (card16-get 26)
:min-installed-maps (card16-get 28)
:max-installed-maps (card16-get 30)
:backing-stores (member8-get 36 :never :when-mapped :always)
:save-unders-p (boolean-get 37)
:root-depth (card8-get 38)))
(num-depths (card8-get 39))
(depths nil))
;; Save root window for event reporting
(save-id display root-id root)
(save-id display default-colormap-id default-colormap)
;; Create the depth AList for a screen, (depth . visual-infos)
(dotimes (j num-depths)
(declare (ignorable j))
(buffer-input display buffer-bbuf 0 8)
(let ((depth (card8-get 0))
(num-visuals (card16-get 2))
(visuals nil)) ;; 4 bytes unused
(dotimes (k num-visuals)
(declare (ignorable k))
(buffer-input display buffer-bbuf 0 24)
(let* ((visual (card32-get 0))
(visual-info (make-visual-info
:id visual
:display display
:class (member8-get 4 :static-gray :gray-scale
:static-color :pseudo-color
:true-color :direct-color)
:bits-per-rgb (card8-get 5)
:colormap-entries (card16-get 6)
:red-mask (card32-get 8)
:green-mask (card32-get 12)
:blue-mask (card32-get 16)
;; 4 bytes unused
)))
(push visual-info visuals)
(when (funcall (resource-id-map-test) root-visual visual)
(setf (screen-root-visual-info screen)
(setf (colormap-visual-info default-colormap)
visual-info)))))
(push (cons depth (nreverse visuals)) depths)))
(setf (screen-depths screen) (nreverse depths))
(push screen (display-roots display))))
(setf (display-roots display) (nreverse (display-roots display)))
(setf (display-default-screen display) (first (display-roots display))))))
(when reply-buffer
(deallocate-reply-buffer reply-buffer))))
display)
(defun display-protocol-version (display)
(declare (type display display))
(declare (clx-values major minor))
(values (display-protocol-major-version display)
(display-protocol-minor-version display)))
(defun display-vendor (display)
(declare (type display display))
(declare (clx-values name release))
(values (display-vendor-name display)
(display-release-number display)))
(defun display-nscreens (display)
(declare (type display display))
(length (display-roots display)))
#+comment ;; defined by the DISPLAY defstruct
(defsetf display-error-handler (display) (handler)
;; All errors (synchronous and asynchronous) are processed by calling an error
;; handler in the display. If handler is a sequence it is expected to contain
;; handler functions specific to each error; the error code is used to index the
;; sequence, fetching the appropriate handler. Any results returned by the handler
;; are ignored; it is assumed the handler either takes care of the error
;; completely, or else signals. For all core errors, the keyword/value argument
;; pairs are:
;; :display display
;; :error-key error-key
;; :major integer
;; :minor integer
;; :sequence integer
;; :current-sequence integer
;; For :colormap, :cursor, :drawable, :font, :gcontext, :id-choice, :pixmap, and
;; :window errors another pair is:
;; :resource-id integer
;; For :atom errors, another pair is:
;; :atom-id integer
;; For :value errors, another pair is:
;; :value integer
)
;; setf'able
;; If defined, called after every protocol request is generated, even those inside
;; explicit with-display's, but never called from inside the after-function itself.
;; The function is called inside the effective with-display for the associated
;; request. Default value is nil. Can be set, for example, to
;; #'display-force-output or #'display-finish-output.
(defvar *inside-display-after-function* nil)
(defun display-invoke-after-function (display)
; Called after every protocal request is generated
(declare (type display display))
(when (and (display-after-function display)
(not *inside-display-after-function*))
(let ((*inside-display-after-function* t)) ;; Ensure no recursive calls
(funcall (display-after-function display) display))))
(defun display-finish-output (display)
;; Forces output, then causes a round-trip to ensure that all possible
;; errors and events have been received.
(declare (type display display))
(with-buffer-request-and-reply (display +x-getinputfocus+ 16 :sizes (8 32))
()
)
;; Report asynchronous errors here if the user wants us to.
(report-asynchronous-errors display :after-finish-output))
(defparameter
*request-names*
'#("error" "CreateWindow" "ChangeWindowAttributes" "GetWindowAttributes"
"DestroyWindow" "DestroySubwindows" "ChangeSaveSet" "ReparentWindow"
"MapWindow" "MapSubwindows" "UnmapWindow" "UnmapSubwindows"
"ConfigureWindow" "CirculateWindow" "GetGeometry" "QueryTree"
"InternAtom" "GetAtomName" "ChangeProperty" "DeleteProperty"
"GetProperty" "ListProperties" "SetSelectionOwner" "GetSelectionOwner"
"ConvertSelection" "SendEvent" "GrabPointer" "UngrabPointer"
"GrabButton" "UngrabButton" "ChangeActivePointerGrab" "GrabKeyboard"
"UngrabKeyboard" "GrabKey" "UngrabKey" "AllowEvents"
"GrabServer" "UngrabServer" "QueryPointer" "GetMotionEvents"
"TranslateCoords" "WarpPointer" "SetInputFocus" "GetInputFocus"
"QueryKeymap" "OpenFont" "CloseFont" "QueryFont"
"QueryTextExtents" "ListFonts" "ListFontsWithInfo" "SetFontPath"
"GetFontPath" "CreatePixmap" "FreePixmap" "CreateGC"
"ChangeGC" "CopyGC" "SetDashes" "SetClipRectangles"
"FreeGC" "ClearToBackground" "CopyArea" "CopyPlane"
"PolyPoint" "PolyLine" "PolySegment" "PolyRectangle"
"PolyArc" "FillPoly" "PolyFillRectangle" "PolyFillArc"
"PutImage" "GetImage" "PolyText8" "PolyText16"
"ImageText8" "ImageText16" "CreateColormap" "FreeColormap"
"CopyColormapAndFree" "InstallColormap" "UninstallColormap" "ListInstalledColormaps"
"AllocColor" "AllocNamedColor" "AllocColorCells" "AllocColorPlanes"
"FreeColors" "StoreColors" "StoreNamedColor" "QueryColors"
"LookupColor" "CreateCursor" "CreateGlyphCursor" "FreeCursor"
"RecolorCursor" "QueryBestSize" "QueryExtension" "ListExtensions"
"SetKeyboardMapping" "GetKeyboardMapping" "ChangeKeyboardControl" "GetKeyboardControl"
"Bell" "ChangePointerControl" "GetPointerControl" "SetScreenSaver"
"GetScreenSaver" "ChangeHosts" "ListHosts" "ChangeAccessControl"
"ChangeCloseDownMode" "KillClient" "RotateProperties" "ForceScreenSaver"
"SetPointerMapping" "GetPointerMapping" "SetModifierMapping" "GetModifierMapping"))

3806
src/eclx/doc.lisp
View file

File diff suppressed because it is too large Load diff

368
src/eclx/fonts.lisp
View file

@ -1,368 +0,0 @@
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
#+cmu
(ext:file-comment
"$Header$")
(in-package :xlib)
;; The char-info stuff is here instead of CLX because of uses of int16->card16.
; To allow efficient storage representations, the type char-info is not
; required to be a structure.
;; For each of left-bearing, right-bearing, width, ascent, descent, attributes:
;(defun char-<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)
; (clx-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)
; (clx-values integer)))
;(defun min-char-<metric> (font)
; (declare (type font font)
; (clx-values integer)))
;; Note: char16-<metric> accessors could be defined to accept two-byte indexes.
(deftype char-info-vec () '(simple-array int16 (*)))
(macrolet ((def-char-info-accessors (useless-name &body fields)
`(within-definition (,useless-name def-char-info-accessors)
,@(do ((field fields (cdr field))
(n 0 (1+ n))
(name) (type)
(result nil))
((endp field) result)
(setq name (xintern 'char- (caar field)))
(setq type (cadar field))
(flet ((from (form)
(if (eq type 'int16)
form
`(,(xintern 'int16-> type) ,form))))
(push
`(defun ,name (font index)
(declare (type font font)
(type array-index index))
(declare (clx-values (or null ,type)))
(when (and (font-name font)
(index>= (font-max-char font) index (font-min-char font)))
(the ,type
,(from
`(the int16
(let ((char-info-vector (font-char-infos font)))
(declare (type char-info-vec char-info-vector))
(if (index-zerop (length char-info-vector))
;; Fixed width font
(aref (the char-info-vec
(font-max-bounds font))
,n)
;; Variable width font
(aref char-info-vector
(index+
(index*
6
(index-
index
(font-min-char font)))
,n)))))))))
result)
(setq name (xintern 'min-char- (caar field)))
(push
`(defun ,name (font)
(declare (type font font))
(declare (clx-values (or null ,type)))
(when (font-name font)
(the ,type
,(from
`(the int16
(aref (the char-info-vec (font-min-bounds font))
,n))))))
result)
(setq name (xintern 'max-char- (caar field)))
(push
`(defun ,name (font)
(declare (type font font))
(declare (clx-values (or null ,type)))
(when (font-name font)
(the ,type
,(from
`(the int16
(aref (the char-info-vec (font-max-bounds font))
,n))))))
result)))
(defun make-char-info
(&key ,@(mapcar
#'(lambda (field)
`(,(car field) (required-arg ,(car field))))
fields))
(declare ,@(mapcar #'(lambda (field) `(type ,@(reverse field))) fields))
(let ((result (make-array ,(length fields) :element-type 'int16)))
(declare (type char-info-vec result))
,@(do* ((field fields (cdr field))
(var (caar field) (caar field))
(type (cadar field) (cadar field))
(n 0 (1+ n))
(result nil))
((endp field) (nreverse result))
(push `(setf (aref result ,n)
,(if (eq type 'int16)
var
`(,(xintern type '->int16) ,var)))
result))
result)))))
(def-char-info-accessors ignore
(left-bearing int16)
(right-bearing int16)
(width int16)
(ascent int16)
(descent int16)
(attributes card16)))
(defun open-font (display name)
;; Font objects may be cached and reference counted locally within the display
;; object. This function might not execute a with-display if the font is cached.
;; The protocol QueryFont request happens on-demand under the covers.
(declare (type display display)
(type stringable name))
(declare (clx-values font))
(let* ((name-string (string-downcase (string name)))
(font (car (member name-string (display-font-cache display)
:key 'font-name
:test 'equal)))
font-id)
(unless font
(setq font (make-font :display display :name name-string))
(setq font-id (allocate-resource-id display font 'font))
(setf (font-id-internal font) font-id)
(with-buffer-request (display +x-openfont+)
(resource-id font-id)
(card16 (length name-string))
(pad16 nil)
(string name-string))
(push font (display-font-cache display)))
(incf (font-reference-count font))
font))
(defun open-font-internal (font)
;; Called "under the covers" to open a font object
(declare (type font font))
(declare (clx-values resource-id))
(let* ((name-string (font-name font))
(display (font-display font))
(id (allocate-resource-id display font 'font)))
(setf (font-id-internal font) id)
(with-buffer-request (display +x-openfont+)
(resource-id id)
(card16 (length name-string))
(pad16 nil)
(string name-string))
(push font (display-font-cache display))
(incf (font-reference-count font))
id))
(defun discard-font-info (font)
;; Discards any state that can be re-obtained with QueryFont. This is
;; simply a performance hint for memory-limited systems.
(declare (type font font))
(setf (font-font-info-internal font) nil
(font-char-infos-internal font) nil))
(defun query-font (font)
;; Internal function called by font and char info accessors
(declare (type font font))
(declare (clx-values font-info))
(let ((display (font-display font))
font-id
font-info
props)
(setq font-id (font-id font)) ;; May issue an open-font request
(with-buffer-request-and-reply (display +x-queryfont+ 60)
((resource-id font-id))
(let* ((min-byte2 (card16-get 40))
(max-byte2 (card16-get 42))
(min-byte1 (card8-get 49))
(max-byte1 (card8-get 50))
(min-char min-byte2)
(max-char (index+ (index-ash max-byte1 8) max-byte2))
(nfont-props (card16-get 46))
(nchar-infos (index* (card32-get 56) 6))
(char-info (make-array nchar-infos :element-type 'int16)))
(setq font-info
(make-font-info
:direction (member8-get 48 :left-to-right :right-to-left)
:min-char min-char
:max-char max-char
:min-byte1 min-byte1
:max-byte1 max-byte1
:min-byte2 min-byte2
:max-byte2 max-byte2
:all-chars-exist-p (boolean-get 51)
:default-char (card16-get 44)
:ascent (int16-get 52)
:descent (int16-get 54)
:min-bounds (char-info-get 8)
:max-bounds (char-info-get 24)))
(setq props (sequence-get :length (index* 2 nfont-props) :format int32
:result-type 'list :index 60))
(sequence-get :length nchar-infos :format int16 :data char-info
:index (index+ 60 (index* 2 nfont-props 4)))
(setf (font-char-infos-internal font) char-info)
(setf (font-font-info-internal font) font-info)))
;; Replace atom id's with keywords in the plist
(do ((p props (cddr p)))
((endp p))
(setf (car p) (atom-name display (car p))))
(setf (font-info-properties font-info) props)
font-info))
(defun close-font (font)
;; This might not generate a protocol request if the font is reference
;; counted locally.
(declare (type font font))
(when (and (not (plusp (decf (font-reference-count font))))
(font-id-internal font))
(let ((display (font-display font))
(id (font-id-internal font)))
(declare (type display display))
;; Remove font from cache
(setf (display-font-cache display) (delete font (display-font-cache display)))
;; Close the font
(with-buffer-request (display +x-closefont+)
(resource-id id)))))
(defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list))
(declare (type display display)
(type string pattern)
(type card16 max-fonts)
(type t result-type)) ;; CL type
(declare (clx-values (clx-sequence string)))
(let ((string (string pattern)))
(with-buffer-request-and-reply (display +x-listfonts+ size :sizes (8 16))
((card16 max-fonts (length string))
(string string))
(values
(read-sequence-string
buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+)))))
(defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list))
;; Note: Was called list-fonts-with-info.
;; Returns "pseudo" fonts that contain basic font metrics and properties, but
;; no per-character metrics and no resource-ids. These pseudo fonts will be
;; converted (internally) to real fonts dynamically as needed, by issuing an
;; OpenFont request. However, the OpenFont might fail, in which case the
;; invalid-font error can arise.
(declare (type display display)
(type string pattern)
(type card16 max-fonts)
(type t result-type)) ;; CL type
(declare (clx-values (clx-sequence font)))
(let ((string (string pattern))
(result nil))
(with-buffer-request-and-reply (display +x-listfontswithinfo+ 60
:sizes (8 16) :multiple-reply t)
((card16 max-fonts (length string))
(string string))
(cond ((zerop (card8-get 1)) t)
(t
(let* ((name-len (card8-get 1))
(min-byte2 (card16-get 40))
(max-byte2 (card16-get 42))
(min-byte1 (card8-get 49))
(max-byte1 (card8-get 50))
(min-char min-byte2)
(max-char (index+ (index-ash max-byte1 8) max-byte2))
(nfont-props (card16-get 46))
(font
(make-font
:display display
:name nil
:font-info-internal
(make-font-info
:direction (member8-get 48 :left-to-right :right-to-left)
:min-char min-char
:max-char max-char
:min-byte1 min-byte1
:max-byte1 max-byte1
:min-byte2 min-byte2
:max-byte2 max-byte2
:all-chars-exist-p (boolean-get 51)
:default-char (card16-get 44)
:ascent (int16-get 52)
:descent (int16-get 54)
:min-bounds (char-info-get 8)
:max-bounds (char-info-get 24)
:properties (sequence-get :length (index* 2 nfont-props)
:format int32
:result-type 'list
:index 60)))))
(setf (font-name font) (string-get name-len (index+ 60 (index* 2 nfont-props 4))))
(push font result))
nil)))
;; Replace atom id's with keywords in the plist
(dolist (font result)
(do ((p (font-properties font) (cddr p)))
((endp p))
(setf (car p) (atom-name display (car p)))))
(coerce (nreverse result) result-type)))
(defun font-path (display &key (result-type 'list))
(declare (type display display)
(type t result-type)) ;; CL type
(declare (clx-values (clx-sequence (or string pathname))))
(with-buffer-request-and-reply (display +x-getfontpath+ size :sizes (8 16))
()
(values
(read-sequence-string
buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+))))
(defun set-font-path (display paths)
(declare (type display display)
(type (clx-sequence (or string pathname)) paths))
(let ((path-length (length paths))
(request-length 8))
;; Find the request length
(dotimes (i path-length)
(let* ((string (string (elt paths i)))
(len (length string)))
(incf request-length (1+ len))))
(with-buffer-request (display +x-setfontpath+ :length request-length)
(length (ceiling request-length 4))
(card16 path-length)
(pad16 nil)
(progn
(incf buffer-boffset 8)
(dotimes (i path-length)
(let* ((string (string (elt paths i)))
(len (length string)))
(card8-put 0 len)
(string-put 1 string :appending t :header-length 1)
(incf buffer-boffset (1+ len))))
(setf (buffer-boffset display) (lround buffer-boffset)))))
paths)
(defsetf font-path set-font-path)

974
src/eclx/gcontext.lisp
View file

@ -1,974 +0,0 @@
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
;;; GContext
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
;;; GContext values are usually cached locally in the GContext object.
;;; This is required because the X.11 server doesn't have any requests
;;; for getting GContext values back.
;;;
;;; GContext changes are cached until force-GContext-changes is called.
;;; All the requests that use GContext (including the GContext accessors,
;;; but not the SETF's) call force-GContext-changes.
;;; In addition, the macro WITH-GCONTEXT may be used to provide a
;;; local view if a GContext.
;;;
;;; Each GContext keeps a copy of the values the server has seen, and
;;; a copy altered by SETF, called the LOCAL-STATE (bad name...).
;;; The SETF accessors increment a timestamp in the GContext.
;;; When the timestamp in a GContext isn't equal to the timestamp in
;;; the local-state, changes have been made, and force-GContext-changes
;;; loops through the GContext and local-state, sending differences to
;;; the server, and updating GContext.
;;;
;;; WITH-GCONTEXT works by BINDING the local-state slot in a GContext to
;;; a private copy. This is easy (and fast) for lisp machines, but other
;;; lisps will have problems. Fortunately, most other lisps don't care,
;;; because they don't run in a multi-processing shared-address space
;;; environment.
#+cmu
(ext:file-comment
"$Header$")
(in-package :xlib)
;; GContext state accessors
;; The state vector contains all card32s to speed server updating
(eval-when (:execute :compile-toplevel :load-toplevel)
(defconstant +gcontext-fast-change-length+ #.(length *gcontext-components*))
(macrolet ((def-gc-internals (name &rest extras)
(let ((macros nil)
(indexes nil)
(masks nil)
(index 0))
(dolist (name *gcontext-components*)
(push `(defmacro ,(xintern 'gcontext-internal- name) (state)
`(svref ,state ,,index))
macros)
(setf (getf indexes name) index)
(push (ash 1 index) masks)
(incf index))
(dolist (extra extras)
(push `(defmacro ,(xintern 'gcontext-internal- (first extra)) (state)
`(svref ,state ,,index))
macros)
;; don't override already correct index entries
(unless (or (getf indexes (second extra)) (getf indexes (first extra)))
(setf (getf indexes (or (second extra) (first extra))) index))
(push (logior (ash 1 index)
(if (second extra)
(ash 1 (position (second extra) *gcontext-components*))
0))
masks)
(incf index))
`(within-definition (def-gc-internals ,name)
,@(nreverse macros)
(eval-when (:execute :compile-toplevel :load-toplevel)
(defparameter *gcontext-data-length* ,index)
(defparameter *gcontext-indexes* ',indexes)
(defparameter *gcontext-masks*
',(coerce (nreverse masks) 'simple-vector)))))))
(def-gc-internals ignore
(:clip :clip-mask) (:dash :dashes) (:font-obj :font) (:timestamp)))
) ;; end EVAL-WHEN
(deftype gcmask () '(unsigned-byte #.+gcontext-fast-change-length+))
(deftype xgcmask () '(unsigned-byte #.*gcontext-data-length*))
(defstruct (gcontext-extension (:type vector) (:copier nil)) ;; un-named
(name nil :type symbol :read-only t)
(default nil :type t :read-only t)
(set-function #'(lambda (gcontext value)
(declare (ignore gcontext))
value)
:type (function (gcontext t) t) :read-only t)
(copy-function #'(lambda (from-gc to-gc value)
(declare (ignore from-gc to-gc))
value)
:type (function (gcontext gcontext t) t) :read-only t))
(defvar *gcontext-extensions* nil) ;; list of gcontext-extension
;; Gcontext state Resource
(defvar *gcontext-local-state-cache* nil) ;; List of unused gcontext local states
(defmacro gcontext-state-next (state)
`(svref ,state 0))
(defun allocate-gcontext-state ()
;; Allocate a gcontext-state
;; Loop until a local state is found that's large enough to hold
;; any extensions that may exist.
(let ((length (index+ *gcontext-data-length* (length *gcontext-extensions*))))
(declare (type array-index length))
(loop
(let ((state (or (threaded-atomic-pop *gcontext-local-state-cache*
gcontext-state-next gcontext-state)
(make-array length :initial-element nil))))
(declare (type gcontext-state state))
(when (index>= (length state) length)
(return state))))))
(defun deallocate-gcontext-state (state)
(declare (type gcontext-state state))
(fill state nil)
(threaded-atomic-push state *gcontext-local-state-cache*
gcontext-state-next gcontext-state))
;; Temp-Gcontext Resource
(defvar *temp-gcontext-cache* nil) ;; List of unused gcontexts
(defun allocate-temp-gcontext ()
(or (threaded-atomic-pop *temp-gcontext-cache* gcontext-next gcontext)
(make-gcontext :local-state '#() :server-state '#())))
(defun deallocate-temp-gcontext (gc)
(declare (type gcontext gc))
(threaded-atomic-push gc *temp-gcontext-cache* gcontext-next gcontext))
;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared
;; as (type <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)
; (clx-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 (clx-values (or null ,type)))
(let ((value (,internal-accessor (gcontext-local-state gcontext))))
(declare (type (or null card32) value))
(when value ;; Don't do anything when value isn't known
(let ((%buffer (gcontext-display gcontext)))
(declare (type display %buffer))
%buffer
(decode-type ,type value)))))
(defun ,internal-setfer (gcontext value)
(declare (type gcontext gcontext)
(type ,type value))
(modify-gcontext (gcontext local-state)
(setf (,internal-accessor local-state) (encode-type ,type value))
,@(when (eq type 'pixmap)
;; write-through pixmaps, because the protocol allows
;; the server to copy the pixmap contents at the time
;; of the store, rather than continuing to share with
;; the pixmap.
`((let ((server-state (gcontext-server-state gcontext)))
(setf (,internal-accessor server-state) nil))))
value))
(defsetf ,gcontext-name ,internal-setfer))))
(defmacro incf-internal-timestamp (state)
(let ((ts (gensym)))
`(let ((,ts (the fixnum (gcontext-internal-timestamp ,state))))
(declare (type fixnum ,ts))
;; the probability seems low enough
(setq ,ts (if (= ,ts most-positive-fixnum)
1
(the fixnum (1+ ,ts))))
(setf (gcontext-internal-timestamp ,state) ,ts))))
(def-gc-accessor function boole-constant)
(def-gc-accessor plane-mask card32)
(def-gc-accessor foreground card32)
(def-gc-accessor background card32)
(def-gc-accessor line-width card16)
(def-gc-accessor line-style (member :solid :dash :double-dash))
(def-gc-accessor cap-style (member :not-last :butt :round :projecting))
(def-gc-accessor join-style (member :miter :round :bevel))
(def-gc-accessor fill-style (member :solid :tiled :stippled :opaque-stippled))
(def-gc-accessor fill-rule (member :even-odd :winding))
(def-gc-accessor tile pixmap)
(def-gc-accessor stipple pixmap)
(def-gc-accessor ts-x int16) ;; Tile-Stipple-X-origin
(def-gc-accessor ts-y int16) ;; Tile-Stipple-Y-origin
;; (def-GC-accessor font font) ;; See below
(def-gc-accessor subwindow-mode (member :clip-by-children :include-inferiors))
(def-gc-accessor exposures (member :off :on))
(def-gc-accessor clip-x int16)
(def-gc-accessor clip-y int16)
;; (def-GC-accessor clip-mask) ;; see below
(def-gc-accessor dash-offset card16)
;; (def-GC-accessor dashes) ;; see below
(def-gc-accessor arc-mode (member :chord :pie-slice))
(defun gcontext-clip-mask (gcontext)
(declare (type gcontext gcontext))
(declare (clx-values (or null (member :none) pixmap rect-seq)
(or null (member :unsorted :y-sorted :yx-sorted :yx-banded))))
(access-gcontext (gcontext local-state)
(multiple-value-bind (clip clip-mask)
(without-interrupts
(values (gcontext-internal-clip local-state)
(gcontext-internal-clip-mask local-state)))
(if (null clip)
(values (let ((%buffer (gcontext-display gcontext)))
(declare (type display %buffer))
(decode-type (or (member :none) pixmap) clip-mask))
nil)
(values (second clip)
(decode-type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded))
(first clip)))))))
(defsetf gcontext-clip-mask (gcontext &optional ordering) (clip-mask)
;; A bit strange, but retains setf form.
;; a nil clip-mask is transformed to an empty vector
`(set-gcontext-clip-mask ,gcontext ,ordering ,clip-mask))
(defun set-gcontext-clip-mask (gcontext ordering clip-mask)
;; a nil clip-mask is transformed to an empty vector
(declare (type gcontext gcontext)
(type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) ordering)
(type (or (member :none) pixmap rect-seq) clip-mask))
(unless clip-mask (x-type-error clip-mask '(or (member :none) pixmap rect-seq)))
(multiple-value-bind (clip-mask clip)
(typecase clip-mask
(pixmap (values (pixmap-id clip-mask) nil))
((member :none) (values 0 nil))
(sequence
(values nil
(list (encode-type
(or null (member :unsorted :y-sorted :yx-sorted :yx-banded))
ordering)
(copy-seq clip-mask))))
(otherwise (x-type-error clip-mask '(or (member :none) pixmap rect-seq))))
(modify-gcontext (gcontext local-state)
(let ((server-state (gcontext-server-state gcontext)))
(declare (type gcontext-state server-state))
(without-interrupts
(setf (gcontext-internal-clip local-state) clip
(gcontext-internal-clip-mask local-state) clip-mask)
(if (null clip)
(setf (gcontext-internal-clip server-state) nil)
(setf (gcontext-internal-clip-mask server-state) nil))
(when (and clip-mask (not (zerop clip-mask)))
;; write-through clip-mask pixmap, because the protocol allows the
;; server to copy the pixmap contents at the time of the store,
;; rather than continuing to share with the pixmap.
(setf (gcontext-internal-clip-mask server-state) nil))))))
clip-mask)
(defun gcontext-dashes (gcontext)
(declare (type gcontext gcontext))
(declare (clx-values (or null card8 sequence)))
(access-gcontext (gcontext local-state)
(multiple-value-bind (dash dashes)
(without-interrupts
(values (gcontext-internal-dash local-state)
(gcontext-internal-dashes local-state)))
(if (null dash)
dashes
dash))))
(defsetf gcontext-dashes set-gcontext-dashes)
(defun set-gcontext-dashes (gcontext dashes)
(declare (type gcontext gcontext)
(type (or card8 sequence) dashes))
(multiple-value-bind (dashes dash)
(if (type? dashes 'sequence)
(if (zerop (length dashes))
(x-type-error dashes '(or card8 sequence) "non-empty sequence")
(values nil (or (copy-seq dashes) (vector))))
(values (encode-type card8 dashes) nil))
(modify-gcontext (gcontext local-state)
(let ((server-state (gcontext-server-state gcontext)))
(declare (type gcontext-state server-state))
(without-interrupts
(setf (gcontext-internal-dash local-state) dash
(gcontext-internal-dashes local-state) dashes)
(if (null dash)
(setf (gcontext-internal-dash server-state) nil)
(setf (gcontext-internal-dashes server-state) nil))))))
dashes)
(defun gcontext-font (gcontext &optional metrics-p)
;; If the stored font is known, it is returned. If it is not known and
;; metrics-p is false, then nil is returned. If it is not known and
;; metrics-p is true, then a pseudo font is returned. Full metric and
;; property information can be obtained, but the font does not have a name or
;; a resource-id, and attempts to use it where a resource-id is required will
;; result in an invalid-font error.
(declare (type gcontext gcontext)
(type generalized-boolean metrics-p))
(declare (clx-values (or null font)))
(access-gcontext (gcontext local-state)
(let ((font (gcontext-internal-font-obj local-state)))
(or font
(when metrics-p
;; XXX this isn't correct
(make-font :display (gcontext-display gcontext)
:id (gcontext-id gcontext)
:name nil))))))
(defsetf gcontext-font set-gcontext-font)
(defun set-gcontext-font (gcontext font)
(declare (type gcontext gcontext)
(type fontable font))
(let* ((font-object (if (font-p font) font (open-font (gcontext-display gcontext) font)))
(font (and font-object (font-id font-object))))
;; XXX need to check font has id (and name?)
(modify-gcontext (gcontext local-state)
(let ((server-state (gcontext-server-state gcontext)))
(declare (type gcontext-state server-state))
(without-interrupts
(setf (gcontext-internal-font-obj local-state) font-object
(gcontext-internal-font local-state) font)
;; check against font, not against font-obj
(if (null font)
(setf (gcontext-internal-font server-state) nil)
(setf (gcontext-internal-font-obj server-state) font-object))))))
font)
(defun force-gcontext-changes-internal (gcontext)
;; Force any delayed changes.
(declare (type gcontext gcontext))
#.(declare-buffun)
(let ((display (gcontext-display gcontext))
(server-state (gcontext-server-state gcontext))
(local-state (gcontext-local-state gcontext)))
(declare (type display display)
(type gcontext-state server-state local-state))
;; Update server when timestamps don't match
(unless (= (the fixnum (gcontext-internal-timestamp local-state))
(the fixnum (gcontext-internal-timestamp server-state)))
;; The display is already locked.
(macrolet ((with-buffer ((buffer &key timeout) &body body)
`(progn (progn ,buffer ,@(and timeout `(,timeout)) nil)
,@body)))
;; Because there is no locking on the local state we have to
;; assume that state will change and set timestamps up front,
;; otherwise by the time we figured out there were no changes
;; and tried to store the server stamp as the local stamp, the
;; local stamp might have since been modified.
(setf (gcontext-internal-timestamp local-state)
(incf-internal-timestamp server-state))
(block no-changes
(let ((last-request (buffer-last-request display)))
(with-buffer-request (display +x-changegc+)
(gcontext gcontext)
(progn
(do ((i 0 (index+ i 1))
(bit 1 (the xgcmask (ash bit 1)))
(nbyte 12)
(mask 0)
(local 0))
((index>= i +gcontext-fast-change-length+)
(when (zerop mask)
;; If nothing changed, restore last-request and quit
(setf (buffer-last-request display)
(if (zerop (buffer-last-request display))
nil
last-request))
(return-from no-changes nil))
(card29-put 8 mask)
(card16-put 2 (index-ash nbyte -2))
(index-incf (buffer-boffset display) nbyte))
(declare (type array-index i nbyte)
(type xgcmask bit)
(type gcmask mask)
(type (or null card32) local))
(unless (eql (the (or null card32) (svref server-state i))
(setq local (the (or null card32) (svref local-state i))))
(setf (svref server-state i) local)
(card32-put nbyte local)
(setq mask (the gcmask (logior mask bit)))
(index-incf nbyte 4)))))))
;; Update GContext extensions
(do ((extension *gcontext-extensions* (cdr extension))
(i *gcontext-data-length* (index+ i 1))
(local))
((endp extension))
(unless (eql (svref server-state i)
(setq local (svref local-state i)))
(setf (svref server-state i) local)
(funcall (gcontext-extension-set-function (car extension)) gcontext local)))
;; Update clipping rectangles
(multiple-value-bind (local-clip server-clip)
(without-interrupts
(values (gcontext-internal-clip local-state)
(gcontext-internal-clip server-state)))
(unless (equalp local-clip server-clip)
(setf (gcontext-internal-clip server-state) nil)
(unless (null local-clip)
(with-buffer-request (display +x-setcliprectangles+)
(data (first local-clip))
(gcontext gcontext)
;; XXX treat nil correctly
(card16 (or (gcontext-internal-clip-x local-state) 0)
(or (gcontext-internal-clip-y local-state) 0))
;; XXX this has both int16 and card16 values
((sequence :format int16) (second local-clip)))
(setf (gcontext-internal-clip server-state) local-clip))))
;; Update dashes
(multiple-value-bind (local-dash server-dash)
(without-interrupts
(values (gcontext-internal-dash local-state)
(gcontext-internal-dash server-state)))
(unless (equalp local-dash server-dash)
(setf (gcontext-internal-dash server-state) nil)
(unless (null local-dash)
(with-buffer-request (display +x-setdashes+)
(gcontext gcontext)
;; XXX treat nil correctly
(card16 (or (gcontext-internal-dash-offset local-state) 0)
(length local-dash))
((sequence :format card8) local-dash))
(setf (gcontext-internal-dash server-state) local-dash))))))))
(defun force-gcontext-changes (gcontext)
;; Force any delayed changes.
(declare (type gcontext gcontext))
(let ((display (gcontext-display gcontext))
(server-state (gcontext-server-state gcontext))
(local-state (gcontext-local-state gcontext)))
(declare (type gcontext-state server-state local-state))
;; Update server when timestamps don't match
(unless (= (the fixnum (gcontext-internal-timestamp local-state))
(the fixnum (gcontext-internal-timestamp server-state)))
(with-display (display)
(force-gcontext-changes-internal gcontext)))))
;;; WARNING: WITH-GCONTEXT WORKS MUCH MORE EFFICIENTLY WHEN THE OPTIONS BEING "BOUND" ARE
;;; SET IN THE GCONTEXT ON ENTRY. BECAUSE THERE'S NO WAY TO GET THE VALUE OF AN
;;; UNKNOWN GC COMPONENT, WITH-GCONTEXT MUST CREATE A TEMPORARY GC, COPY THE UNKNOWN
;;; COMPONENTS TO THE TEMPORARY GC, ALTER THE GC BEING USED, THEN COPY COMPOMENTS
;;; BACK.
(defmacro with-gcontext ((gcontext &rest options &key clip-ordering
&allow-other-keys)
&body body)
;; "Binds" the gcontext components specified by options within the
;; dynamic scope of the body (i.e., indefinite scope and dynamic
;; extent), on a per-process basis in a multi-process environment.
;; The body is not surrounded by a with-display. If cache-p is nil or
;; the some component states are unknown, this will implement
;; save/restore by creating a temporary gcontext and doing
;; copy-gcontext-components to and from it.
(declare (arglist (gcontext &rest options &key
function plane-mask foreground background
line-width line-style cap-style join-style
fill-style fill-rule arc-mode tile stipple ts-x
ts-y font subwindow-mode exposures clip-x clip-y
clip-mask clip-ordering dash-offset dashes
&allow-other-keys)
&body body))
(remf options :clip-ordering)
(let ((gc (gensym))
(saved-state (gensym))
(temp-gc (gensym))
(temp-mask (gensym))
(temp-vars nil)
(setfs nil)
(indexes nil) ; List of gcontext field indices
(extension-indexes nil) ; List of gcontext extension field indices
(ts-index (getf *gcontext-indexes* :timestamp)))
(do* ((option options (cddr option))
(name (car option) (car option))
(value (cadr option) (cadr option)))
((endp option) (setq setfs (nreverse setfs)))
(let ((index (getf *gcontext-indexes* name)))
(if index
(push index indexes)
(let ((extension (find name *gcontext-extensions*
:key #'gcontext-extension-name)))
(if extension
(progn
(push (xintern "Internal-" 'gcontext- name "-State-Index")
extension-indexes))
(x-type-error name 'gcontext-key)))))
(let ((accessor `(,(xintern 'gcontext- name) ,gc
,@(when (eq name :clip-mask) `(,clip-ordering))))
(temp-var (gensym)))
(when value
(push `(,temp-var ,value) temp-vars)
(push `(when ,temp-var (setf ,accessor ,temp-var)) setfs))))
(if setfs
`(multiple-value-bind (,gc ,saved-state ,temp-mask ,temp-gc)
(copy-gcontext-local-state ,gcontext ',indexes ,@extension-indexes)
(declare (type gcontext ,gc)
(type gcontext-state ,saved-state)
(type xgcmask ,temp-mask)
(type (or null gcontext) ,temp-gc))
(with-gcontext-bindings (,gc ,saved-state
,(append indexes extension-indexes)
,ts-index ,temp-mask ,temp-gc)
(let ,temp-vars
,@setfs)
,@body))
`(progn ,@body))))
(defun copy-gcontext-local-state (gcontext indexes &rest extension-indices)
;; Called from WITH-GCONTEXT to save the fields in GCONTEXT indicated by MASK
(declare (type gcontext gcontext)
(type list indexes)
(dynamic-extent extension-indices))
(let ((local-state (gcontext-local-state gcontext))
(saved-state (allocate-gcontext-state))
(cache-p (gcontext-cache-p gcontext)))
(declare (type gcontext-state local-state saved-state))
(setf (gcontext-internal-timestamp saved-state) 1)
(let ((temp-gc nil)
(temp-mask 0)
(extension-mask 0))
(declare (type xgcmask temp-mask)
(type integer extension-mask))
(dolist (i indexes)
(when (or (not (setf (svref saved-state i) (svref local-state i)))
(not cache-p))
(setq temp-mask
(the xgcmask (logior temp-mask
(the xgcmask (svref *gcontext-masks* i)))))))
(dolist (i extension-indices)
(when (or (not (setf (svref saved-state i) (svref local-state i)))
(not cache-p))
(setq extension-mask
(the xgcmask (logior extension-mask (ash 1 i))))))
(when (or (plusp temp-mask)
(plusp extension-mask))
;; Copy to temporary GC when field unknown or cache-p false
(let ((display (gcontext-display gcontext)))
(declare (type display display))
(with-display (display)
(setq temp-gc (allocate-temp-gcontext))
(setf (gcontext-id temp-gc) (allocate-resource-id display gcontext 'gcontext)
(gcontext-display temp-gc) display
(gcontext-drawable temp-gc) (gcontext-drawable gcontext)
(gcontext-server-state temp-gc) saved-state
(gcontext-local-state temp-gc) saved-state)
;; Create a new (temporary) gcontext
(with-buffer-request (display +x-creategc+)
(gcontext temp-gc)
(drawable (gcontext-drawable gcontext))
(card29 0))
;; Copy changed components to the temporary gcontext
(when (plusp temp-mask)
(with-buffer-request (display +x-copygc+)
(gcontext gcontext)
(gcontext temp-gc)
(card29 (xgcmask->gcmask temp-mask))))
;; Copy extension fields to the new gcontext
(when (plusp extension-mask)
;; Copy extension fields from temp back to gcontext
(do ((bit (ash extension-mask (- *gcontext-data-length*)) (ash bit -1))
(i 0 (index+ i 1)))
((zerop bit))
(let ((copy-function (gcontext-extension-copy-function
(elt *gcontext-extensions* i))))
(funcall copy-function gcontext temp-gc
(svref local-state (index+ i *gcontext-data-length*))))))
)))
(values gcontext saved-state (logior temp-mask extension-mask) temp-gc))))
(defun restore-gcontext-temp-state (gcontext temp-mask temp-gc)
(declare (type gcontext gcontext temp-gc)
(type xgcmask temp-mask))
(let ((display (gcontext-display gcontext)))
(declare (type display display))
(with-display (display)
(with-buffer-request (display +x-copygc+)
(gcontext temp-gc)
(gcontext gcontext)
(card29 (xgcmask->gcmask temp-mask)))
;; Copy extension fields from temp back to gcontext
(do ((bit (ash temp-mask (- *gcontext-data-length*)) (ash bit -1))
(extensions *gcontext-extensions* (cdr extensions))
(i *gcontext-data-length* (index+ i 1))
(local-state (gcontext-local-state temp-gc)))
((zerop bit))
(let ((copy-function (gcontext-extension-copy-function (car extensions))))
(funcall copy-function temp-gc gcontext (svref local-state i))))
;; free gcontext
(with-buffer-request (display +x-freegc+)
(gcontext temp-gc))
(deallocate-resource-id display (gcontext-id temp-gc) 'gcontext)
(deallocate-temp-gcontext temp-gc)
;; Copy saved state back to server state
(do ((server-state (gcontext-server-state gcontext))
(bit (xgcmask->gcmask temp-mask) (the gcmask (ash bit -1)))
(i 0 (index+ i 1)))
((zerop bit)
(incf-internal-timestamp server-state))
(declare (type gcontext-state server-state)
(type gcmask bit)
(type array-index i))
(when (oddp bit)
(setf (svref server-state i) nil))))))
(defun create-gcontext (&rest options &key (drawable (required-arg drawable))
function plane-mask foreground background
line-width line-style cap-style join-style fill-style fill-rule
arc-mode tile stipple ts-x ts-y font subwindow-mode
exposures clip-x clip-y clip-mask clip-ordering
dash-offset dashes
(cache-p t)
&allow-other-keys)
;; Only non-nil components are passed on in the request, but for effective caching
;; assumptions have to be made about what the actual protocol defaults are. For
;; all gcontext components, a value of nil causes the default gcontext value to be
;; used. For clip-mask, this implies that an empty rect-seq cannot be represented
;; as a list. Note: use of stringable as font will cause an implicit open-font.
;; Note: papers over protocol SetClipRectangles and SetDashes special cases. If
;; cache-p is true, then gcontext state is cached locally, and changing a gcontext
;; component will have no effect unless the new value differs from the cached
;; value. Component changes (setfs and with-gcontext) are always deferred
;; regardless of the cache mode, and sent over the protocol only when required by a
;; local operation or by an explicit call to force-gcontext-changes.
(declare (type drawable drawable) ; Required to be non-null
(type (or null boole-constant) function)
(type (or null pixel) plane-mask foreground background)
(type (or null card16) line-width dash-offset)
(type (or null int16) ts-x ts-y clip-x clip-y)
(type (or null (member :solid :dash :double-dash)) line-style)
(type (or null (member :not-last :butt :round :projecting)) cap-style)
(type (or null (member :miter :round :bevel)) join-style)
(type (or null (member :solid :tiled :opaque-stippled :stippled)) fill-style)
(type (or null (member :even-odd :winding)) fill-rule)
(type (or null (member :chord :pie-slice)) arc-mode)
(type (or null pixmap) tile stipple)
(type (or null fontable) font)
(type (or null (member :clip-by-children :include-inferiors)) subwindow-mode)
(type (or null (member :on :off)) exposures)
(type (or null (member :none) pixmap rect-seq) clip-mask)
(type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering)
(type (or null card8 sequence) dashes)
(dynamic-extent options)
(type generalized-boolean cache-p))
(declare (clx-values gcontext))
(let* ((display (drawable-display drawable))
(gcontext (make-gcontext :display display :drawable drawable :cache-p cache-p))
(local-state (gcontext-local-state gcontext))
(server-state (gcontext-server-state gcontext))
(gcontextid (allocate-resource-id display gcontext 'gcontext)))
(declare (type display display)
(type gcontext gcontext)
(type resource-id gcontextid)
(type gcontext-state local-state server-state))
(setf (gcontext-id gcontext) gcontextid)
(unless function (setf (gcontext-function gcontext) boole-1))
;; using the depth of the drawable would be better, but ...
(unless plane-mask (setf (gcontext-plane-mask gcontext) #xffffffff))
(unless foreground (setf (gcontext-foreground gcontext) 0))
(unless background (setf (gcontext-background gcontext) 1))
(unless line-width (setf (gcontext-line-width gcontext) 0))
(unless line-style (setf (gcontext-line-style gcontext) :solid))
(unless cap-style (setf (gcontext-cap-style gcontext) :butt))
(unless join-style (setf (gcontext-join-style gcontext) :miter))
(unless fill-style (setf (gcontext-fill-style gcontext) :solid))
(unless fill-rule (setf (gcontext-fill-rule gcontext) :even-odd))
(unless arc-mode (setf (gcontext-arc-mode gcontext) :pie-slice))
(unless ts-x (setf (gcontext-ts-x gcontext) 0))
(unless ts-y (setf (gcontext-ts-y gcontext) 0))
(unless subwindow-mode (setf (gcontext-subwindow-mode gcontext)
:clip-by-children))
(unless exposures (setf (gcontext-exposures gcontext) :on))
(unless clip-mask (setf (gcontext-clip-mask gcontext) :none))
(unless clip-x (setf (gcontext-clip-x gcontext) 0))
(unless clip-y (setf (gcontext-clip-y gcontext) 0))
(unless dashes (setf (gcontext-dashes gcontext) 4))
(unless dash-offset (setf (gcontext-dash-offset gcontext) 0))
;; a bit kludgy, but ...
(replace server-state local-state)
(when function (setf (gcontext-function gcontext) function))
(when plane-mask (setf (gcontext-plane-mask gcontext) plane-mask))
(when foreground (setf (gcontext-foreground gcontext) foreground))
(when background (setf (gcontext-background gcontext) background))
(when line-width (setf (gcontext-line-width gcontext) line-width))
(when line-style (setf (gcontext-line-style gcontext) line-style))
(when cap-style (setf (gcontext-cap-style gcontext) cap-style))
(when join-style (setf (gcontext-join-style gcontext) join-style))
(when fill-style (setf (gcontext-fill-style gcontext) fill-style))
(when fill-rule (setf (gcontext-fill-rule gcontext) fill-rule))
(when arc-mode (setf (gcontext-arc-mode gcontext) arc-mode))
(when tile (setf (gcontext-tile gcontext) tile))
(when stipple (setf (gcontext-stipple gcontext) stipple))
(when ts-x (setf (gcontext-ts-x gcontext) ts-x))
(when ts-y (setf (gcontext-ts-y gcontext) ts-y))
(when font (setf (gcontext-font gcontext) font))
(when subwindow-mode (setf (gcontext-subwindow-mode gcontext) subwindow-mode))
(when exposures (setf (gcontext-exposures gcontext) exposures))
(when clip-x (setf (gcontext-clip-x gcontext) clip-x))
(when clip-y (setf (gcontext-clip-y gcontext) clip-y))
(when clip-mask (setf (gcontext-clip-mask gcontext clip-ordering) clip-mask))
(when dash-offset (setf (gcontext-dash-offset gcontext) dash-offset))
(when dashes (setf (gcontext-dashes gcontext) dashes))
(setf (gcontext-internal-timestamp server-state) 1)
(setf (gcontext-internal-timestamp local-state)
;; SetClipRectangles or SetDashes request need to be sent?
(if (or (gcontext-internal-clip local-state)
(gcontext-internal-dash local-state))
;; Yes, mark local state "modified" to ensure
;; force-gcontext-changes will occur.
0
;; No, mark local state "unmodified"
1))
(with-buffer-request (display +x-creategc+)
(resource-id gcontextid)
(drawable drawable)
(progn (do* ((i 0 (index+ i 1))
(bit 1 (the xgcmask (ash bit 1)))
(nbyte 16)
(mask 0)
(local (svref local-state i) (svref local-state i)))
((index>= i +gcontext-fast-change-length+)
(card29-put 12 mask)
(card16-put 2 (index-ash nbyte -2))
(index-incf (buffer-boffset display) nbyte))
(declare (type array-index i nbyte)
(type xgcmask bit)
(type gcmask mask)
(type (or null card32) local))
(unless (eql local (the (or null card32) (svref server-state i)))
(setf (svref server-state i) local)
(card32-put nbyte local)
(setq mask (the gcmask (logior mask bit)))
(index-incf nbyte 4)))))
;; Initialize extensions
(do ((extensions *gcontext-extensions* (cdr extensions))
(i *gcontext-data-length* (index+ i 1)))
((endp extensions))
(declare (type list extensions)
(type array-index i))
(setf (svref server-state i)
(setf (svref local-state i)
(gcontext-extension-default (car extensions)))))
;; Set extension values
(do* ((option-list options (cddr option-list))
(option (car option-list) (car option-list))
(extension))
((endp option-list))
(declare (type list option-list))
(cond ((getf *gcontext-indexes* option)) ; Gcontext field
((member option '(:drawable :clip-ordering :cache-p))) ; Optional parameter
((setq extension (find option *gcontext-extensions*
:key #'gcontext-extension-name))
(funcall (gcontext-extension-set-function extension)
gcontext (second option-list)))
(t (x-type-error option 'gcontext-key))))
gcontext))
(defun copy-gcontext-components (src dst &rest keys)
(declare (type gcontext src dst)
(dynamic-extent keys))
;; you might ask why this isn't just a bunch of
;; (setf (gcontext-<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 symbol set-function) ;; required
(type symbol copy-function))
(let* ((gc-name (intern (concatenate 'string
(string 'gcontext-)
(string name)))) ;; in current package
(key-name (kintern name))
(setfer (xintern "Set-" gc-name))
(internal-set-function (xintern "Internal-Set-" gc-name))
(internal-copy-function (xintern "Internal-Copy-" gc-name))
(internal-state-index (xintern "Internal-" gc-name "-State-Index")))
(unless copy-function
(setq copy-function
`(lambda (src-gc dst-gc value)
(declare (ignore src-gc))
(if value
(,set-function dst-gc value)
(error "Can't copy unknown GContext component ~a" ',name)))))
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter ,internal-state-index
(add-gcontext-extension ',key-name ,default ',internal-set-function
',internal-copy-function))
) ;; end eval-when
(defun ,gc-name (gcontext)
(svref (gcontext-local-state gcontext) ,internal-state-index))
(defun ,setfer (gcontext new-value)
(let ((local-state (gcontext-local-state gcontext)))
(setf (gcontext-internal-timestamp local-state) 0)
(setf (svref local-state ,internal-state-index) new-value)))
(defsetf ,gc-name ,setfer)
(defun ,internal-set-function (gcontext new-value)
(,set-function gcontext new-value)
(setf (svref (gcontext-server-state gcontext) ,internal-state-index)
(setf (svref (gcontext-local-state gcontext) ,internal-state-index)
new-value)))
(defun ,internal-copy-function (src-gc dst-gc new-value)
(,copy-function src-gc dst-gc new-value)
(setf (svref (gcontext-local-state dst-gc) ,internal-state-index)
(setf (svref (gcontext-server-state dst-gc) ,internal-state-index)
new-value)))
',name)))
;; GContext extension fields are treated in much the same way as normal GContext
;; components. The current value is stored in a slot of the gcontext-local-state,
;; and the value known to the server is in a slot of the gcontext-server-state.
;; The slot-number is defined by its position in the *gcontext-extensions* list.
;; The value of the special variable |Internal-GCONTEXT-name| (where "name" is
;; the extension component name) reflects this position. The position within
;; *gcontext-extensions* and the value of the special value are determined at
;; LOAD time to facilitate merging of seperately compiled extension files.
(defun add-gcontext-extension (name default-value set-function copy-function)
(declare (type symbol name)
(type t default-value)
(type (function (gcontext t) t) set-function)
(type (function (gcontext gcontext t) t) copy-function))
(let ((number (or (position name *gcontext-extensions* :key #'gcontext-extension-name)
(prog1 (length *gcontext-extensions*)
(push nil *gcontext-extensions*)))))
(setf (nth number *gcontext-extensions*)
(make-gcontext-extension :name name
:default default-value
:set-function set-function
:copy-function copy-function))
(+ number *gcontext-data-length*)))

450
src/eclx/graphics.lisp
View file

@ -1,450 +0,0 @@
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
;;; CLX drawing requests
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
#+cmu
(ext:file-comment
"$Header$")
(in-package :xlib)
(defvar *inhibit-appending* nil)
(defun draw-point (drawable gcontext x y)
;; Should be clever about appending to existing buffered protocol request.
(declare (type drawable drawable)
(type gcontext gcontext)
(type int16 x y))
(let ((display (drawable-display drawable)))
(declare (type display display))
(with-display (display)
(force-gcontext-changes-internal gcontext)
(with-buffer-output (display :length +requestsize+)
(let* ((last-request-byte (display-last-request display))
(current-boffset buffer-boffset))
;; To append or not append, that is the question
(if (and (not *inhibit-appending*)
last-request-byte
;; Same request?
(= (aref-card8 buffer-bbuf last-request-byte) +x-polypoint+)
(progn ;; Set buffer pointers to last request
(set-buffer-offset last-request-byte)
;; same drawable and gcontext?
(or (compare-request (4)
(data 0)
(drawable drawable)
(gcontext gcontext))
(progn ;; If failed, reset buffer pointers
(set-buffer-offset current-boffset)
nil))))
;; Append request
(progn
;; Set new request length
(card16-put 2 (index+ 1 (index-ash (index- current-boffset last-request-byte)
-2)))
(set-buffer-offset current-boffset)
(put-items (0) ; Insert new point
(int16 x y))
(setf (display-boffset display) (index+ buffer-boffset 4)))
;; New Request
(progn
(put-items (4)
(code +x-polypoint+)
(data 0) ;; Relative-p false
(length 4)
(drawable drawable)
(gcontext gcontext)
(int16 x y))
(buffer-new-request-number display)
(setf (buffer-last-request display) buffer-boffset)
(setf (display-boffset display) (index+ buffer-boffset 16)))))))
(display-invoke-after-function display)))
(defun draw-points (drawable gcontext points &optional relative-p)
(declare (type drawable drawable)
(type gcontext gcontext)
(type sequence points) ;(repeat-seq (integer x) (integer y))
(type generalized-boolean relative-p))
(with-buffer-request ((drawable-display drawable) +x-polypoint+ :gc-force gcontext)
((data boolean) relative-p)
(drawable drawable)
(gcontext gcontext)
((sequence :format int16) points)))
(defun draw-line (drawable gcontext x1 y1 x2 y2 &optional relative-p)
;; Should be clever about appending to existing buffered protocol request.
(declare (type drawable drawable)
(type gcontext gcontext)
(type int16 x1 y1 x2 y2)
(type generalized-boolean relative-p))
(let ((display (drawable-display drawable)))
(declare (type display display))
(when relative-p
(incf x2 x1)
(incf y2 y1))
(with-display (display)
(force-gcontext-changes-internal gcontext)
(with-buffer-output (display :length +requestsize+)
(let* ((last-request-byte (display-last-request display))
(current-boffset buffer-boffset))
;; To append or not append, that is the question
(if (and (not *inhibit-appending*)
last-request-byte
;; Same request?
(= (aref-card8 buffer-bbuf last-request-byte) +x-polysegment+)
(progn ;; Set buffer pointers to last request
(set-buffer-offset last-request-byte)
;; same drawable and gcontext?
(or (compare-request (4)
(drawable drawable)
(gcontext gcontext))
(progn ;; If failed, reset buffer pointers
(set-buffer-offset current-boffset)
nil))))
;; Append request
(progn
;; Set new request length
(card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte)
-2)))
(set-buffer-offset current-boffset)
(put-items (0) ; Insert new point
(int16 x1 y1 x2 y2))
(setf (display-boffset display) (index+ buffer-boffset 8)))
;; New Request
(progn
(put-items (4)
(code +x-polysegment+)
(length 5)
(drawable drawable)
(gcontext gcontext)
(int16 x1 y1 x2 y2))
(buffer-new-request-number display)
(setf (buffer-last-request display) buffer-boffset)
(setf (display-boffset display) (index+ buffer-boffset 20)))))))
(display-invoke-after-function display)))
(defun draw-lines (drawable gcontext points &key relative-p fill-p (shape :complex))
(declare (type drawable drawable)
(type gcontext gcontext)
(type sequence points) ;(repeat-seq (integer x) (integer y))
(type generalized-boolean relative-p fill-p)
(type (member :complex :non-convex :convex) shape))
(if fill-p
(fill-polygon drawable gcontext points relative-p shape)
(with-buffer-request ((drawable-display drawable) +x-polyline+ :gc-force gcontext)
((data boolean) relative-p)
(drawable drawable)
(gcontext gcontext)
((sequence :format int16) points))))
;; Internal function called from DRAW-LINES
(defun fill-polygon (drawable gcontext points relative-p shape)
;; This is clever about appending to previous requests. Should it be?
(declare (type drawable drawable)
(type gcontext gcontext)
(type sequence points) ;(repeat-seq (integer x) (integer y))
(type generalized-boolean relative-p)
(type (member :complex :non-convex :convex) shape))
(with-buffer-request ((drawable-display drawable) +x-fillpoly+ :gc-force gcontext)
(drawable drawable)
(gcontext gcontext)
((member8 :complex :non-convex :convex) shape)
(boolean relative-p)
((sequence :format int16) points)))
(defun draw-segments (drawable gcontext segments)
(declare (type drawable drawable)
(type gcontext gcontext)
;; (repeat-seq (integer x1) (integer y1) (integer x2) (integer y2)))
(type sequence segments))
(with-buffer-request ((drawable-display drawable) +x-polysegment+ :gc-force gcontext)
(drawable drawable)
(gcontext gcontext)
((sequence :format int16) segments)))
(defun draw-rectangle (drawable gcontext x y width height &optional fill-p)
;; Should be clever about appending to existing buffered protocol request.
(declare (type drawable drawable)
(type gcontext gcontext)
(type int16 x y)
(type card16 width height)
(type generalized-boolean fill-p))
(let ((display (drawable-display drawable))
(request (if fill-p +x-polyfillrectangle+ +x-polyrectangle+)))
(declare (type display display)
(type card16 request))
(with-display (display)
(force-gcontext-changes-internal gcontext)
(with-buffer-output (display :length +requestsize+)
(let* ((last-request-byte (display-last-request display))
(current-boffset buffer-boffset))
;; To append or not append, that is the question
(if (and (not *inhibit-appending*)
last-request-byte
;; Same request?
(= (aref-card8 buffer-bbuf last-request-byte) request)
(progn ;; Set buffer pointers to last request
(set-buffer-offset last-request-byte)
;; same drawable and gcontext?
(or (compare-request (4)
(drawable drawable)
(gcontext gcontext))
(progn ;; If failed, reset buffer pointers
(set-buffer-offset current-boffset)
nil))))
;; Append request
(progn
;; Set new request length
(card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte)
-2)))
(set-buffer-offset current-boffset)
(put-items (0) ; Insert new point
(int16 x y)
(card16 width height))
(setf (display-boffset display) (index+ buffer-boffset 8)))
;; New Request
(progn
(put-items (4)
(code request)
(length 5)
(drawable drawable)
(gcontext gcontext)
(int16 x y)
(card16 width height))
(buffer-new-request-number display)
(setf (buffer-last-request display) buffer-boffset)
(setf (display-boffset display) (index+ buffer-boffset 20)))))))
(display-invoke-after-function display)))
(defun draw-rectangles (drawable gcontext rectangles &optional fill-p)
(declare (type drawable drawable)
(type gcontext gcontext)
;; (repeat-seq (integer x) (integer y) (integer width) (integer height)))
(type sequence rectangles)
(type generalized-boolean fill-p))
(with-buffer-request ((drawable-display drawable)
(if fill-p +x-polyfillrectangle+ +x-polyrectangle+)
:gc-force gcontext)
(drawable drawable)
(gcontext gcontext)
((sequence :format int16) rectangles)))
(defun draw-arc (drawable gcontext x y width height angle1 angle2 &optional fill-p)
;; Should be clever about appending to existing buffered protocol request.
(declare (type drawable drawable)
(type gcontext gcontext)
(type int16 x y)
(type card16 width height)
(type angle angle1 angle2)
(type generalized-boolean fill-p))
(let ((display (drawable-display drawable))
(request (if fill-p +x-polyfillarc+ +x-polyarc+)))
(declare (type display display)
(type card16 request))
(with-display (display)
(force-gcontext-changes-internal gcontext)
(with-buffer-output (display :length +requestsize+)
(let* ((last-request-byte (display-last-request display))
(current-boffset buffer-boffset))
;; To append or not append, that is the question
(if (and (not *inhibit-appending*)
last-request-byte
;; Same request?
(= (aref-card8 buffer-bbuf last-request-byte) request)
(progn ;; Set buffer pointers to last request
(set-buffer-offset last-request-byte)
;; same drawable and gcontext?
(or (compare-request (4)
(drawable drawable)
(gcontext gcontext))
(progn ;; If failed, reset buffer pointers
(set-buffer-offset current-boffset)
nil))))
;; Append request
(progn
;; Set new request length
(card16-put 2 (index+ 3 (index-ash (index- current-boffset last-request-byte)
-2)))
(set-buffer-offset current-boffset)
(put-items (0) ; Insert new point
(int16 x y)
(card16 width height)
(angle angle1 angle2))
(setf (display-boffset display) (index+ buffer-boffset 12)))
;; New Request
(progn
(put-items (4)
(code request)
(length 6)
(drawable drawable)
(gcontext gcontext)
(int16 x y)
(card16 width height)
(angle angle1 angle2))
(buffer-new-request-number display)
(setf (buffer-last-request display) buffer-boffset)
(setf (display-boffset display) (index+ buffer-boffset 24)))))))
(display-invoke-after-function display)))
(defun draw-arcs-list (drawable gcontext arcs &optional fill-p)
(declare (type drawable drawable)
(type gcontext gcontext)
(type list arcs)
(type generalized-boolean fill-p))
(let* ((display (drawable-display drawable))
(limit (index- (buffer-size display) 12))
(length (length arcs))
(request (if fill-p +x-polyfillarc+ +x-polyarc+)))
(with-buffer-request ((drawable-display drawable) request :gc-force gcontext)
(drawable drawable)
(gcontext gcontext)
(progn
(card16-put 2 (index+ (index-ash length -1) 3)) ; Set request length (in words)
(set-buffer-offset (index+ buffer-boffset 12)) ; Position to start of data
(do ((arc arcs))
((endp arc)
(setf (buffer-boffset display) buffer-boffset))
;; Make sure there's room
(when (index>= buffer-boffset limit)
(setf (buffer-boffset display) buffer-boffset)
(buffer-flush display)
(set-buffer-offset (buffer-boffset display)))
(int16-put 0 (pop arc))
(int16-put 2 (pop arc))
(card16-put 4 (pop arc))
(card16-put 6 (pop arc))
(angle-put 8 (pop arc))
(angle-put 10 (pop arc))
(set-buffer-offset (index+ buffer-boffset 12)))))))
(defun draw-arcs-vector (drawable gcontext arcs &optional fill-p)
(declare (type drawable drawable)
(type gcontext gcontext)
(type vector arcs)
(type generalized-boolean fill-p))
(let* ((display (drawable-display drawable))
(limit (index- (buffer-size display) 12))
(length (length arcs))
(request (if fill-p +x-polyfillarc+ +x-polyarc+)))
(with-buffer-request ((drawable-display drawable) request :gc-force gcontext)
(drawable drawable)
(gcontext gcontext)
(progn
(card16-put 2 (index+ (index-ash length -1) 3)) ; Set request length (in words)
(set-buffer-offset (index+ buffer-boffset 12)) ; Position to start of data
(do ((n 0 (index+ n 6))
(length (length arcs)))
((index>= n length)
(setf (buffer-boffset display) buffer-boffset))
;; Make sure there's room
(when (index>= buffer-boffset limit)
(setf (buffer-boffset display) buffer-boffset)
(buffer-flush display)
(set-buffer-offset (buffer-boffset display)))
(int16-put 0 (aref arcs (index+ n 0)))
(int16-put 2 (aref arcs (index+ n 1)))
(card16-put 4 (aref arcs (index+ n 2)))
(card16-put 6 (aref arcs (index+ n 3)))
(angle-put 8 (aref arcs (index+ n 4)))
(angle-put 10 (aref arcs (index+ n 5)))
(set-buffer-offset (index+ buffer-boffset 12)))))))
(defun draw-arcs (drawable gcontext arcs &optional fill-p)
(declare (type drawable drawable)
(type gcontext gcontext)
(type sequence arcs)
(type generalized-boolean fill-p))
(etypecase arcs
(list (draw-arcs-list drawable gcontext arcs fill-p))
(vector (draw-arcs-vector drawable gcontext arcs fill-p))))
;; The following image routines are bare minimum. It may be useful to define
;; some form of "image" object to hide representation details and format
;; conversions. It also may be useful to provide stream-oriented interfaces
;; for reading and writing the data.
(defun put-raw-image (drawable gcontext data &key
(start 0)
(depth (required-arg depth))
(x (required-arg x))
(y (required-arg y))
(width (required-arg width))
(height (required-arg height))
(left-pad 0)
(format (required-arg format)))
;; Data must be a sequence of 8-bit quantities, already in the appropriate format
;; for transmission; the caller is responsible for all byte and bit swapping and
;; compaction. Start is the starting index in data; the end is computed from the
;; other arguments.
(declare (type drawable drawable)
(type gcontext gcontext)
(type sequence data) ; Sequence of integers
(type array-index start)
(type card8 depth left-pad) ;; required
(type int16 x y) ;; required
(type card16 width height) ;; required
(type (member :bitmap :xy-pixmap :z-pixmap) format))
(with-buffer-request ((drawable-display drawable) +x-putimage+ :gc-force gcontext)
((data (member :bitmap :xy-pixmap :z-pixmap)) format)
(drawable drawable)
(gcontext gcontext)
(card16 width height)
(int16 x y)
(card8 left-pad depth)
(pad16 nil)
((sequence :format card8 :start start) data)))
(defun get-raw-image (drawable &key
data
(start 0)
(x (required-arg x))
(y (required-arg y))
(width (required-arg width))
(height (required-arg height))
(plane-mask #xffffffff)
(format (required-arg format))
(result-type '(vector card8)))
;; If data is given, it is modified in place (and returned), otherwise a new sequence
;; is created and returned, with a size computed from the other arguments and the
;; returned depth. The sequence is filled with 8-bit quantities, in transmission
;; format; the caller is responsible for any byte and bit swapping and compaction
;; required for further local use.
(declare (type drawable drawable)
(type (or null sequence) data) ;; sequence of integers
(type int16 x y) ;; required
(type card16 width height) ;; required
(type array-index start)
(type pixel plane-mask)
(type (member :xy-pixmap :z-pixmap) format))
(declare (clx-values (clx-sequence integer) depth visual-info))
(let ((display (drawable-display drawable)))
(with-buffer-request-and-reply (display +x-getimage+ nil :sizes (8 32))
(((data (member error :xy-pixmap :z-pixmap)) format)
(drawable drawable)
(int16 x y)
(card16 width height)
(card32 plane-mask))
(let ((depth (card8-get 1))
(length (* 4 (card32-get 4)))
(visual (resource-id-get 8)))
(values (sequence-get :result-type result-type :format card8
:length length :start start :data data
:index +replysize+)
depth
(visual-info display visual))))))

2673
src/eclx/image.lisp
View file

File diff suppressed because it is too large Load diff

1870
src/eclx/input.lisp
View file

File diff suppressed because it is too large Load diff

162
src/eclx/keysyms.lisp
View file

@ -1,162 +0,0 @@
;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES -*-
;;; Define lisp character to keysym mappings
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
#+cmu
(ext:file-comment
"$Header$")
(in-package :xlib)
(define-keysym-set :latin-1 (keysym 0 0) (keysym 0 255))
(define-keysym-set :latin-2 (keysym 1 0) (keysym 1 255))
(define-keysym-set :latin-3 (keysym 2 0) (keysym 2 255))
(define-keysym-set :latin-4 (keysym 3 0) (keysym 3 255))
(define-keysym-set :kana (keysym 4 0) (keysym 4 255))
(define-keysym-set :arabic (keysym 5 0) (keysym 5 255))
(define-keysym-set :cryllic (keysym 6 0) (keysym 6 255))
(define-keysym-set :greek (keysym 7 0) (keysym 7 255))
(define-keysym-set :tech (keysym 8 0) (keysym 8 255))
(define-keysym-set :special (keysym 9 0) (keysym 9 255))
(define-keysym-set :publish (keysym 10 0) (keysym 10 255))
(define-keysym-set :apl (keysym 11 0) (keysym 11 255))
(define-keysym-set :hebrew (keysym 12 0) (keysym 12 255))
(define-keysym-set :keyboard (keysym 255 0) (keysym 255 255))
(define-keysym :character-set-switch character-set-switch-keysym)
(define-keysym :left-shift left-shift-keysym)
(define-keysym :right-shift right-shift-keysym)
(define-keysym :left-control left-control-keysym)
(define-keysym :right-control right-control-keysym)
(define-keysym :caps-lock caps-lock-keysym)
(define-keysym :shift-lock shift-lock-keysym)
(define-keysym :left-meta left-meta-keysym)
(define-keysym :right-meta right-meta-keysym)
(define-keysym :left-alt left-alt-keysym)
(define-keysym :right-alt right-alt-keysym)
(define-keysym :left-super left-super-keysym)
(define-keysym :right-super right-super-keysym)
(define-keysym :left-hyper left-hyper-keysym)
(define-keysym :right-hyper right-hyper-keysym)
(define-keysym #\space 032)
(define-keysym #\! 033)
(define-keysym #\" 034)
(define-keysym #\# 035)
(define-keysym #\$ 036)
(define-keysym #\% 037)
(define-keysym #\& 038)
(define-keysym #\' 039)
(define-keysym #\( 040)
(define-keysym #\) 041)
(define-keysym #\* 042)
(define-keysym #\+ 043)
(define-keysym #\, 044)
(define-keysym #\- 045)
(define-keysym #\. 046)
(define-keysym #\/ 047)
(define-keysym #\0 048)
(define-keysym #\1 049)
(define-keysym #\2 050)
(define-keysym #\3 051)
(define-keysym #\4 052)
(define-keysym #\5 053)
(define-keysym #\6 054)
(define-keysym #\7 055)
(define-keysym #\8 056)
(define-keysym #\9 057)
(define-keysym #\: 058)
(define-keysym #\; 059)
(define-keysym #\< 060)
(define-keysym #\= 061)
(define-keysym #\> 062)
(define-keysym #\? 063)
(define-keysym #\@ 064)
(define-keysym #\A 065 :lowercase 097)
(define-keysym #\B 066 :lowercase 098)
(define-keysym #\C 067 :lowercase 099)
(define-keysym #\D 068 :lowercase 100)
(define-keysym #\E 069 :lowercase 101)
(define-keysym #\F 070 :lowercase 102)
(define-keysym #\G 071 :lowercase 103)
(define-keysym #\H 072 :lowercase 104)
(define-keysym #\I 073 :lowercase 105)
(define-keysym #\J 074 :lowercase 106)
(define-keysym #\K 075 :lowercase 107)
(define-keysym #\L 076 :lowercase 108)
(define-keysym #\M 077 :lowercase 109)
(define-keysym #\N 078 :lowercase 110)
(define-keysym #\O 079 :lowercase 111)
(define-keysym #\P 080 :lowercase 112)
(define-keysym #\Q 081 :lowercase 113)
(define-keysym #\R 082 :lowercase 114)
(define-keysym #\S 083 :lowercase 115)
(define-keysym #\T 084 :lowercase 116)
(define-keysym #\U 085 :lowercase 117)
(define-keysym #\V 086 :lowercase 118)
(define-keysym #\W 087 :lowercase 119)
(define-keysym #\X 088 :lowercase 120)
(define-keysym #\Y 089 :lowercase 121)
(define-keysym #\Z 090 :lowercase 122)
(define-keysym #\[ 091)
(define-keysym #\\ 092)
(define-keysym #\] 093)
(define-keysym #\^ 094)
(define-keysym #\_ 095)
(define-keysym #\` 096)
(define-keysym #\a 097)
(define-keysym #\b 098)
(define-keysym #\c 099)
(define-keysym #\d 100)
(define-keysym #\e 101)
(define-keysym #\f 102)
(define-keysym #\g 103)
(define-keysym #\h 104)
(define-keysym #\i 105)
(define-keysym #\j 106)
(define-keysym #\k 107)
(define-keysym #\l 108)
(define-keysym #\m 109)
(define-keysym #\n 110)
(define-keysym #\o 111)
(define-keysym #\p 112)
(define-keysym #\q 113)
(define-keysym #\r 114)
(define-keysym #\s 115)
(define-keysym #\t 116)
(define-keysym #\u 117)
(define-keysym #\v 118)
(define-keysym #\w 119)
(define-keysym #\x 120)
(define-keysym #\y 121)
(define-keysym #\z 122)
(define-keysym #\{ 123)
(define-keysym #\| 124)
(define-keysym #\} 125)
(define-keysym #\~ 126)
(progn ;; Semi-standard characters
(define-keysym #\rubout (keysym 255 255)) ; :tty
(define-keysym #\tab (keysym 255 009)) ; :tty
(define-keysym #\linefeed (keysym 255 010)) ; :tty
(define-keysym #\page (keysym 009 227)) ; :special
(define-keysym #\return (keysym 255 013)) ; :tty
(define-keysym #\backspace (keysym 255 008)) ; :tty
)

24
src/eclx/load.lsp.in
View file

@ -1,24 +0,0 @@
(defconstant +eclx-module-files+
'("src:eclx;split-sequence.lisp"
"src:eclx;package.lisp"
"src:eclx;depdefs.lisp"
"src:eclx;clx.lisp"
"src:eclx;dependent.lisp"
"src:eclx;macros.lisp" ; these are just macros
"src:eclx;bufmac.lisp" ; these are just macros
"src:eclx;buffer.lisp"
"src:eclx;display.lisp"
"src:eclx;gcontext.lisp"
"src:eclx;input.lisp"
"src:eclx;requests.lisp"
"src:eclx;fonts.lisp"
"src:eclx;graphics.lisp"
"src:eclx;text.lisp"
"src:eclx;attributes.lisp"
"src:eclx;translate.lisp"
"src:eclx;keysyms.lisp"
"src:eclx;manager.lisp"
"src:eclx;image.lisp"
"src:eclx;resource.lisp"))
(mapc #'(lambda (x) (load x :verbose nil)) +eclx-module-files+)

1086
src/eclx/macros.lisp
View file

File diff suppressed because it is too large Load diff

763
src/eclx/manager.lisp
View file

@ -1,763 +0,0 @@
;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
;;; Window Manager Property functions
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
#+cmu
(ext:file-comment
"$Header$")
(in-package :xlib)
(defun wm-name (window)
(declare (type window window))
(declare (clx-values string))
(get-property window :WM_NAME :type :STRING :result-type 'string :transform #'card8->char))
(defsetf wm-name (window) (name)
`(set-string-property ,window :WM_NAME ,name))
(defun set-string-property (window property string)
(declare (type window window)
(type keyword property)
(type stringable string))
(change-property window property (string string) :STRING 8 :transform #'char->card8)
string)
(defun wm-icon-name (window)
(declare (type window window))
(declare (clx-values string))
(get-property window :WM_ICON_NAME :type :STRING
:result-type 'string :transform #'card8->char))
(defsetf wm-icon-name (window) (name)
`(set-string-property ,window :WM_ICON_NAME ,name))
(defun wm-client-machine (window)
(declare (type window window))
(declare (clx-values string))
(get-property window :WM_CLIENT_MACHINE :type :STRING
:result-type 'string :transform #'card8->char))
(defsetf wm-client-machine (window) (name)
`(set-string-property ,window :WM_CLIENT_MACHINE ,name))
(defun get-wm-class (window)
(declare (type window window))
(declare (clx-values (or null name-string) (or null class-string)))
(let ((value (get-property window :WM_CLASS :type :STRING :result-type '(vector card8))))
(declare (type (or null (vector card8)) value))
(when value
(let* ((name-len (position 0 (the (vector card8) value)))
(name (subseq (the (vector card8) value) 0 name-len))
(class (subseq (the (vector card8) value) (1+ name-len) (1- (length value)))))
(values (and (plusp (length name)) (map 'string #'card8->char name))
(and (plusp (length class)) (map 'string #'card8->char class)))))))
(defun set-wm-class (window resource-name resource-class)
(declare (type window window)
(type (or null stringable) resource-name resource-class))
(change-property window :WM_CLASS
(concatenate '(vector card8)
(map '(vector card8) #'char->card8
(string (or resource-name "")))
#(0)
(map '(vector card8) #'char->card8
(string (or resource-class "")))
#(0))
:string 8)
(values))
(defun wm-command (window)
;; Returns a list whose car is the command and
;; whose cdr is the list of arguments
(declare (type window window))
(declare (clx-values list))
(do* ((command-string (get-property window :WM_COMMAND :type :STRING
:result-type '(vector card8)))
(command nil)
(start 0 (1+ end))
(end 0)
(len (length command-string)))
((>= start len) (nreverse command))
(setq end (position 0 command-string :start start))
(push (map 'string #'card8->char (subseq command-string start end))
command)))
(defsetf wm-command set-wm-command)
(defun set-wm-command (window command)
;; Uses PRIN1 inside the ANSI common lisp form WITH-STANDARD-IO-SYNTAX (or
;; equivalent), with elements of command separated by NULL characters. This
;; enables
;; (with-standard-io-syntax (mapcar #'read-from-string (wm-command window)))
;; to recover a lisp command.
(declare (type window window)
(type list command))
(change-property window :WM_COMMAND
(apply #'concatenate '(vector card8)
(mapcan #'(lambda (c)
(list (map '(vector card8) #'char->card8
(with-output-to-string (stream)
(with-standard-io-syntax
(prin1 c stream))))
#(0)))
command))
:string 8)
command)
;;-----------------------------------------------------------------------------
;; WM_HINTS
(def-clx-class (wm-hints)
(input nil :type (or null (member :off :on)))
(initial-state nil :type (or null (member :dont-care :normal :zoom :iconic :inactive)))
(icon-pixmap nil :type (or null pixmap))
(icon-window nil :type (or null window))
(icon-x nil :type (or null card16))
(icon-y nil :type (or null card16))
(icon-mask nil :type (or null pixmap))
(window-group nil :type (or null resource-id))
(flags 0 :type card32) ;; Extension-hook. Exclusive-Or'ed with the FLAGS field
;; may be extended in the future
)
(defun wm-hints (window)
(declare (type window window))
(declare (clx-values wm-hints))
(let ((prop (get-property window :WM_HINTS :type :WM_HINTS :result-type 'vector)))
(when prop
(decode-wm-hints prop (window-display window)))))
(defsetf wm-hints set-wm-hints)
(defun set-wm-hints (window wm-hints)
(declare (type window window)
(type wm-hints wm-hints))
(declare (clx-values wm-hints))
(change-property window :WM_HINTS (encode-wm-hints wm-hints) :WM_HINTS 32)
wm-hints)
(defun decode-wm-hints (vector display)
(declare (type (simple-vector 9) vector)
(type display display))
(declare (clx-values wm-hints))
(let ((input-hint 0)
(state-hint 1)
(icon-pixmap-hint 2)
(icon-window-hint 3)
(icon-position-hint 4)
(icon-mask-hint 5)
(window-group-hint 6))
(let ((flags (aref vector 0))
(hints (make-wm-hints))
(%buffer display))
(declare (type card32 flags)
(type wm-hints hints)
(type display %buffer))
(setf (wm-hints-flags hints) flags)
(when (logbitp input-hint flags)
(setf (wm-hints-input hints) (decode-type (member :off :on) (aref vector 1))))
(when (logbitp state-hint flags)
(setf (wm-hints-initial-state hints)
(decode-type (member :dont-care :normal :zoom :iconic :inactive)
(aref vector 2))))
(when (logbitp icon-pixmap-hint flags)
(setf (wm-hints-icon-pixmap hints) (decode-type pixmap (aref vector 3))))
(when (logbitp icon-window-hint flags)
(setf (wm-hints-icon-window hints) (decode-type window (aref vector 4))))
(when (logbitp icon-position-hint flags)
(setf (wm-hints-icon-x hints) (aref vector 5)
(wm-hints-icon-y hints) (aref vector 6)))
(when (logbitp icon-mask-hint flags)
(setf (wm-hints-icon-mask hints) (decode-type pixmap (aref vector 7))))
(when (and (logbitp window-group-hint flags) (> (length vector) 7))
(setf (wm-hints-window-group hints) (aref vector 8)))
hints)))
(defun encode-wm-hints (wm-hints)
(declare (type wm-hints wm-hints))
(declare (clx-values simple-vector))
(let ((input-hint #b1)
(state-hint #b10)
(icon-pixmap-hint #b100)
(icon-window-hint #b1000)
(icon-position-hint #b10000)
(icon-mask-hint #b100000)
(window-group-hint #b1000000)
(mask #b1111111)
)
(let ((vector (make-array 9 :initial-element 0))
(flags 0))
(declare (type (simple-vector 9) vector)
(type card16 flags))
(when (wm-hints-input wm-hints)
(setf flags input-hint
(aref vector 1) (encode-type (member :off :on) (wm-hints-input wm-hints))))
(when (wm-hints-initial-state wm-hints)
(setf flags (logior flags state-hint)
(aref vector 2) (encode-type (member :dont-care :normal :zoom :iconic :inactive)
(wm-hints-initial-state wm-hints))))
(when (wm-hints-icon-pixmap wm-hints)
(setf flags (logior flags icon-pixmap-hint)
(aref vector 3) (encode-type pixmap (wm-hints-icon-pixmap wm-hints))))
(when (wm-hints-icon-window wm-hints)
(setf flags (logior flags icon-window-hint)
(aref vector 4) (encode-type window (wm-hints-icon-window wm-hints))))
(when (and (wm-hints-icon-x wm-hints) (wm-hints-icon-y wm-hints))
(setf flags (logior flags icon-position-hint)
(aref vector 5) (encode-type card16 (wm-hints-icon-x wm-hints))
(aref vector 6) (encode-type card16 (wm-hints-icon-y wm-hints))))
(when (wm-hints-icon-mask wm-hints)
(setf flags (logior flags icon-mask-hint)
(aref vector 7) (encode-type pixmap (wm-hints-icon-mask wm-hints))))
(when (wm-hints-window-group wm-hints)
(setf flags (logior flags window-group-hint)
(aref vector 8) (wm-hints-window-group wm-hints)))
(setf (aref vector 0) (logior flags (logandc2 (wm-hints-flags wm-hints) mask)))
vector)))
;;-----------------------------------------------------------------------------
;; WM_SIZE_HINTS
(def-clx-class (wm-size-hints)
(user-specified-position-p nil :type generalized-boolean) ;; True when user specified x y
(user-specified-size-p nil :type generalized-boolean) ;; True when user specified width height
(x nil :type (or null int16)) ;; Obsolete
(y nil :type (or null int16)) ;; Obsolete
(width nil :type (or null card16)) ;; Obsolete
(height nil :type (or null card16)) ;; Obsolete
(min-width nil :type (or null card16))
(min-height nil :type (or null card16))
(max-width nil :type (or null card16))
(max-height nil :type (or null card16))
(width-inc nil :type (or null card16))
(height-inc nil :type (or null card16))
(min-aspect nil :type (or null number))
(max-aspect nil :type (or null number))
(base-width nil :type (or null card16))
(base-height nil :type (or null card16))
(win-gravity nil :type (or null win-gravity))
(program-specified-position-p nil :type generalized-boolean) ;; True when program specified x y
(program-specified-size-p nil :type generalized-boolean) ;; True when program specified width height
)
(defun wm-normal-hints (window)
(declare (type window window))
(declare (clx-values wm-size-hints))
(decode-wm-size-hints (get-property window :WM_NORMAL_HINTS :type :WM_SIZE_HINTS :result-type 'vector)))
(defsetf wm-normal-hints set-wm-normal-hints)
(defun set-wm-normal-hints (window hints)
(declare (type window window)
(type wm-size-hints hints))
(declare (clx-values wm-size-hints))
(change-property window :WM_NORMAL_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32)
hints)
;;; OBSOLETE
(defun wm-zoom-hints (window)
(declare (type window window))
(declare (clx-values wm-size-hints))
(decode-wm-size-hints (get-property window :WM_ZOOM_HINTS :type :WM_SIZE_HINTS :result-type 'vector)))
;;; OBSOLETE
(defsetf wm-zoom-hints set-wm-zoom-hints)
;;; OBSOLETE
(defun set-wm-zoom-hints (window hints)
(declare (type window window)
(type wm-size-hints hints))
(declare (clx-values wm-size-hints))
(change-property window :WM_ZOOM_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32)
hints)
(defun decode-wm-size-hints (vector)
(declare (type (or null (simple-vector *)) vector))
(declare (clx-values (or null wm-size-hints)))
(when vector
(let ((flags (aref vector 0))
(hints (make-wm-size-hints)))
(declare (type card16 flags)
(type wm-size-hints hints))
(setf (wm-size-hints-user-specified-position-p hints) (logbitp 0 flags))
(setf (wm-size-hints-user-specified-size-p hints) (logbitp 1 flags))
(setf (wm-size-hints-program-specified-position-p hints) (logbitp 2 flags))
(setf (wm-size-hints-program-specified-size-p hints) (logbitp 3 flags))
(when (logbitp 4 flags)
(setf (wm-size-hints-min-width hints) (aref vector 5)
(wm-size-hints-min-height hints) (aref vector 6)))
(when (logbitp 5 flags)
(setf (wm-size-hints-max-width hints) (aref vector 7)
(wm-size-hints-max-height hints) (aref vector 8)))
(when (logbitp 6 flags)
(setf (wm-size-hints-width-inc hints) (aref vector 9)
(wm-size-hints-height-inc hints) (aref vector 10)))
(when (logbitp 7 flags)
(setf (wm-size-hints-min-aspect hints) (/ (aref vector 11) (aref vector 12))
(wm-size-hints-max-aspect hints) (/ (aref vector 13) (aref vector 14))))
(when (> (length vector) 15)
;; This test is for backwards compatibility since old Xlib programs
;; can set a size-hints structure that is too small. See ICCCM.
(when (logbitp 8 flags)
(setf (wm-size-hints-base-width hints) (aref vector 15)
(wm-size-hints-base-height hints) (aref vector 16)))
(when (logbitp 9 flags)
(setf (wm-size-hints-win-gravity hints)
(decode-type (member-vector *win-gravity-vector*) (aref vector 17)))))
;; Obsolete fields
(when (or (logbitp 0 flags) (logbitp 2 flags))
(setf (wm-size-hints-x hints) (card32->int32 (aref vector 1))
(wm-size-hints-y hints) (card32->int32 (aref vector 2))))
(when (or (logbitp 1 flags) (logbitp 3 flags))
(setf (wm-size-hints-width hints) (aref vector 3)
(wm-size-hints-height hints) (aref vector 4)))
hints)))
(defun encode-wm-size-hints (hints)
(declare (type wm-size-hints hints))
(declare (clx-values simple-vector))
(let ((vector (make-array 18 :initial-element 0))
(flags 0))
(declare (type (simple-vector 18) vector)
(type card16 flags))
(when (wm-size-hints-user-specified-position-p hints)
(setf (ldb (byte 1 0) flags) 1))
(when (wm-size-hints-user-specified-size-p hints)
(setf (ldb (byte 1 1) flags) 1))
(when (wm-size-hints-program-specified-position-p hints)
(setf (ldb (byte 1 2) flags) 1))
(when (wm-size-hints-program-specified-size-p hints)
(setf (ldb (byte 1 3) flags) 1))
(when (and (wm-size-hints-min-width hints) (wm-size-hints-min-height hints))
(setf (ldb (byte 1 4) flags) 1
(aref vector 5) (wm-size-hints-min-width hints)
(aref vector 6) (wm-size-hints-min-height hints)))
(when (and (wm-size-hints-max-width hints) (wm-size-hints-max-height hints))
(setf (ldb (byte 1 5) flags) 1
(aref vector 7) (wm-size-hints-max-width hints)
(aref vector 8) (wm-size-hints-max-height hints)))
(when (and (wm-size-hints-width-inc hints) (wm-size-hints-height-inc hints))
(setf (ldb (byte 1 6) flags) 1
(aref vector 9) (wm-size-hints-width-inc hints)
(aref vector 10) (wm-size-hints-height-inc hints)))
(let ((min-aspect (wm-size-hints-min-aspect hints))
(max-aspect (wm-size-hints-max-aspect hints)))
(when (and min-aspect max-aspect)
(setf (ldb (byte 1 7) flags) 1
min-aspect (rationalize min-aspect)
max-aspect (rationalize max-aspect)
(aref vector 11) (numerator min-aspect)
(aref vector 12) (denominator min-aspect)
(aref vector 13) (numerator max-aspect)
(aref vector 14) (denominator max-aspect))))
(when (and (wm-size-hints-base-width hints)
(wm-size-hints-base-height hints))
(setf (ldb (byte 1 8) flags) 1
(aref vector 15) (wm-size-hints-base-width hints)
(aref vector 16) (wm-size-hints-base-height hints)))
(when (wm-size-hints-win-gravity hints)
(setf (ldb (byte 1 9) flags) 1
(aref vector 17) (encode-type
(member-vector *win-gravity-vector*)
(wm-size-hints-win-gravity hints))))
;; Obsolete fields
(when (and (wm-size-hints-x hints) (wm-size-hints-y hints))
(unless (wm-size-hints-user-specified-position-p hints)
(setf (ldb (byte 1 2) flags) 1))
(setf (aref vector 1) (wm-size-hints-x hints)
(aref vector 2) (wm-size-hints-y hints)))
(when (and (wm-size-hints-width hints) (wm-size-hints-height hints))
(unless (wm-size-hints-user-specified-size-p hints)
(setf (ldb (byte 1 3) flags) 1))
(setf (aref vector 3) (wm-size-hints-width hints)
(aref vector 4) (wm-size-hints-height hints)))
(setf (aref vector 0) flags)
vector))
;;-----------------------------------------------------------------------------
;; Icon_Size
;; Use the same intermediate structure as WM_SIZE_HINTS
(defun icon-sizes (window)
(declare (type window window))
(declare (clx-values wm-size-hints))
(let ((vector (get-property window :WM_ICON_SIZE :type :WM_ICON_SIZE :result-type 'vector)))
(declare (type (or null (simple-vector 6)) vector))
(when vector
(make-wm-size-hints
:min-width (aref vector 0)
:min-height (aref vector 1)
:max-width (aref vector 2)
:max-height (aref vector 3)
:width-inc (aref vector 4)
:height-inc (aref vector 5)))))
(defsetf icon-sizes set-icon-sizes)
(defun set-icon-sizes (window wm-size-hints)
(declare (type window window)
(type wm-size-hints wm-size-hints))
(let ((vector (vector (wm-size-hints-min-width wm-size-hints)
(wm-size-hints-min-height wm-size-hints)
(wm-size-hints-max-width wm-size-hints)
(wm-size-hints-max-height wm-size-hints)
(wm-size-hints-width-inc wm-size-hints)
(wm-size-hints-height-inc wm-size-hints))))
(change-property window :WM_ICON_SIZE vector :WM_ICON_SIZE 32)
wm-size-hints))
;;-----------------------------------------------------------------------------
;; WM-Protocols
(defun wm-protocols (window)
(map 'list #'(lambda (id) (atom-name (window-display window) id))
(get-property window :WM_PROTOCOLS :type :ATOM)))
(defsetf wm-protocols set-wm-protocols)
(defun set-wm-protocols (window protocols)
(change-property window :WM_PROTOCOLS
(map 'list #'(lambda (atom) (intern-atom (window-display window) atom))
protocols)
:ATOM 32)
protocols)
;;-----------------------------------------------------------------------------
;; WM-Colormap-windows
(defun wm-colormap-windows (window)
(values (get-property window :WM_COLORMAP_WINDOWS :type :WINDOW
:transform #'(lambda (id)
(lookup-window (window-display window) id)))))
(defsetf wm-colormap-windows set-wm-colormap-windows)
(defun set-wm-colormap-windows (window colormap-windows)
(change-property window :WM_COLORMAP_WINDOWS colormap-windows :WINDOW 32
:transform #'window-id)
colormap-windows)
;;-----------------------------------------------------------------------------
;; Transient-For
(defun transient-for (window)
(let ((prop (get-property window :WM_TRANSIENT_FOR :type :WINDOW :result-type 'list)))
(and prop (lookup-window (window-display window) (car prop)))))
(defsetf transient-for set-transient-for)
(defun set-transient-for (window transient)
(declare (type window window transient))
(change-property window :WM_TRANSIENT_FOR (list (window-id transient)) :WINDOW 32)
transient)
;;-----------------------------------------------------------------------------
;; Set-WM-Properties
(defun set-wm-properties (window &rest options &key
name icon-name resource-name resource-class command
client-machine hints normal-hints zoom-hints
;; the following are used for wm-normal-hints
(user-specified-position-p nil usppp)
(user-specified-size-p nil usspp)
(program-specified-position-p nil psppp)
(program-specified-size-p nil psspp)
x y width height min-width min-height max-width max-height
width-inc height-inc min-aspect max-aspect
base-width base-height win-gravity
;; the following are used for wm-hints
input initial-state icon-pixmap icon-window
icon-x icon-y icon-mask window-group)
;; Set properties for WINDOW.
(declare (arglist window &rest options &key
name icon-name resource-name resource-class command
client-machine hints normal-hints
;; the following are used for wm-normal-hints
user-specified-position-p user-specified-size-p
program-specified-position-p program-specified-size-p
min-width min-height max-width max-height
width-inc height-inc min-aspect max-aspect
base-width base-height win-gravity
;; the following are used for wm-hints
input initial-state icon-pixmap icon-window
icon-x icon-y icon-mask window-group))
(declare (type window window)
(type (or null stringable) name icon-name resource-name resource-class client-machine)
(type (or null list) command)
(type (or null wm-hints) hints)
(type (or null wm-size-hints) normal-hints zoom-hints)
(type generalized-boolean user-specified-position-p user-specified-size-p)
(type generalized-boolean program-specified-position-p program-specified-size-p)
(type (or null int16) x y)
(type (or null card16) width height min-width min-height max-width max-height width-inc height-inc base-width base-height)
(type (or null win-gravity) win-gravity)
(type (or null number) min-aspect max-aspect)
(type (or null (member :off :on)) input)
(type (or null (member :dont-care :normal :zoom :iconic :inactive)) initial-state)
(type (or null pixmap) icon-pixmap icon-mask)
(type (or null window) icon-window)
(type (or null card16) icon-x icon-y)
(type (or null resource-id) window-group)
(dynamic-extent options))
(when name (setf (wm-name window) name))
(when icon-name (setf (wm-icon-name window) icon-name))
(when client-machine (setf (wm-client-machine window) client-machine))
(when (or resource-name resource-class)
(set-wm-class window resource-name resource-class))
(when command (setf (wm-command window) command))
;; WM-HINTS
(if (dolist (arg '(:input :initial-state :icon-pixmap :icon-window
:icon-x :icon-y :icon-mask :window-group))
(when (getf options arg) (return t)))
(let ((wm-hints (if hints (copy-wm-hints hints) (make-wm-hints))))
(when input (setf (wm-hints-input wm-hints) input))
(when initial-state (setf (wm-hints-initial-state wm-hints) initial-state))
(when icon-pixmap (setf (wm-hints-icon-pixmap wm-hints) icon-pixmap))
(when icon-window (setf (wm-hints-icon-window wm-hints) icon-window))
(when icon-x (setf (wm-hints-icon-x wm-hints) icon-x))
(when icon-y (setf (wm-hints-icon-y wm-hints) icon-y))
(when icon-mask (setf (wm-hints-icon-mask wm-hints) icon-mask))
(when window-group (setf (wm-hints-window-group wm-hints) window-group))
(setf (wm-hints window) wm-hints))
(when hints (setf (wm-hints window) hints)))
;; WM-NORMAL-HINTS
(if (dolist (arg '(:x :y :width :height :min-width :min-height :max-width :max-height
:width-inc :height-inc :min-aspect :max-aspect
:user-specified-position-p :user-specified-size-p
:program-specified-position-p :program-specified-size-p
:base-width :base-height :win-gravity))
(when (getf options arg) (return t)))
(let ((size (if normal-hints (copy-wm-size-hints normal-hints) (make-wm-size-hints))))
(when x (setf (wm-size-hints-x size) x))
(when y (setf (wm-size-hints-y size) y))
(when width (setf (wm-size-hints-width size) width))
(when height (setf (wm-size-hints-height size) height))
(when min-width (setf (wm-size-hints-min-width size) min-width))
(when min-height (setf (wm-size-hints-min-height size) min-height))
(when max-width (setf (wm-size-hints-max-width size) max-width))
(when max-height (setf (wm-size-hints-max-height size) max-height))
(when width-inc (setf (wm-size-hints-width-inc size) width-inc))
(when height-inc (setf (wm-size-hints-height-inc size) height-inc))
(when min-aspect (setf (wm-size-hints-min-aspect size) min-aspect))
(when max-aspect (setf (wm-size-hints-max-aspect size) max-aspect))
(when base-width (setf (wm-size-hints-base-width size) base-width))
(when base-height (setf (wm-size-hints-base-height size) base-height))
(when win-gravity (setf (wm-size-hints-win-gravity size) win-gravity))
(when usppp
(setf (wm-size-hints-user-specified-position-p size) user-specified-position-p))
(when usspp
(setf (wm-size-hints-user-specified-size-p size) user-specified-size-p))
(when psppp
(setf (wm-size-hints-program-specified-position-p size) program-specified-position-p))
(when psspp
(setf (wm-size-hints-program-specified-size-p size) program-specified-size-p))
(setf (wm-normal-hints window) size))
(when normal-hints (setf (wm-normal-hints window) normal-hints)))
(when zoom-hints (setf (wm-zoom-hints window) zoom-hints))
)
;;; OBSOLETE
(defun set-standard-properties (window &rest options)
(declare (dynamic-extent options))
(apply #'set-wm-properties window options))
;;-----------------------------------------------------------------------------
;; WM Control
(defun iconify-window (window screen)
(declare (type window window)
(type screen screen))
(let ((root (screen-root screen)))
(declare (type window root))
(send-event root :client-message '(:substructure-redirect :substructure-notify)
:window window :format 32 :type :WM_CHANGE_STATE :data (list 3))))
(defun withdraw-window (window screen)
(declare (type window window)
(type screen screen))
(unmap-window window)
(let ((root (screen-root screen)))
(declare (type window root))
(send-event root :unmap-notify '(:substructure-redirect :substructure-notify)
:window window :event-window root :configure-p nil)))
;;-----------------------------------------------------------------------------
;; Colormaps
(def-clx-class (standard-colormap (:copier nil) (:predicate nil))
(colormap nil :type (or null colormap))
(base-pixel 0 :type pixel)
(max-color nil :type (or null color))
(mult-color nil :type (or null color))
(visual nil :type (or null visual-info))
(kill nil :type (or (member nil :release-by-freeing-colormap)
drawable gcontext cursor colormap font)))
(defun rgb-colormaps (window property)
(declare (type window window)
(type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
:RGB_GREEN_MAP :RGB_BLUE_MAP) property))
(let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector)))
(declare (type (or null simple-vector) prop))
(when prop
(list (make-standard-colormap
:colormap (lookup-colormap (window-display window) (aref prop 0))
:base-pixel (aref prop 7)
:max-color (make-color :red (card16->rgb-val (aref prop 1))
:green (card16->rgb-val (aref prop 3))
:blue (card16->rgb-val (aref prop 5)))
:mult-color (make-color :red (card16->rgb-val (aref prop 2))
:green (card16->rgb-val (aref prop 4))
:blue (card16->rgb-val (aref prop 6)))
:visual (and (<= 9 (length prop))
(visual-info (window-display window) (aref prop 8)))
:kill (and (<= 10 (length prop))
(let ((killid (aref prop 9)))
(if (= killid 1)
:release-by-freeing-colormap
(lookup-resource-id (window-display window) killid)))))))))
(defsetf rgb-colormaps set-rgb-colormaps)
(defun set-rgb-colormaps (window property maps)
(declare (type window window)
(type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
:RGB_GREEN_MAP :RGB_BLUE_MAP) property)
(type list maps))
(let ((prop (make-array (* 10 (length maps)) :element-type 'card32))
(index -1))
(dolist (map maps)
(setf (aref prop (incf index))
(encode-type colormap (standard-colormap-colormap map)))
(setf (aref prop (incf index))
(encode-type rgb-val (color-red (standard-colormap-max-color map))))
(setf (aref prop (incf index))
(encode-type rgb-val (color-red (standard-colormap-mult-color map))))
(setf (aref prop (incf index))
(encode-type rgb-val (color-green (standard-colormap-max-color map))))
(setf (aref prop (incf index))
(encode-type rgb-val (color-green (standard-colormap-mult-color map))))
(setf (aref prop (incf index))
(encode-type rgb-val (color-blue (standard-colormap-max-color map))))
(setf (aref prop (incf index))
(encode-type rgb-val (color-blue (standard-colormap-mult-color map))))
(setf (aref prop (incf index))
(standard-colormap-base-pixel map))
(setf (aref prop (incf index))
(visual-info-id (standard-colormap-visual map)))
(setf (aref prop (incf index))
(let ((kill (standard-colormap-kill map)))
(etypecase kill
(symbol
(ecase kill
((nil) 0)
((:release-by-freeing-colormap) 1)))
(drawable (drawable-id kill))
(gcontext (gcontext-id kill))
(cursor (cursor-id kill))
(colormap (colormap-id kill))
(font (font-id kill))))))
(change-property window property prop :RGB_COLOR_MAP 32)))
;;; OBSOLETE
(defun get-standard-colormap (window property)
(declare (type window window)
(type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
:RGB_GREEN_MAP :RGB_BLUE_MAP) property))
(declare (clx-values colormap base-pixel max-color mult-color))
(let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector)))
(declare (type (or null simple-vector) prop))
(when prop
(values (lookup-colormap (window-display window) (aref prop 0))
(aref prop 7) ;Base Pixel
(make-color :red (card16->rgb-val (aref prop 1)) ;Max Color
:green (card16->rgb-val (aref prop 3))
:blue (card16->rgb-val (aref prop 5)))
(make-color :red (card16->rgb-val (aref prop 2)) ;Mult color
:green (card16->rgb-val (aref prop 4))
:blue (card16->rgb-val (aref prop 6)))))))
;;; OBSOLETE
(defun set-standard-colormap (window property colormap base-pixel max-color mult-color)
(declare (type window window)
(type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
:RGB_GREEN_MAP :RGB_BLUE_MAP) property)
(type colormap colormap)
(type pixel base-pixel)
(type color max-color mult-color))
(let ((prop (vector (encode-type colormap colormap)
(encode-type rgb-val (color-red max-color))
(encode-type rgb-val (color-red mult-color))
(encode-type rgb-val (color-green max-color))
(encode-type rgb-val (color-green mult-color))
(encode-type rgb-val (color-blue max-color))
(encode-type rgb-val (color-blue mult-color))
base-pixel)))
(change-property window property prop :RGB_COLOR_MAP 32)))
;;-----------------------------------------------------------------------------
;; Cut-Buffers
(defun cut-buffer (display &key (buffer 0) (type :STRING) (result-type 'string)
(transform #'card8->char) (start 0) end)
;; Return the contents of cut-buffer BUFFER
(declare (type display display)
(type (integer 0 7) buffer)
(type xatom type)
(type array-index start)
(type (or null array-index) end)
(type t result-type) ;a sequence type
(type (or null (function (integer) t)) transform))
(declare (clx-values sequence type format bytes-after))
(let* ((root (screen-root (first (display-roots display))))
(property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3
:CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7)
buffer)))
(get-property root property :type type :result-type result-type
:start start :end end :transform transform)))
(defun (setf cut-buffer)
(data display &key (buffer 0) (type :STRING) (format 8)
(start 0) end (transform #'char->card8))
(declare (type sequence data)
(type display display)
(type (integer 0 7) buffer)
(type xatom type)
(type (member 8 16 32) format)
(type array-index start)
(type (or null array-index) end)
(type (or null (function (integer) t)) transform))
(let* ((root (screen-root (first (display-roots display))))
(property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3
:CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7)
buffer)))
(change-property root property data type format :transform transform :start start :end end)
data))
(defun rotate-cut-buffers (display &optional (delta 1) (careful-p t))
;; Positive rotates left, negative rotates right (opposite of actual protocol request).
;; When careful-p, ensure all cut-buffer properties are defined, to prevent errors.
(declare (type display display)
(type int16 delta)
(type generalized-boolean careful-p))
(let* ((root (screen-root (first (display-roots display))))
(buffers '#(:cut_buffer0 :cut_buffer1 :cut_buffer2 :cut_buffer3
:cut_buffer4 :cut_buffer5 :cut_buffer6 :cut_buffer7)))
(when careful-p
(let ((props (list-properties root)))
(dotimes (i 8)
(unless (member (aref buffers i) props)
(setf (cut-buffer display :buffer i) "")))))
(rotate-properties root buffers delta)))

168
src/eclx/package.lisp
View file

@ -1,168 +0,0 @@
;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: Yes; -*-
;;; Copyright 1990 Massachusetts Institute of Technology, Cambridge,
;;; Massachusetts. All Rights Reserved.
;;;
;;; Permission to use, copy, modify, and distribute this software and its
;;; documentation for any purpose and without fee is hereby granted, provided
;;; that the above copyright notice appear in all copies and that both that
;;; copyright notice and this permission notice appear in supporting
;;; documentation, and that the name MIT not be used in advertising or
;;; publicity pertaining to distribution of the software without specific,
;;; written prior permission.
#+cmu
(ext:file-comment
"$Header$")
;;; The ANSI Common Lisp way
(common-lisp:in-package :common-lisp-user)
(defpackage xlib
(:use common-lisp)
(:size 3000)
(:export
*version* access-control access-error access-hosts
activate-screen-saver add-access-host add-resource add-to-save-set
alist alloc-color alloc-color-cells alloc-color-planes alloc-error
allow-events angle arc-seq array-index atom-error atom-name
bell bit-gravity bitmap bitmap-format bitmap-format-lsb-first-p
bitmap-format-p bitmap-format-pad bitmap-format-unit bitmap-image
boole-constant boolean card16 card29 card32 card8
card8->char change-active-pointer-grab change-keyboard-control
change-keyboard-mapping change-pointer-control change-property
char->card8 char-ascent char-attributes char-descent
char-left-bearing char-right-bearing char-width character->keysyms
character-in-map-p circulate-window-down circulate-window-up clear-area
close-display close-down-mode close-font closed-display color
color-blue color-green color-p color-red color-rgb colormap
colormap-display colormap-equal colormap-error colormap-id colormap-p
colormap-plist colormap-visual-info connection-failure convert-selection
copy-area copy-colormap-and-free copy-gcontext copy-gcontext-components
copy-image copy-plane create-colormap create-cursor
create-gcontext create-glyph-cursor create-image create-pixmap
create-window cursor cursor-display cursor-equal cursor-error
cursor-id cursor-p cursor-plist cut-buffer declare-event decode-core-error
default-error-handler default-keysym-index default-keysym-translate
define-error define-extension define-gcontext-accessor
define-keysym define-keysym-set delete-property delete-resource
destroy-subwindows destroy-window device-busy device-event-mask
device-event-mask-class discard-current-event discard-font-info display
display-after-function display-authorization-data display-authorization-name
display-bitmap-format display-byte-order display-default-screen
display-display display-error-handler display-finish-output
display-force-output display-host display-image-lsb-first-p
display-invoke-after-function display-keycode-range display-max-keycode
display-max-request-length display-min-keycode display-motion-buffer-size
display-nscreens display-p display-pixmap-formats display-plist
display-protocol-major-version display-protocol-minor-version
display-protocol-version display-release-number
display-report-asynchronous-errors display-resource-id-base
display-resource-id-mask display-roots display-vendor
display-vendor-name display-xdefaults display-xid draw-arc
draw-arcs draw-direction draw-glyph draw-glyphs draw-image-glyph
draw-image-glyphs draw-line draw-lines draw-point draw-points
draw-rectangle draw-rectangles draw-segments drawable
drawable-border-width drawable-depth drawable-display drawable-equal
drawable-error drawable-height drawable-id drawable-p
drawable-plist drawable-root drawable-width drawable-x drawable-y
error-key event-case event-cond event-handler event-key
event-listen event-mask event-mask-class extension-opcode
find-atom font font-all-chars-exist-p font-ascent
font-default-char font-descent font-direction font-display
font-equal font-error font-id font-max-byte1 font-max-byte2
font-max-char font-min-byte1 font-min-byte2 font-min-char
font-name font-p font-path font-plist font-properties
font-property fontable force-gcontext-changes free-colormap
free-colors free-cursor free-gcontext free-pixmap gcontext
gcontext-arc-mode gcontext-background
gcontext-cache-p gcontext-cap-style
gcontext-clip-mask gcontext-clip-ordering gcontext-clip-x
gcontext-clip-y gcontext-dash-offset gcontext-dashes gcontext-display
gcontext-equal gcontext-error gcontext-exposures gcontext-fill-rule
gcontext-fill-style gcontext-font gcontext-foreground gcontext-function
gcontext-id gcontext-join-style gcontext-key gcontext-line-style
gcontext-line-width gcontext-p gcontext-plane-mask gcontext-plist
gcontext-stipple gcontext-subwindow-mode gcontext-tile gcontext-ts-x
gcontext-ts-y generalized-boolean get-external-event-code get-image get-property
get-raw-image get-resource get-search-resource get-search-table
get-standard-colormap get-wm-class global-pointer-position grab-button
grab-key grab-keyboard grab-pointer grab-server grab-status
icon-sizes iconify-window id-choice-error illegal-request-error
image image-blue-mask image-depth image-green-mask image-height
image-name image-pixmap image-plist image-red-mask image-width
image-x image-x-hot image-x-p image-xy image-xy-bitmap-list
image-xy-p image-y-hot image-z image-z-bits-per-pixel image-z-p
image-z-pixarray implementation-error input-focus install-colormap
installed-colormaps int16 int32 int8 intern-atom invalid-font
keyboard-control keyboard-mapping keycode->character keycode->keysym
keysym keysym->character keysym->keycodes keysym-in-map-p
keysym-set kill-client kill-temporary-clients length-error
list-extensions list-font-names list-fonts list-properties
lookup-color lookup-error make-color make-event-handlers
make-event-keys make-event-mask make-resource-database make-state-keys
make-state-mask make-wm-hints make-wm-size-hints map-resource
map-subwindows map-window mapping-notify mask16 mask32
match-error max-char-ascent max-char-attributes max-char-descent
max-char-left-bearing max-char-right-bearing max-char-width
merge-resources min-char-ascent min-char-attributes min-char-descent
min-char-left-bearing min-char-right-bearing min-char-width
missing-parameter modifier-key modifier-mapping modifier-mask
motion-events name-error no-operation guess-display open-default-display open-display open-font
pixarray pixel pixmap pixmap-display pixmap-equal
pixmap-error pixmap-format pixmap-format-bits-per-pixel
pixmap-format-depth pixmap-format-p pixmap-format-scanline-pad
pixmap-id pixmap-p pixmap-plist point-seq pointer-control
pointer-event-mask pointer-event-mask-class pointer-mapping
pointer-position process-event put-image put-raw-image
query-best-cursor query-best-stipple query-best-tile query-colors
query-extension query-keymap query-pointer query-tree queue-event
read-bitmap-file read-resources recolor-cursor rect-seq
remove-access-host remove-from-save-set reparent-window repeat-seq
reply-length-error reply-timeout request-error reset-screen-saver
resource-database resource-database-timestamp resource-error
resource-id resource-key rgb-colormaps rgb-val root-resources
rotate-cut-buffers rotate-properties screen screen-backing-stores
screen-black-pixel screen-default-colormap screen-depths
screen-event-mask-at-open screen-height screen-height-in-millimeters
screen-max-installed-maps screen-min-installed-maps screen-p
screen-plist screen-root screen-root-depth screen-root-visual
screen-root-visual-info screen-save-unders-p screen-saver
screen-white-pixel screen-width screen-width-in-millimeters seg-seq
selection-owner send-event sequence-error set-access-control
set-close-down-mode set-input-focus set-modifier-mapping
set-pointer-mapping set-screen-saver set-selection-owner
set-standard-colormap set-standard-properties set-wm-class
set-wm-properties set-wm-resources state-keysym-p state-mask-key
store-color store-colors stringable text-extents text-width
timestamp transient-for translate-coordinates translate-default
translation-function undefine-keysym unexpected-reply
ungrab-button ungrab-key ungrab-keyboard ungrab-pointer
ungrab-server uninstall-colormap unknown-error unmap-subwindows
unmap-window value-error visual-info visual-info-bits-per-rgb
visual-info-blue-mask visual-info-class visual-info-colormap-entries
visual-info-display visual-info-green-mask visual-info-id visual-info-p
visual-info-plist visual-info-red-mask warp-pointer
warp-pointer-if-inside warp-pointer-relative warp-pointer-relative-if-inside
win-gravity window window-all-event-masks window-background
window-backing-pixel window-backing-planes window-backing-store
window-bit-gravity window-border window-class window-colormap
window-colormap-installed-p window-cursor window-display
window-do-not-propagate-mask window-equal window-error
window-event-mask window-gravity window-id window-map-state
window-override-redirect window-p window-plist window-priority
window-save-under window-visual window-visual-info with-display
with-event-queue with-gcontext with-server-grabbed with-state
withdraw-window wm-client-machine wm-colormap-windows wm-command
wm-hints wm-hints-flags wm-hints-icon-mask wm-hints-icon-pixmap
wm-hints-icon-window wm-hints-icon-x wm-hints-icon-y
wm-hints-initial-state wm-hints-input wm-hints-p wm-hints-window-group
wm-icon-name wm-name wm-normal-hints wm-protocols wm-resources
wm-size-hints wm-size-hints-base-height wm-size-hints-base-width
wm-size-hints-height wm-size-hints-height-inc wm-size-hints-max-aspect
wm-size-hints-max-height wm-size-hints-max-width wm-size-hints-min-aspect
wm-size-hints-min-height wm-size-hints-min-width wm-size-hints-p
wm-size-hints-user-specified-position-p wm-size-hints-user-specified-size-p
wm-size-hints-width wm-size-hints-width-inc wm-size-hints-win-gravity
wm-size-hints-x wm-size-hints-y wm-zoom-hints write-bitmap-file
write-resources xatom))

1494
src/eclx/requests.lisp
View file

File diff suppressed because it is too large Load diff

697
src/eclx/resource.lisp
View file

@ -1,697 +0,0 @@
;;; -*- Mode: LISP; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
;; RESOURCE - Lisp version of XLIB's Xrm resource manager
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
#+cmu
(ext:file-comment
"$Header$")
(in-package :xlib)
;; The C version of this uses a 64 entry hash table at each entry.
;; Small hash tables lose in Lisp, so we do linear searches on lists.
(defstruct (resource-database (:copier nil) (:predicate nil)
(:print-function print-resource-database)
(:constructor make-resource-database-internal)
)
(name nil :type stringable :read-only t)
(value nil)
(tight nil :type list) ;; List of resource-database
(loose nil :type list) ;; List of resource-database
)
(defun print-resource-database (database stream depth)
(declare (type resource-database database)
(ignore depth))
(print-unreadable-object (database stream :type t)
(write-string (string (resource-database-name database)) stream)
(when (resource-database-value database)
(write-string " " stream)
(prin1 (resource-database-value database) stream))))
;; The value slot of the top-level resource-database structure is used for a
;; time-stamp.
(defun make-resource-database ()
;; Make a resource-database with initial timestamp of 0
(make-resource-database-internal :name "Top-Level" :value 0))
(defun resource-database-timestamp (database)
(declare (type resource-database database))
(resource-database-value database))
(defun incf-resource-database-timestamp (database)
;; Increment the timestamp
(declare (type resource-database database))
(let ((timestamp (resource-database-value database)))
(setf (resource-database-value database)
(if (= timestamp most-positive-fixnum)
most-negative-fixnum
(1+ timestamp)))))
;; DEBUG FUNCTION (not exported)
(defun print-db (entry &optional (level 0) type)
;; Debug function to print a resource database
(format t "~%~v@t~s~:[~; *~]~@[ Value ~s~]"
level
(resource-database-name entry)
(eq type 'loose)
(resource-database-value entry))
(when (resource-database-tight entry)
(dolist (tight (resource-database-tight entry))
(print-db tight (+ 2 level) 'tight)))
(when (resource-database-loose entry)
(dolist (loose (resource-database-loose entry))
(print-db loose (+ 2 level) 'loose))))
;; DEBUG FUNCTION
#+comment
(defun print-search-table (table)
(terpri)
(dolist (dbase-list table)
(format t "~%~s" dbase-list)
(dolist (db dbase-list)
(print-db db)
(dolist (dblist table)
(unless (eq dblist dbase-list)
(when (member db dblist)
(format t " duplicate at ~s" db))))
)))
;;
;; If this is true, resource symbols will be compared in a case-insensitive
;; manner, and converting a resource string to a keyword will uppercaseify it.
;;
(defparameter *uppercase-resource-symbols* nil)
(defun resource-key (stringable)
;; Ensure STRINGABLE is a keyword.
(declare (type stringable stringable))
(etypecase stringable
(symbol
(if (keywordp (the symbol stringable))
stringable
(kintern (symbol-name (the symbol stringable)))))
(string
(if *uppercase-resource-symbols*
(setq stringable (string-upcase
(the string stringable))))
(kintern (the string stringable)))))
(defun stringable-equal (a b)
;; Compare two stringables.
;; Ignore case when comparing to a symbol.
(declare (type stringable a b))
(declare (clx-values generalized-boolean))
(etypecase a
(string
(etypecase b
(string
(string= (the string a) (the string b)))
(symbol
(if *uppercase-resource-symbols*
(string-equal (the string a)
(the string (symbol-name (the symbol b))))
(string= (the string a)
(the string (symbol-name (the symbol b))))))))
(symbol
(etypecase b
(string
(if *uppercase-resource-symbols*
(string-equal (the string (symbol-name (the symbol a)))
(the string b))
(string= (the string (symbol-name (the symbol a)))
(the string b))))
(symbol
(string= (the string (symbol-name (the symbol a)))
(the string (symbol-name (the symbol b)))))))))
;;;-----------------------------------------------------------------------------
;;; Add/delete resource
(defun add-resource (database name-list value)
;; name-list is a list of either strings or symbols. If a symbol,
;; case-insensitive comparisons will be used, if a string,
;; case-sensitive comparisons will be used. The symbol '* or
;; string "*" are used as wildcards, matching anything or nothing.
(declare (type resource-database database)
(type (clx-list stringable) name-list)
(type t value))
(unless value (error "Null resource values are ignored"))
(incf-resource-database-timestamp database)
(do* ((list name-list (cdr list))
(name (car list) (car list))
(node database)
(loose-p nil))
((endp list)
(setf (resource-database-value node) value))
;; Key is the first name that isn't *
(if (stringable-equal name "*")
(setq loose-p t)
;; find the entry associated with name
(progn
(do ((entry (if loose-p
(resource-database-loose node)
(resource-database-tight node))
(cdr entry)))
((endp entry)
;; Entry not found - create a new one
(setq entry (make-resource-database-internal :name name))
(if loose-p
(push entry (resource-database-loose node))
(push entry (resource-database-tight node)))
(setq node entry))
(when (stringable-equal name (resource-database-name (car entry)))
;; Found entry - use it
(return (setq node (car entry)))))
(setq loose-p nil)))))
(defun delete-resource (database name-list)
(declare (type resource-database database)
(type list name-list))
(incf-resource-database-timestamp database)
(delete-resource-internal database name-list))
(defun delete-resource-internal (database name-list)
(declare (type resource-database database)
(type (clx-list stringable) name-list))
(do* ((list name-list (cdr list))
(string (car list) (car list))
(node database)
(loose-p nil))
((endp list) nil)
;; Key is the first name that isn't *
(if (stringable-equal string "*")
(setq loose-p t)
;; find the entry associated with name
(progn
(do* ((first-entry (if loose-p
(resource-database-loose node)
(resource-database-tight node)))
(entry-list first-entry (cdr entry-list))
(entry (car entry-list) (car entry-list)))
((endp entry-list)
;; Entry not found - exit
(return-from delete-resource-internal nil))
(when (stringable-equal string (resource-database-name entry))
(when (cdr list) (delete-resource-internal entry (cdr list)))
(when (and (null (resource-database-loose entry))
(null (resource-database-tight entry)))
(if loose-p
(setf (resource-database-loose node)
(delete entry (resource-database-loose node)
:test #'eq :count 1))
(setf (resource-database-tight node)
(delete entry (resource-database-tight node)
:test #'eq :count 1))))
(return-from delete-resource-internal t)))
(setq loose-p nil)))))
;;;-----------------------------------------------------------------------------
;;; Get Resource
(defun get-resource (database value-name value-class full-name full-class)
;; Return the value of the resource in DATABASE whose partial name
;; most closely matches (append full-name (list value-name)) and
;; (append full-class (list value-class)).
(declare (type resource-database database)
(type stringable value-name value-class)
(type (clx-list stringable) full-name full-class))
(declare (clx-values value))
(let ((names (append full-name (list value-name)))
(classes (append full-class (list value-class))))
(let* ((result (get-entry (resource-database-tight database)
(resource-database-loose database)
names classes)))
(when result
(resource-database-value result)))))
(defun get-entry-lookup (table name names classes)
(declare (type list table names classes)
(type stringable name))
(dolist (entry table)
(declare (type resource-database entry))
(when (stringable-equal name (resource-database-name entry))
(if (null (cdr names))
(return entry)
(let ((result (get-entry (resource-database-tight entry)
(resource-database-loose entry)
(cdr names) (cdr classes))))
(declare (type (or null resource-database) result))
(when result
(return result)
))))))
(defun get-entry (tight loose names classes &aux result)
(declare (type list tight loose names classes))
(let ((name (car names))
(class (car classes)))
(declare (type stringable name class))
(cond ((and tight
(get-entry-lookup tight name names classes)))
((and loose
(get-entry-lookup loose name names classes)))
((and tight
(not (stringable-equal name class))
(get-entry-lookup tight class names classes)))
((and loose
(not (stringable-equal name class))
(get-entry-lookup loose class names classes)))
(loose
(loop
(pop names) (pop classes)
(unless (and names classes) (return nil))
(setq name (car names)
class (car classes))
(when (setq result (get-entry-lookup loose name names classes))
(return result))
(when (and (not (stringable-equal name class))
(setq result
(get-entry-lookup loose class names classes)))
(return result))
)))))
;;;-----------------------------------------------------------------------------
;;; Get-resource with search-table
(defun get-search-resource (table name class)
;; (get-search-resource (get-search-table database full-name full-class)
;; value-name value-class)
;; is equivalent to
;; (get-resource database value-name value-class full-name full-class)
;; But since most of the work is done by get-search-table,
;; get-search-resource is MUCH faster when getting several resources with
;; the same full-name/full-class
(declare (type list table)
(type stringable name class))
(let ((do-class (and class (not (stringable-equal name class)))))
(dolist (dbase-list table)
(declare (type list dbase-list))
(dolist (dbase dbase-list)
(declare (type resource-database dbase))
(when (stringable-equal name (resource-database-name dbase))
(return-from get-search-resource
(resource-database-value dbase))))
(when do-class
(dolist (dbase dbase-list)
(declare (type resource-database dbase))
(when (stringable-equal class (resource-database-name dbase))
(return-from get-search-resource
(resource-database-value dbase))))))))
(defvar *get-table-result*)
(defun get-search-table (database full-name full-class)
;; Return a search table for use with get-search-resource.
(declare (type resource-database database)
(type (clx-list stringable) full-name full-class))
(declare (clx-values value))
(let* ((tight (resource-database-tight database))
(loose (resource-database-loose database))
(result (cons nil nil))
(*get-table-result* result))
(declare (type list tight loose)
(type cons result))
(when (or tight loose)
(when full-name
(get-tables tight loose full-name full-class))
;; Pick up bindings of the form (* name). These are the elements of
;; top-level loose without further tight/loose databases.
;;
;; (Hack: these bindings belong in ANY search table, so recomputing them
;; is a drag. True fix involves redesigning entire lookup
;; data-structure/algorithm.)
;;
(let ((universal-bindings
(remove nil loose :test-not #'eq
:key #'(lambda (database)
(or (resource-database-tight database)
(resource-database-loose database))))))
(when universal-bindings
(setf (cdr *get-table-result*) (list universal-bindings)))))
(cdr result)))
(defun get-tables-lookup (dbase name names classes)
(declare (type list dbase names classes)
(type stringable name))
#-clx-debugging
(declare (optimize speed))
(dolist (entry dbase)
(declare (type resource-database entry))
(when (stringable-equal name (resource-database-name entry))
(let ((tight (resource-database-tight entry))
(loose (resource-database-loose entry)))
(declare (type list tight loose))
(when (or tight loose)
(if (cdr names)
(get-tables tight loose (cdr names) (cdr classes))
(when tight
(let ((result *get-table-result*))
;; Put tight at end of *get-table-result*
(setf (cdr result)
(setq *get-table-result* (cons tight nil))))))
(when loose
(let ((result *get-table-result*))
;; Put loose at end of *get-table-result*
(setf (cdr result)
(setq *get-table-result* (cons loose nil))))))))))
(defun get-tables (tight loose names classes)
(declare (type list tight loose names classes))
(let ((name (car names))
(class (car classes)))
(declare (type stringable name class))
(when tight
(get-tables-lookup tight name names classes))
(when loose
(get-tables-lookup loose name names classes))
(when (and tight (not (stringable-equal name class)))
(get-tables-lookup tight class names classes))
(when (and loose (not (stringable-equal name class)))
(get-tables-lookup loose class names classes))
(when loose
(loop
(pop names) (pop classes)
(unless (and names classes) (return nil))
(setq name (car names)
class (car classes))
(get-tables-lookup loose name names classes)
(unless (stringable-equal name class)
(get-tables-lookup loose class names classes))
))))
;;;-----------------------------------------------------------------------------
;;; Utility functions
(defun map-resource (database function &rest args)
;; Call FUNCTION on each resource in DATABASE.
;; FUNCTION is called with arguments (name-list value . args)
(declare (type resource-database database)
(type (function (list t &rest t) t) function)
(dynamic-extent function)
(dynamic-extent args))
(declare (clx-values nil))
(labels ((map-resource-internal (database function args name)
(declare (type resource-database database)
(type (function (list t &rest t) t) function)
(type list name)
(dynamic-extent function))
(let ((tight (resource-database-tight database))
(loose (resource-database-loose database)))
(declare (type list tight loose))
(dolist (resource tight)
(declare (type resource-database resource))
(let ((value (resource-database-value resource))
(name (append
name
(list (resource-database-name resource)))))
(if value
(apply function name value args)
(map-resource-internal resource function args name))))
(dolist (resource loose)
(declare (type resource-database resource))
(let ((value (resource-database-value resource))
(name (append
name
(list "*" (resource-database-name resource)))))
(if value
(apply function name value args)
(map-resource-internal resource function args name)))))))
(map-resource-internal database function args nil)))
(defun merge-resources (database with-database)
(declare (type resource-database database with-database))
(declare (clx-values resource-database))
(map-resource
database
#'(lambda (name value database)
(add-resource database name value))
with-database)
with-database)
(defun char-memq (key char)
;; Used as a test function for POSITION
(declare (type base-char char))
(member char key))
(defmacro resource-with-open-file ((stream pathname &rest options) &body body)
;; Private WITH-OPEN-FILE, which, when pathname is a stream, uses it as the
;; stream
(let ((abortp (gensym))
(streamp (gensym)))
`(let* ((,abortp t)
(,streamp (streamp pathname))
(,stream (if ,streamp pathname (open ,pathname ,@options))))
(unwind-protect
(multiple-value-prog1
(progn ,@body)
(setq ,abortp nil))
(unless ,streamp
(close stream :abort ,abortp))))))
(defun read-resources (database pathname &key key test test-not)
;; Merges resources from a file in standard X11 format with DATABASE.
;; KEY is a function used for converting value-strings, the default is
;; identity. TEST and TEST-NOT are predicates used for filtering
;; which resources to include in the database. They are called with
;; the name and results of the KEY function.
(declare (type resource-database database)
(type (or pathname string stream) pathname)
(type (or null (function (string) t)) key)
(type (or null (function (list t) generalized-boolean))
test test-not))
(declare (clx-values resource-database))
(resource-with-open-file (stream pathname)
(loop
(let ((string (read-line stream nil :eof)))
(declare (type (or string keyword) string))
(when (eq string :eof) (return database))
(let* ((end (length string))
(i (position '(#\tab #\space) string
:test-not #'char-memq :end end))
(term nil))
(declare (type array-index end)
(type (or null array-index) i term))
(when i ;; else blank line
(case (char string i)
(#\! nil) ;; Comment - skip
;;(#.(card8->char 0) nil) ;; terminator for C strings - skip
(#\# ;; Include
(setq term (position '(#\tab #\space) string :test #'char-memq
:start i :end end))
(when (string-equal string "#INCLUDE" :start1 i :end1 term)
(let ((path (merge-pathnames
(string-trim '(#\tab #\space #\")
(subseq string (1+ term)))
(truename stream))))
(read-resources database path
:key key :test test :test-not test-not))))
(otherwise
(multiple-value-bind (name-list value)
(parse-resource string i end)
(when name-list
(when key (setq value (funcall key value)))
(when
(cond (test (funcall test name-list value))
(test-not (not (funcall test-not name-list value)))
(t t))
(add-resource database name-list value))))))))))))
(defun parse-resource (string &optional (start 0) end)
;; Parse a resource specfication string into a list of names and a value
;; string
(declare (type string string)
(type array-index start)
(type (or null array-index) end))
(declare (clx-values name-list value))
(do ((i start)
(end (or end (length string)))
(term)
(name-list))
((>= i end))
(declare (type array-index end)
(type (or null array-index) i term))
(setq term (position '(#\. #\* #\:) string
:test #'char-memq :start i :end end))
(case (and term (char string term))
;; Name seperator
(#\. (when (> term i)
(push (subseq string i term) name-list)))
;; Wildcard seperator
(#\* (when (> term i)
(push (subseq string i term) name-list))
(push '* name-list))
;; Value separator
(#\:
(push (subseq string i term) name-list)
(return
(values
(nreverse name-list)
(string-trim '(#\tab #\space) (subseq string (1+ term))))))
(otherwise
(return
(values
(nreverse name-list)
(subseq string i term)))))
(setq i (1+ term))))
(defun write-resources (database pathname &key write test test-not)
;; Write resources to PATHNAME in the standard X11 format.
;; WRITE is a function used for writing values, the default is #'princ
;; TEST and TEST-NOT are predicates used for filtering which resources
;; to include in the database. They are called with the name and value.
(declare (type resource-database database)
(type (or pathname string stream) pathname)
(type (or null (function (string stream) t)) write)
(type (or null (function (list t) generalized-boolean))
test test-not))
(resource-with-open-file (stream pathname :direction :output)
(map-resource
database
#'(lambda (name-list value stream write test test-not)
(when
(cond (test (funcall test name-list value))
(test-not (not (funcall test-not name-list value)))
(t t))
(let ((previous (car name-list)))
(princ previous stream)
(dolist (name (cdr name-list))
(unless (or (stringable-equal name "*")
(stringable-equal previous "*"))
(write-char #\. stream))
(setq previous name)
(princ name stream)))
(write-string ": " stream)
(funcall write value stream)
(terpri stream)))
stream (or write #'princ) test test-not))
database)
(defun wm-resources (database window &key key test test-not)
;; Takes the resources associated with the RESOURCE_MANAGER property
;; of WINDOW (if any) and merges them with DATABASE.
;; KEY is a function used for converting value-strings, the default is
;; identity. TEST and TEST-NOT are predicates used for filtering
;; which resources to include in the database. They are called with
;; the name and results of the KEY function.
(declare (type resource-database database)
(type window window)
(type (or null (function (string) t)) key)
(type (or null (function (list t) generalized-boolean))
test test-not))
(declare (clx-values resource-database))
(let ((string (get-property window :RESOURCE_MANAGER :type :STRING
:result-type 'string
:transform #'xlib::card8->char)))
(when string
(with-input-from-string (stream string)
(read-resources database stream
:key key :test test :test-not test-not)))))
(defun set-wm-resources (database window &key write test test-not)
;; Sets the resources associated with the RESOURCE_MANAGER property
;; of WINDOW.
;; WRITE is a function used for writing values, the default is #'princ
;; TEST and TEST-NOT are predicates used for filtering which resources
;; to include in the database. They are called with the name and value.
(declare (type resource-database database)
(type window window)
(type (or null (function (string stream) t)) write)
(type (or null (function (list t) generalized-boolean))
test test-not))
(xlib::set-string-property
window :RESOURCE_MANAGER
(with-output-to-string (stream)
(write-resources database stream :write write
:test test :test-not test-not))))
(defun root-resources (screen &key database key test test-not)
"Returns a resource database containing the contents of the root window
RESOURCE_MANAGER property for the given SCREEN. If SCREEN is a display,
then its default screen is used. If an existing DATABASE is given, then
resource values are merged with the DATABASE and the modified DATABASE is
returned.
TEST and TEST-NOT are predicates for selecting which resources are
read. Arguments are a resource name list and a resource value. The KEY
function, if given, is called to convert a resource value string to the
value given to TEST or TEST-NOT."
(declare (type (or screen display) screen)
(type (or null resource-database) database)
(type (or null (function (string) t)) key)
(type (or null (function (list t) generalized-boolean)) test test-not)
(clx-values resource-database))
(let* ((screen (if (type? screen 'display)
(display-default-screen screen)
screen))
(window (screen-root screen))
(database (or database (make-resource-database))))
(wm-resources database window :key key :test test :test-not test-not)
database))
(defun set-root-resources (screen &key test test-not (write #'princ) database)
"Changes the contents of the root window RESOURCE_MANAGER property for the
given SCREEN. If SCREEN is a display, then its default screen is used.
TEST and TEST-NOT are predicates for selecting which resources from the
DATABASE are written. Arguments are a resource name list and a resource
value. The WRITE function is used to convert a resource value into a
string stored in the property."
(declare (type (or screen display) screen)
(type (or null resource-database) database)
(type (or null (function (list t) generalized-boolean)) test test-not)
(type (or null (function (string stream) t)) write)
(clx-values resource-database))
(let* ((screen (if (type? screen 'display)
(display-default-screen screen)
screen))
(window (screen-root screen)))
(set-wm-resources database window
:write write :test test :test-not test-not)
database))
(defsetf root-resources (screen &key test test-not (write #'princ))(database)
`(set-root-resources
,screen :test ,test :test-not ,test-not :write ,write :database ,database))
(defun initialize-resource-database (display)
;; This function is (supposed to be) equivalent to the Xlib initialization
;; code.
(declare (type display display))
(let ((rdb (make-resource-database))
(rootwin (screen-root (car (display-roots display)))))
;; First read the server defaults if present, otherwise from the default
;; resource file
(if (get-property rootwin :RESOURCE_MANAGER)
(xlib:wm-resources rdb rootwin)
(let ((path (default-resources-pathname)))
(when (and path (probe-file path))
(read-resources rdb path))))
;; Next read from the resources file
(let ((path (resources-pathname)))
(when (and path (probe-file path))
(read-resources rdb path)))
(setf (display-xdefaults display) rdb)))

192
src/eclx/shape.lisp
View file

@ -1,192 +0,0 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*-
;;; ---------------------------------------------------------------------------
;;; Title: X11 Shape extension
;;; Created: 1999-05-14 11:31
;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
;;; ---------------------------------------------------------------------------
;;; (c) copyright 1999 by Gilbert Baumann
;;;
;;; Permission is granted to any individual or institution to use,
;;; copy, modify, and distribute this software, provided that this
;;; complete copyright and permission notice is maintained, intact, in
;;; all copies and supporting documentation.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;;
;;; Use xc/doc/hardcopy/Xext/shape.PS.gz obtainable from e.g.
;; ftp://ftp.xfree86.org/pub/XFree86/current/untarred/xc/hardcopy/Xext/shape.PS.gz
(in-package :xlib)
(export '(shape-query-version
shape-rectangles
shape-mask
shape-combine
shape-offset
shape-query-extents
shape-select-input
shape-input-selected-p
shape-get-rectangles)
:xlib)
(define-extension "SHAPE"
:events (:shape-notify))
(declare-event :shape-notify
((data (member8 :bounding :clip)) kind) ;shape kind
(card16 sequence)
(window (window event-window)) ;affected window
(int16 x) ;extents
(int16 y)
(card16 width)
(card16 height)
((or null card32) time) ;timestamp
(boolean shaped-p))
(defun encode-shape-kind (kind)
(ecase kind
(:bounding 0)
(:clip 1)))
(defun encode-shape-operation (operation)
(ecase operation
(:set 0)
(:union 1)
(:interset 2)
(:subtract 3)
(:invert 4)))
(defun encode-shape-rectangle-ordering (ordering)
(ecase ordering
((:unsorted :un-sorted nil) 0)
((:y-sorted) 1)
((:yx-sorted) 2)
((:yx-banded) 3)))
(defun shape-query-version (display)
(with-buffer-request-and-reply (display (extension-opcode display "SHAPE")
nil :sizes 16)
((data 0))
(values
(card16-get 8)
(card16-get 10))))
(defun shape-rectangles (window rectangles
&key (kind :bounding)
(x-offset 0)
(y-offset 0)
(operation :set)
(ordering :unsorted))
(let* ((display (xlib:window-display window)))
(with-buffer-request (display (extension-opcode display "SHAPE"))
(data 1)
(card8 (encode-shape-operation operation))
(card8 (encode-shape-kind kind))
(card8 (encode-shape-rectangle-ordering ordering))
(card8 0) ;unused
(window window)
(int16 x-offset)
(int16 y-offset)
((sequence :format int16) rectangles))))
(defun shape-mask (window pixmap
&key (kind :bounding)
(x-offset 0)
(y-offset 0)
(operation :set))
(let* ((display (xlib:window-display window)))
(with-buffer-request (display (extension-opcode display "SHAPE"))
(data 2)
(card8 (encode-shape-operation operation))
(card8 (encode-shape-kind kind))
(card16 0) ;unused
(window window)
(int16 x-offset)
(int16 y-offset)
((or pixmap (member :none)) pixmap))))
(defun shape-combine (window source-window
&key (kind :bounding)
(source-kind :bounding)
(x-offset 0)
(y-offset 0)
(operation :set))
(let* ((display (xlib:window-display window)))
(with-buffer-request (display (extension-opcode display "SHAPE"))
(data 3)
(card8 (encode-shape-operation operation))
(card8 (encode-shape-kind kind))
(card8 (encode-shape-kind source-kind))
(card8 0) ;unused
(window window)
(int16 x-offset)
(int16 y-offset)
(window source-window))))
(defun shape-offset (window &key (kind :bounding) (x-offset 0) (y-offset 0))
(let* ((display (xlib:window-display window)))
(with-buffer-request (display (extension-opcode display "SHAPE"))
(data 4)
(card8 (encode-shape-kind kind))
(card8 0) (card8 0) (card8 0) ;unused
(window window)
(int16 x-offset)
(int16 y-offset))))
(defun shape-query-extents (window)
(let* ((display (xlib:window-display window)))
(with-buffer-request-and-reply (display (extension-opcode display "SHAPE")
nil :sizes (8 16 32))
((data 5)
(window window))
(values
(boolean-get 8) ;bounding shaped
(boolean-get 9) ;clip shaped
(int16-get 12) ;bounding shape extents x
(int16-get 14) ;bounding shape extents y
(card16-get 16) ;bounding shape extents width
(card16-get 18) ;bounding shape extents height
(int16-get 20) ;clip shape extents x
(int16-get 22) ;clip shape extents y
(card16-get 24) ;clip shape extents width
(card16-get 26))))) ;clip shape extents height
(defun shape-select-input (window selected-p)
(let* ((display (window-display window)))
(with-buffer-request (display (extension-opcode display "SHAPE"))
(data 6)
(window window)
(boolean selected-p)) ))
(defun shape-input-selected-p (window)
(let* ((display (window-display window)))
(with-buffer-request-and-reply (display (extension-opcode display "SHAPE")
nil :sizes (8))
((data 7) ;also wrong in documentation
(window window))
(boolean-get 1))))
(defun shape-get-rectangles (window &optional (kind :bounding)
(result-type 'list))
(let* ((display (window-display window)))
(with-buffer-request-and-reply (display (extension-opcode display "SHAPE")
nil :sizes (8 16 32))
((data 8) ;this was wrong in the specification
(window window)
(card8 (ecase kind
(:bounding 0)
(:clip 1))))
(values
(sequence-get :length (print (* 4 (card32-get 8)))
:result-type result-type
:format int16
:index +replysize+)
(ecase (card8-get 1)
(0 :unsorted)
(1 :y-sorted)
(2 :yx-sorted)
(3 :yx-banded) )))))

243
src/eclx/split-sequence.lisp
View file

@ -1,243 +0,0 @@
;;;; SPLIT-SEQUENCE
;;;
;;; This code was based on Arthur Lemmens' in
;;; <URL:http://groups.google.com/groups?as_umsgid=39F36F1A.B8F19D20%40simplex.nl>;
;;;
;;; changes include:
;;;
;;; * altering the behaviour of the :from-end keyword argument to
;;; return the subsequences in original order, for consistency with
;;; CL:REMOVE, CL:SUBSTITUTE et al. (:from-end being non-NIL only
;;; affects the answer if :count is less than the number of
;;; subsequences, by analogy with the above-referenced functions).
;;;
;;; * changing the :maximum keyword argument to :count, by analogy
;;; with CL:REMOVE, CL:SUBSTITUTE, and so on.
;;;
;;; * naming the function SPLIT-SEQUENCE rather than PARTITION rather
;;; than SPLIT.
;;;
;;; * adding SPLIT-SEQUENCE-IF and SPLIT-SEQUENCE-IF-NOT.
;;;
;;; * The second return value is now an index rather than a copy of a
;;; portion of the sequence; this index is the `right' one to feed to
;;; CL:SUBSEQ for continued processing.
;;; There's a certain amount of code duplication here, which is kept
;;; to illustrate the relationship between the SPLIT-SEQUENCE
;;; functions and the CL:POSITION functions.
;;; Examples:
;;;
;;; * (split-sequence #\; "a;;b;c")
;;; -> ("a" "" "b" "c"), 6
;;;
;;; * (split-sequence #\; "a;;b;c" :from-end t)
;;; -> ("a" "" "b" "c"), 0
;;;
;;; * (split-sequence #\; "a;;b;c" :from-end t :count 1)
;;; -> ("c"), 4
;;;
;;; * (split-sequence #\; "a;;b;c" :remove-empty-subseqs t)
;;; -> ("a" "b" "c"), 6
;;;
;;; * (split-sequence-if (lambda (x) (member x '(#\a #\b))) "abracadabra")
;;; -> ("" "" "r" "c" "d" "" "r" ""), 11
;;;
;;; * (split-sequence-if-not (lambda (x) (member x '(#\a #\b))) "abracadabra")
;;; -> ("ab" "a" "a" "ab" "a"), 11
;;;
;;; * (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9)
;;; -> ("oo" "bar" "b"), 9
(defpackage "SPLIT-SEQUENCE"
(:use "CL")
(:nicknames "PARTITION")
(:export "SPLIT-SEQUENCE" "SPLIT-SEQUENCE-IF" "SPLIT-SEQUENCE-IF-NOT"
"PARTITION" "PARTITION-IF" "PARTITION-IF-NOT"))
(in-package "SPLIT-SEQUENCE")
(defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied))
"Return a list of subsequences in seq delimited by delimiter.
If :remove-empty-subseqs is NIL, empty subsequences will be included
in the result; otherwise they will be discarded. All other keywords
work analogously to those for CL:SUBSTITUTE. In particular, the
behaviour of :from-end is possibly different from other versions of
this function; :from-end values of NIL and T are equivalent unless
:count is supplied. The second return value is an index suitable as an
argument to CL:SUBSEQ into the sequence indicating where processing
stopped."
(let ((len (length seq))
(other-keys (nconc (when test-supplied
(list :test test))
(when test-not-supplied
(list :test-not test-not))
(when key-supplied
(list :key key)))))
(unless end (setq end len))
(if from-end
(loop for right = end then left
for left = (max (or (apply #'position delimiter seq
:end right
:from-end t
other-keys)
-1)
(1- start))
unless (and (= right (1+ left))
remove-empty-subseqs) ; empty subseq we don't want
if (and count (>= nr-elts count))
;; We can't take any more. Return now.
return (values (nreverse subseqs) right)
else
collect (subseq seq (1+ left) right) into subseqs
and sum 1 into nr-elts
until (< left start)
finally (return (values (nreverse subseqs) (1+ left))))
(loop for left = start then (+ right 1)
for right = (min (or (apply #'position delimiter seq
:start left
other-keys)
len)
end)
unless (and (= right left)
remove-empty-subseqs) ; empty subseq we don't want
if (and count (>= nr-elts count))
;; We can't take any more. Return now.
return (values subseqs left)
else
collect (subseq seq left right) into subseqs
and sum 1 into nr-elts
until (>= right end)
finally (return (values subseqs right))))))
(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
"Return a list of subsequences in seq delimited by items satisfying
predicate.
If :remove-empty-subseqs is NIL, empty subsequences will be included
in the result; otherwise they will be discarded. All other keywords
work analogously to those for CL:SUBSTITUTE-IF. In particular, the
behaviour of :from-end is possibly different from other versions of
this function; :from-end values of NIL and T are equivalent unless
:count is supplied. The second return value is an index suitable as an
argument to CL:SUBSEQ into the sequence indicating where processing
stopped."
(let ((len (length seq))
(other-keys (when key-supplied
(list :key key))))
(unless end (setq end len))
(if from-end
(loop for right = end then left
for left = (max (or (apply #'position-if predicate seq
:end right
:from-end t
other-keys)
-1)
(1- start))
unless (and (= right (1+ left))
remove-empty-subseqs) ; empty subseq we don't want
if (and count (>= nr-elts count))
;; We can't take any more. Return now.
return (values (nreverse subseqs) right)
else
collect (subseq seq (1+ left) right) into subseqs
and sum 1 into nr-elts
until (< left start)
finally (return (values (nreverse subseqs) (1+ left))))
(loop for left = start then (+ right 1)
for right = (min (or (apply #'position-if predicate seq
:start left
other-keys)
len)
end)
unless (and (= right left)
remove-empty-subseqs) ; empty subseq we don't want
if (and count (>= nr-elts count))
;; We can't take any more. Return now.
return (values subseqs left)
else
collect (subseq seq left right) into subseqs
and sum 1 into nr-elts
until (>= right end)
finally (return (values subseqs right))))))
(defun split-sequence-if-not (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
"Return a list of subsequences in seq delimited by items satisfying
(CL:COMPLEMENT predicate).
If :remove-empty-subseqs is NIL, empty subsequences will be included
in the result; otherwise they will be discarded. All other keywords
work analogously to those for CL:SUBSTITUTE-IF-NOT. In particular,
the behaviour of :from-end is possibly different from other versions
of this function; :from-end values of NIL and T are equivalent unless
:count is supplied. The second return value is an index suitable as an
argument to CL:SUBSEQ into the sequence indicating where processing
stopped."
(let ((len (length seq))
(other-keys (when key-supplied
(list :key key))))
(unless end (setq end len))
(if from-end
(loop for right = end then left
for left = (max (or (apply #'position-if-not predicate seq
:end right
:from-end t
other-keys)
-1)
(1- start))
unless (and (= right (1+ left))
remove-empty-subseqs) ; empty subseq we don't want
if (and count (>= nr-elts count))
;; We can't take any more. Return now.
return (values (nreverse subseqs) right)
else
collect (subseq seq (1+ left) right) into subseqs
and sum 1 into nr-elts
until (< left start)
finally (return (values (nreverse subseqs) (1+ left))))
(loop for left = start then (+ right 1)
for right = (min (or (apply #'position-if-not predicate seq
:start left
other-keys)
len)
end)
unless (and (= right left)
remove-empty-subseqs) ; empty subseq we don't want
if (and count (>= nr-elts count))
;; We can't take any more. Return now.
return (values subseqs left)
else
collect (subseq seq left right) into subseqs
and sum 1 into nr-elts
until (>= right end)
finally (return (values subseqs right))))))
;;; clean deprecation
(defun partition (&rest args)
(apply #'split-sequence args))
(defun partition-if (&rest args)
(apply #'split-sequence-if args))
(defun partition-if-not (&rest args)
(apply #'split-sequence-if-not args))
(define-compiler-macro partition (&whole form &rest args)
(declare (ignore args))
(warn "PARTITION is deprecated; use SPLIT-SEQUENCE instead.")
form)
(define-compiler-macro partition-if (&whole form &rest args)
(declare (ignore args))
(warn "PARTITION-IF is deprecated; use SPLIT-SEQUENCE-IF instead.")
form)
(define-compiler-macro partition-if-not (&whole form &rest args)
(declare (ignore args))
(warn "PARTITION-IF-NOT is deprecated; use SPLIT-SEQUENCE-IF-NOT instead")
form)
(pushnew :split-sequence *features*)

155
src/eclx/test/image.lisp
View file

@ -1,155 +0,0 @@
;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
;;; Tests image code by randomly reading, copying and then writing images to
;;; the exact same place on the screen. If everything works, just the borders
;;; of the image windows appear. If one of these image windows is garbled,
;;; then somewhere something is broken. Entry point is the function
;;; IMAGE-TEST
(in-package :xlib)
(export '(image-test))
(defvar *image-test-host* "")
(defvar *image-test-nimages* 25)
(defvar *image-test-copy* t)
(defvar *image-test-copy-random-subimage* t)
(defvar *image-test-put-random-subimage* t)
(defvar *image-test-get-image-result-type-choices*
'(image-x image-x image-xy image-z))
(defvar *image-test-get-image-image-x-format-choices*
'(:xy-pixmap :z-pixmap))
(defun image-test
(&key
(host *image-test-host*)
(nimages *image-test-nimages*)
(copy *image-test-copy*)
(copy-random-subimage *image-test-copy-random-subimage*)
(put-random-subimage *image-test-put-random-subimage*)
(get-image-result-type-choices
*image-test-get-image-result-type-choices*)
(get-image-image-x-format-choices
*image-test-get-image-image-x-format-choices*))
(let* ((display nil)
(abort t)
(images nil))
(loop
(setq images nil)
(unwind-protect
(progn
(setq display (open-display host))
(let* ((screen (display-default-screen display))
(window (screen-root screen))
(gcontext (create-gcontext
:drawable window
:font (open-font display "fixed"))))
(dotimes (i nimages)
(let ((image (image-test-get-image
window
get-image-result-type-choices
get-image-image-x-format-choices)))
(format t "~&Image=~S~%" image)
(let ((copy (if copy
(image-test-copy-image
image
copy-random-subimage)
image)))
(format t "~&Copy=~S~%" copy)
(push (list image copy) images)
(image-test-put-image
screen gcontext copy
(concatenate
'string (image-info image) (image-info copy))
put-random-subimage))))
(unless (y-or-n-p "More ") (return))
(setq abort nil)))
(close-display (shiftf display nil) :abort abort))
(sleep 10))
(reverse images)))
(defun image-test-choose (list)
(nth (random (length list)) list))
(defun image-test-get-image (window result-type-choices image-x-format-choices)
(let* ((x (random (floor (drawable-width window) 3)))
(y (random (floor (drawable-height window) 3)))
(hw (floor (- (drawable-width window) x) 3))
(hh (floor (- (drawable-height window) y) 3))
(width (+ hw hw (random hw)))
(height (+ hh hh (random hh)))
(result-type (image-test-choose result-type-choices))
(format
(ecase result-type
(image-x (image-test-choose image-x-format-choices))
(image-xy :xy-pixmap)
(image-z :z-pixmap)))
(image (get-image window :x x :y y :width width :height height
:format format :result-type result-type)))
;; XCreatePixmapCursor(3X11) says that x,y for hotspot are
;; unsigned, so what we're doing here I don't know
;;(setf (image-x-hot image) (- x))
;;(setf (image-y-hot image) (- y))
image))
(defun image-test-subimage-parameters (image random-subimage-p)
(if random-subimage-p
(let* ((x (random (floor (image-width image) 3)))
(y (random (floor (image-height image) 3)))
(hw (floor (- (image-width image) x) 3))
(hh (floor (- (image-height image) y) 3))
(width (+ hw hw (random hw)))
(height (+ hh hh (random hh))))
(values x y width height))
(values 0 0 (image-width image) (image-height image))))
(defun image-test-copy-image (image random-subimage-p)
(let ((result-type
(if (zerop (random 2))
(type-of image)
(etypecase image
(image-x (ecase (image-x-format image)
(:xy-pixmap 'image-xy)
(:z-pixmap 'image-z)))
((or image-xy image-z) 'image-x)))))
(multiple-value-bind (x y width height)
(image-test-subimage-parameters image random-subimage-p)
(copy-image image :x x :y y :width width :height height
:result-type result-type))))
(defun image-test-put-image (screen gcontext image info random-subimage-p)
(multiple-value-bind (src-x src-y width height)
(image-test-subimage-parameters image random-subimage-p)
(let* ((border-width 1)
(x (- src-x #+nil (image-x-hot image) border-width))
(y (- src-y #+nil (image-y-hot image) border-width)))
(unless (or (zerop width) (zerop height))
(let ((window
(create-window
:parent (screen-root screen) :x x :y y
:width width :height height
:border-width border-width
:background (screen-white-pixel screen)
:override-redirect :on)))
(map-window window)
(display-finish-output (drawable-display window))
(put-image window gcontext image
:x 0 :y 0 :src-x src-x :src-y src-y
:width width :height height)
(draw-image-glyphs window gcontext 0 (1- height) info)
(display-finish-output (drawable-display window))
window)))))
(defun image-info (image)
(etypecase image
(image-x (ecase (image-x-format image)
(:xy-pixmap "XXY")
(:z-pixmap "XZ ")))
(image-xy "XY ")
(image-z "Z ")))

72
src/eclx/test/trapezoid.lisp
View file

@ -1,72 +0,0 @@
;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
;;; CLX trapezoid Extension test program
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
(in-package :xlib)
(defun zoid-test (host)
;; Display the part picture in /extensions/test/datafile
(let* ((display (open-display host))
(width 400)
(height 400)
(screen (display-default-screen display))
(black (screen-black-pixel screen))
(white (screen-white-pixel screen))
(win (create-window
:parent (screen-root screen)
:background black
:border white
:border-width 1
:colormap (screen-default-colormap screen)
:bit-gravity :center
:event-mask '(:exposure :key-press)
:x 20 :y 20
:width width :height height))
(gc (create-gcontext
:drawable win
:background black
:foreground white)))
(initialize-extensions display)
(map-window win) ; Map the window
;; Handle events
(unwind-protect
(loop
(event-case (display :force-output-p t)
(exposure ;; Come here on exposure events
(window count)
(when (zerop count) ;; Ignore all but the last exposure event
(clear-area window)
;; NOT VERY INTERESTING, BUT CHECKS ALL THE POSSIBILITIES
(poly-fill-Trapezoids window gc '(10 20 30 40 100 200))
(setf (gcontext-trapezoid-alignment gc) :y)
(poly-fill-Trapezoids window gc #(10 20 30 40 100 200))
(with-gcontext (gc :trapezoid-alignment :x)
(poly-fill-Trapezoids window gc '(40 50 60 70 140 240)))
(setf (gcontext-trapezoid-alignment gc) :x)
(poly-fill-Trapezoids window gc #(40 50 60 70 80 90))
(with-gcontext (gc :trapezoid-alignment :y)
(poly-fill-Trapezoids window gc #(40 50 60 70 140 240)))
(draw-glyphs window gc 10 10 "Press any key to exit")
;; Returning non-nil causes event-case to exit
t))
(key-press () (return-from zoid-test t))))
(close-display display))))

1063
src/eclx/text.lisp
View file

File diff suppressed because it is too large Load diff

559
src/eclx/translate.lisp
View file

@ -1,559 +0,0 @@
;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES -*-
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
(in-package :xlib)
(defvar *keysym-sets* nil) ;; Alist of (name first-keysym last-keysym)
(defun define-keysym-set (set first-keysym last-keysym)
;; Define all keysyms from first-keysym up to and including
;; last-keysym to be in SET (returned from the keysym-set function).
;; Signals an error if the keysym range overlaps an existing set.
(declare (type keyword set)
(type keysym first-keysym last-keysym))
(when (> first-keysym last-keysym)
(rotatef first-keysym last-keysym))
(setq *keysym-sets* (delete set *keysym-sets* :key #'car))
(dolist (set *keysym-sets*)
(let ((first (second set))
(last (third set)))
(when (or (<= first first-keysym last)
(<= first last-keysym last))
(error "Keysym range overlaps existing set ~s" set))))
(push (list set first-keysym last-keysym) *keysym-sets*)
set)
(defun keysym-set (keysym)
;; Return the character code set name of keysym
(declare (type keysym keysym)
(clx-values keyword))
(dolist (set *keysym-sets*)
(let ((first (second set))
(last (third set)))
(when (<= first keysym last)
(return (first set))))))
(eval-when (:compile-toplevel :execute :load-toplevel) ;; Required for Vaxlisp ...
(defmacro keysym (keysym &rest bytes)
;; Build a keysym.
;; If KEYSYM is an integer, it is used as the most significant bits of
;; the keysym, and BYTES are used to specify low order bytes. The last
;; parameter is always byte4 of the keysym. If KEYSYM is not an
;; integer, the keysym associated with KEYSYM is returned.
;;
;; This is a macro and not a function macro to promote compile-time
;; lookup. All arguments are evaluated.
(declare (type t keysym)
(type list bytes)
(clx-values keysym))
(typecase keysym
((integer 0 *)
(dolist (b bytes keysym) (setq keysym (+ (ash keysym 8) b))))
(otherwise
(or (car (character->keysyms keysym))
(error "~s Isn't the name of a keysym" keysym)))))
)
(defvar *keysym->character-map*
(make-hash-table :test (keysym->character-map-test) :size 400))
;; Keysym-mappings are a list of the form (object translate lowercase modifiers mask)
;; With the following accessor macros. Everything after OBJECT is optional.
(defmacro keysym-mapping-object (keysym-mapping)
;; Parameter to translate
`(first ,keysym-mapping))
(defmacro keysym-mapping-translate (keysym-mapping)
;; Function to be called with parameters (display state OBJECT)
;; when translating KEYSYM and modifiers and mask are satisfied.
`(second ,keysym-mapping))
(defmacro keysym-mapping-lowercase (keysym-mapping)
;; LOWERCASE is used for uppercase alphabetic keysyms. The value
;; is the associated lowercase keysym.
`(third ,keysym-mapping))
(defmacro keysym-mapping-modifiers (keysym-mapping)
;; MODIFIERS is either a modifier-mask or list containing intermixed
;; keysyms and state-mask-keys specifying when to use this
;; keysym-translation.
`(fourth ,keysym-mapping))
(defmacro keysym-mapping-mask (keysym-mapping)
;; MASK is either a modifier-mask or list containing intermixed
;; keysyms and state-mask-keys specifying which modifiers to look at
;; (i.e. modifiers not specified are don't-cares)
`(fifth ,keysym-mapping))
(defvar *default-keysym-translate-mask*
(the (or (member :modifiers) mask16 (clx-list (or keysym state-mask-key)))
(logand #xff (lognot (make-state-mask :lock))))
"Default keysym state mask to use during keysym-translation.")
(defun define-keysym (object keysym &key lowercase translate modifiers mask display)
;; Define the translation from keysym/modifiers to a (usually
;; character) object. ANy previous keysym definition with
;; KEYSYM and MODIFIERS is deleted before adding the new definition.
;;
;; MODIFIERS is either a modifier-mask or list containing intermixed
;; keysyms and state-mask-keys specifying when to use this
;; keysym-translation. The default is NIL.
;;
;; MASK is either a modifier-mask or list containing intermixed
;; keysyms and state-mask-keys specifying which modifiers to look at
;; (i.e. modifiers not specified are don't-cares).
;; If mask is :MODIFIERS then the mask is the same as the modifiers
;; (i.e. modifiers not specified by modifiers are don't cares)
;; The default mask is *default-keysym-translate-mask*
;;
;; If DISPLAY is specified, the translation will be local to DISPLAY,
;; otherwise it will be the default translation for all displays.
;;
;; LOWERCASE is used for uppercase alphabetic keysyms. The value
;; is the associated lowercase keysym. This information is used
;; by the keysym-both-case-p predicate (for caps-lock computations)
;; and by the keysym-downcase function.
;;
;; TRANSLATE will be called with parameters (display state OBJECT)
;; when translating KEYSYM and modifiers and mask are satisfied.
;; [e.g (zerop (logxor (logand state (or mask *default-keysym-translate-mask*))
;; (or modifiers 0)))
;; when mask and modifiers aren't lists of keysyms]
;; The default is #'default-keysym-translate
;;
(declare (type (or base-char t) object)
(type keysym keysym)
(type (or null mask16 (clx-list (or keysym state-mask-key)))
modifiers)
(type (or null (member :modifiers) mask16 (clx-list (or keysym state-mask-key)))
mask)
(type (or null display) display)
(type (or null keysym) lowercase)
(type (or null (function (display card16 t) t)) translate))
(flet ((merge-keysym-mappings (new old)
;; Merge new keysym-mapping with list of old mappings.
;; Ensure that the mapping with no modifiers or mask comes first.
(let* ((key (keysym-mapping-modifiers new))
(merge (delete key old :key #'cadddr :test #'equal)))
(if key
(nconc merge (list new))
(cons new merge))))
(mask-check (mask)
(unless (or (numberp mask)
(dolist (element mask t)
(unless (or (find element *state-mask-vector*)
(gethash element *keysym->character-map*))
(return nil))))
(x-type-error mask '(or mask16 (clx-list (or modifier-key modifier-keysym)))))))
(let ((entry
;; Create with a single LIST call, to ensure cdr-coding
(cond
(mask
(unless (eq mask :modifiers)
(mask-check mask))
(when (or (null modifiers) (and (numberp modifiers) (zerop modifiers)))
(error "Mask with no modifiers"))
(list object translate lowercase modifiers mask))
(modifiers (mask-check modifiers)
(list object translate lowercase modifiers))
(lowercase (list object translate lowercase))
(translate (list object translate))
(t (list object)))))
(if display
(let ((previous (assoc keysym (display-keysym-translation display))))
(if previous
(setf (cdr previous) (merge-keysym-mappings entry (cdr previous)))
(push (list keysym entry) (display-keysym-translation display))))
(setf (gethash keysym *keysym->character-map*)
(merge-keysym-mappings entry (gethash keysym *keysym->character-map*)))))
object))
(defun undefine-keysym (object keysym &key display modifiers &allow-other-keys)
;; Undefine the keysym-translation translating KEYSYM to OBJECT with MODIFIERS.
;; If DISPLAY is non-nil, undefine the translation for DISPLAY if it exists.
(declare (type (or base-char t) object)
(type keysym keysym)
(type (or null mask16 (clx-list (or keysym state-mask-key)))
modifiers)
(type (or null display) display))
(flet ((match (key entry)
(let ((object (car key))
(modifiers (cdr key)))
(or (eql object (keysym-mapping-object entry))
(equal modifiers (keysym-mapping-modifiers entry))))))
(let* (entry
(previous (if display
(cdr (setq entry (assoc keysym (display-keysym-translation display))))
(gethash keysym *keysym->character-map*)))
(key (cons object modifiers)))
(when (and previous (find key previous :test #'match))
(setq previous (delete key previous :test #'match))
(if display
(setf (cdr entry) previous)
(setf (gethash keysym *keysym->character-map*) previous))))))
(defun keysym-downcase (keysym)
;; If keysym has a lower-case equivalent, return it, otherwise return keysym.
(declare (type keysym keysym))
(declare (clx-values keysym))
(let ((translations (gethash keysym *keysym->character-map*)))
(or (and translations (keysym-mapping-lowercase (first translations))) keysym)))
(defun keysym-uppercase-alphabetic-p (keysym)
;; Returns T if keysym is uppercase-alphabetic.
;; I.E. If it has a lowercase equivalent.
(declare (type keysym keysym))
(declare (clx-values (or null keysym)))
(let ((translations (gethash keysym *keysym->character-map*)))
(and translations
(keysym-mapping-lowercase (first translations)))))
(defun character->keysyms (character &optional display)
;; Given a character, return a list of all matching keysyms.
;; If DISPLAY is given, translations specific to DISPLAY are used,
;; otherwise only global translations are used.
;; Implementation dependent function.
;; May be slow [i.e. do a linear search over all known keysyms]
(declare (type t character)
(type (or null display) display)
(clx-values (clx-list keysym)))
(let ((result nil))
(when display
(dolist (mapping (display-keysym-translation display))
(when (eql character (second mapping))
(push (first mapping) result))))
(maphash #'(lambda (keysym mappings)
(dolist (mapping mappings)
(when (eql (keysym-mapping-object mapping) character)
(pushnew keysym result))))
*keysym->character-map*)
result))
(eval-when (:compile-toplevel :execute :load-toplevel) ;; Required for Symbolics...
(defparameter character-set-switch-keysym (keysym 255 126))
(defparameter left-shift-keysym (keysym 255 225))
(defparameter right-shift-keysym (keysym 255 226))
(defparameter left-control-keysym (keysym 255 227))
(defparameter right-control-keysym (keysym 255 228))
(defparameter caps-lock-keysym (keysym 255 229))
(defparameter shift-lock-keysym (keysym 255 230))
(defparameter left-meta-keysym (keysym 255 231))
(defparameter right-meta-keysym (keysym 255 232))
(defparameter left-alt-keysym (keysym 255 233))
(defparameter right-alt-keysym (keysym 255 234))
(defparameter left-super-keysym (keysym 255 235))
(defparameter right-super-keysym (keysym 255 236))
(defparameter left-hyper-keysym (keysym 255 237))
(defparameter right-hyper-keysym (keysym 255 238))
) ;; end eval-when
;;-----------------------------------------------------------------------------
;; Keysym mapping functions
(defun display-keyboard-mapping (display)
(declare (type display display))
(declare (clx-values (simple-array keysym (display-max-keycode keysyms-per-keycode))))
(or (display-keysym-mapping display)
(setf (display-keysym-mapping display) (keyboard-mapping display))))
(defun keycode->keysym (display keycode keysym-index)
(declare (type display display)
(type card8 keycode)
(type card8 keysym-index)
(clx-values keysym))
(let* ((mapping (display-keyboard-mapping display))
(keysym (aref mapping keycode keysym-index)))
(declare (type (simple-array keysym (* *)) mapping)
(type keysym keysym))
;; The keysym-mapping is brain dammaged.
;; Mappings for both-case alphabetic characters have the
;; entry for keysym-index zero set to the uppercase keysym
;; (this is normally where the lowercase keysym goes), and the
;; entry for keysym-index one is zero.
(cond ((zerop keysym-index) ; Lowercase alphabetic keysyms
(keysym-downcase keysym))
((and (zerop keysym) (plusp keysym-index)) ; Get the uppercase keysym
(aref mapping keycode 0))
(t keysym))))
(defun keysym->character (display keysym &optional (state 0))
;; Find the character associated with a keysym.
;; STATE can be used to set character attributes.
;; Implementation dependent function.
(declare (type display display)
(type keysym keysym)
(type card16 state))
(declare (clx-values (or null character)))
(let* ((display-mappings (cdr (assoc keysym (display-keysym-translation display))))
(mapping (or ;; Find the matching display mapping
(dolist (mapping display-mappings)
(when (mapping-matches-p display state mapping)
(return mapping)))
;; Find the matching static mapping
(dolist (mapping (gethash keysym *keysym->character-map*))
(when (mapping-matches-p display state mapping)
(return mapping))))))
(when mapping
(funcall (or (keysym-mapping-translate mapping) 'default-keysym-translate)
display state (keysym-mapping-object mapping)))))
(defun mapping-matches-p (display state mapping)
;; Returns T when the modifiers and mask in MAPPING satisfies STATE for DISPLAY
(declare (type display display)
(type mask16 state)
(type list mapping))
(declare (clx-values generalized-boolean))
(flet
((modifiers->mask (display-mapping modifiers errorp &aux (mask 0))
;; Convert MODIFIERS, which is a modifier mask, or a list of state-mask-keys into a mask.
;; If ERRORP is non-nil, return NIL when an unknown modifier is specified,
;; otherwise ignore unknown modifiers.
(declare (type list display-mapping) ; Alist of (keysym . mask)
(type (or mask16 list) modifiers)
(type mask16 mask))
(declare (clx-values (or null mask16)))
(if (numberp modifiers)
modifiers
(dolist (modifier modifiers mask)
(declare (type symbol modifier))
(let ((bit (position modifier (the simple-vector *state-mask-vector*) :test #'eq)))
(setq mask
(logior mask
(if bit
(ash 1 bit)
(or (cdr (assoc modifier display-mapping))
;; bad modifier
(if errorp
(return-from modifiers->mask nil)
0))))))))))
(let* ((display-mapping (get-display-modifier-mapping display))
(mapping-modifiers (keysym-mapping-modifiers mapping))
(modifiers (or (modifiers->mask display-mapping (or mapping-modifiers 0) t)
(return-from mapping-matches-p nil)))
(mapping-mask (or (keysym-mapping-mask mapping) ; If no mask, use the default.
(if mapping-modifiers ; If no modifiers, match anything.
*default-keysym-translate-mask*
0)))
(mask (if (eq mapping-mask :modifiers)
modifiers
(modifiers->mask display-mapping mapping-mask nil))))
(declare (type mask16 modifiers mask))
(= (logand state mask) modifiers))))
(defun default-keysym-index (display keycode state)
;; Returns a keysym-index for use with keycode->character
(declare (clx-values card8))
(macrolet ((keystate-p (state keyword)
`(logbitp ,(position keyword *state-mask-vector*) ,state)))
(let* ((mapping (display-keyboard-mapping display))
(keysyms-per-keycode (array-dimension mapping 1))
(symbolp (and (> keysyms-per-keycode 2)
(state-keysymp display state character-set-switch-keysym)))
(result (if symbolp 2 0)))
(declare (type (simple-array keysym (* *)) mapping)
(type generalized-boolean symbolp)
(type card8 keysyms-per-keycode result))
(when (and (< result keysyms-per-keycode)
(keysym-shift-p display state (keysym-uppercase-alphabetic-p
(aref mapping keycode 0))))
(incf result))
result)))
(defun keysym-shift-p (display state uppercase-alphabetic-p &key
shift-lock-xors
(control-modifiers
'#.(list left-meta-keysym left-super-keysym left-hyper-keysym)))
(declare (type display display)
(type card16 state)
(type generalized-boolean uppercase-alphabetic-p)
(type generalized-boolean shift-lock-xors));;; If T, both SHIFT-LOCK and SHIFT is the same
;;; as neither if the character is alphabetic.
(declare (clx-values generalized-boolean))
(macrolet ((keystate-p (state keyword)
`(logbitp ,(position keyword *state-mask-vector*) ,state)))
(let* ((controlp (or (keystate-p state :control)
(dolist (modifier control-modifiers)
(when (state-keysymp display state modifier)
(return t)))))
(shiftp (keystate-p state :shift))
(lockp (keystate-p state :lock))
(alphap (or uppercase-alphabetic-p
(not (state-keysymp display #.(make-state-mask :lock)
caps-lock-keysym)))))
(declare (type generalized-boolean controlp shiftp lockp alphap))
;; Control keys aren't affected by lock
(unless controlp
;; Not a control character - check state of lock modifier
(when (and lockp
alphap
(or (not shiftp) shift-lock-xors)) ; Lock doesn't unshift unless shift-lock-xors
(setq shiftp (not shiftp))))
shiftp)))
;;; default-keysym-index implements the following tables:
;;;
;;; control shift caps-lock character character
;;; 0 0 0 #\a #\8
;;; 0 0 1 #\A #\8
;;; 0 1 0 #\A #\*
;;; 0 1 1 #\A #\*
;;; 1 0 0 #\control-A #\control-8
;;; 1 0 1 #\control-A #\control-8
;;; 1 1 0 #\control-shift-a #\control-*
;;; 1 1 1 #\control-shift-a #\control-*
;;;
;;; control shift shift-lock character character
;;; 0 0 0 #\a #\8
;;; 0 0 1 #\A #\*
;;; 0 1 0 #\A #\*
;;; 0 1 1 #\A #\8
;;; 1 0 0 #\control-A #\control-8
;;; 1 0 1 #\control-A #\control-*
;;; 1 1 0 #\control-shift-a #\control-*
;;; 1 1 1 #\control-shift-a #\control-8
(defun keycode->character (display keycode state &key keysym-index
(keysym-index-function #'default-keysym-index))
;; keysym-index defaults to the result of keysym-index-function which
;; is called with the following parameters:
;; (char0 state caps-lock-p keysyms-per-keycode)
;; where char0 is the "character" object associated with keysym-index 0 and
;; caps-lock-p is non-nil when the keysym associated with the lock
;; modifier is for caps-lock.
;; STATE can also used for setting character attributes.
;; Implementation dependent function.
(declare (type display display)
(type card8 keycode)
(type card16 state)
(type (or null card8) keysym-index)
(type (or null (function (base-char card16 generalized-boolean card8) card8))
keysym-index-function))
(declare (clx-values (or null character)))
(let* ((index (or keysym-index
(funcall keysym-index-function display keycode state)))
(keysym (if index (keycode->keysym display keycode index) 0)))
(declare (type (or null card8) index)
(type keysym keysym))
(when (plusp keysym)
(keysym->character display keysym state))))
(defun get-display-modifier-mapping (display)
(labels ((keysym-replace (display modifiers mask &aux result)
(dolist (modifier modifiers result)
(push (cons (keycode->keysym display modifier 0) mask) result))))
(or (display-modifier-mapping display)
(multiple-value-bind (shift lock control mod1 mod2 mod3 mod4 mod5)
(modifier-mapping display)
(setf (display-modifier-mapping display)
(nconc (keysym-replace display shift #.(make-state-mask :shift))
(keysym-replace display lock #.(make-state-mask :lock))
(keysym-replace display control #.(make-state-mask :control))
(keysym-replace display mod1 #.(make-state-mask :mod-1))
(keysym-replace display mod2 #.(make-state-mask :mod-2))
(keysym-replace display mod3 #.(make-state-mask :mod-3))
(keysym-replace display mod4 #.(make-state-mask :mod-4))
(keysym-replace display mod5 #.(make-state-mask :mod-5))))))))
(defun state-keysymp (display state keysym)
;; Returns T when a modifier key associated with KEYSYM is on in STATE
(declare (type display display)
(type card16 state)
(type keysym keysym))
(declare (clx-values generalized-boolean))
(let* ((mapping (get-display-modifier-mapping display))
(mask (assoc keysym mapping)))
(and mask (plusp (logand state (cdr mask))))))
(defun mapping-notify (display request start count)
;; Called on a mapping-notify event to update
;; the keyboard-mapping cache in DISPLAY
(declare (type display display)
(type (member :modifier :keyboard :pointer) request)
(type card8 start count)
(ignore count start))
;; Invalidate the keyboard mapping to force the next key translation to get it
(case request
(:modifier
(setf (display-modifier-mapping display) nil))
(:keyboard
(setf (display-keysym-mapping display) nil))))
(defun keysym-in-map-p (display keysym keymap)
;; Returns T if keysym is found in keymap
(declare (type display display)
(type keysym keysym)
(type (bit-vector 256) keymap))
(declare (clx-values generalized-boolean))
;; The keysym may appear in the keymap more than once,
;; So we have to search the entire keysym map.
(do* ((min (display-min-keycode display))
(max (display-max-keycode display))
(map (display-keyboard-mapping display))
(jmax (min 2 (array-dimension map 1)))
(i min (1+ i)))
((> i max))
(declare (type card8 min max jmax)
(type (simple-array keysym (* *)) map))
(when (and (plusp (aref keymap i))
(dotimes (j jmax)
(when (= keysym (aref map i j)) (return t))))
(return t))))
(defun character-in-map-p (display character keymap)
;; Implementation dependent function.
;; Returns T if character is found in keymap
(declare (type display display)
(type character character)
(type (bit-vector 256) keymap))
(declare (clx-values generalized-boolean))
;; Check all one bits in keymap
(do* ((min (display-min-keycode display))
(max (display-max-keycode display))
(jmax (array-dimension (display-keyboard-mapping display) 1))
(i min (1+ i)))
((> i max))
(declare (type card8 min max jmax))
(when (and (plusp (aref keymap i))
;; Match when character is in mapping for this keycode
(dotimes (j jmax)
(when (eql character (keycode->character display i 0 :keysym-index j))
(return t))))
(return t))))
(defun keysym->keycodes (display keysym)
;; Return keycodes for keysym, as multiple values
(declare (type display display)
(type keysym keysym))
(declare (clx-values (or null keycode) (or null keycode) (or null keycode)))
;; The keysym may appear in the keymap more than once,
;; So we have to search the entire keysym map.
(do* ((min (display-min-keycode display))
(max (display-max-keycode display))
(map (display-keyboard-mapping display))
(jmax (min 2 (array-dimension map 1)))
(i min (1+ i))
(result nil))
((> i max) (values-list result))
(declare (type card8 min max jmax)
(type (simple-array keysym (* *)) map))
(dotimes (j jmax)
(when (= keysym (aref map i j))
(push i result)))))