cl-clx-sbcl-0.7.4.20160323.orig/0000755000175000017500000000000012715666243013621 5ustar pdmpdmcl-clx-sbcl-0.7.4.20160323.orig/cmudep.lisp0000644000175000017500000000132512715665272015771 0ustar pdmpdm;;; -*- Package: XLIB -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; If you want to use this code or any part of CMU Common Lisp, please contact ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment "$Header: /loaclhost/usr/local/src/cvs/clx/cmudep.lisp,v 1.1 2000/07/02 19:19:46 dan Exp $") ;;; ;;; ********************************************************************** ;;; (in-package "XLIB") (alien:def-alien-routine ("connect_to_server" xlib::connect-to-server) c-call:int (host c-call:c-string) (port c-call:int)) cl-clx-sbcl-0.7.4.20160323.orig/input.lisp0000644000175000017500000022147012715665272015660 0ustar pdmpdm;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11 ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; ;;; ;;; Change history: ;;; ;;; Date Author Description ;;; ------------------------------------------------------------------------------------- ;;; 12/10/87 LGO Created (in-package :xlib) ;; Event Resource (defvar *event-free-list* nil) ;; List of unused (processed) events (eval-when (:compile-toplevel :load-toplevel :execute) ;; Maximum number of events supported (the X11 alpha release only has 34) (defconstant +max-events+ 64) (defvar *event-key-vector* (make-array +max-events+ :initial-element nil) "Vector of event keys - See define-event")) (defvar *event-macro-vector* (make-array +max-events+ :initial-element nil) "Vector of event handler functions - See declare-event") (defvar *event-handler-vector* (make-array +max-events+ :initial-element nil) "Vector of event handler functions - See declare-event") (defvar *event-send-vector* (make-array +max-events+ :initial-element nil) "Vector of event sending functions - See declare-event") (defun allocate-event () (or (threaded-atomic-pop *event-free-list* reply-next reply-buffer) (make-reply-buffer +replysize+))) (defun deallocate-event (reply-buffer) (declare (type reply-buffer reply-buffer)) (setf (reply-size reply-buffer) +replysize+) (threaded-atomic-push reply-buffer *event-free-list* reply-next reply-buffer)) ;; Extensions are handled as follows: ;; DEFINITION: Use DEFINE-EXTENSION ;; ;; CODE: Use EXTENSION-CODE to get the X11 opcode for an extension. ;; This looks up the code on the display-extension-alist. ;; ;; EVENTS: Use DECLARE-EVENT to define events. This calls ALLOCATE-EXTENSION-EVENT-CODE ;; at LOAD time to define an internal event-code number ;; (stored in the 'event-code property of the event-name) ;; used to index the following vectors: ;; *event-key-vector* Used for getting the event-key ;; *event-macro-vector* Used for getting the event-parameter getting macros ;; ;; The GET-INTERNAL-EVENT-CODE function can be called at runtime to convert ;; a server event-code into an internal event-code used to index the following ;; vectors: ;; *event-handler-vector* Used for getting the event-handler function ;; *event-send-vector* Used for getting the event-sending function ;; ;; The GET-EXTERNAL-EVENT-CODE function can be called at runtime to convert ;; internal event-codes to external (server) codes. ;; ;; ERRORS: Use DEFINE-ERROR to define new error decodings. ;; ;; Any event-code greater than 34 is for an extension (defparameter *first-extension-event-code* 35) (defvar *extensions* nil) ;; alist of (extension-name-symbol events errors) (defmacro define-extension (name &key events errors) ;; Define extension NAME with EVENTS and ERRORS. ;; Note: The case of NAME is important. ;; To define the request, Use: ;; (with-buffer-request (display (extension-opcode ,name)) ,@body) ;; See the REQUESTS file for lots of examples. ;; To define event handlers, use declare-event. ;; To define error handlers, use declare-error and define-condition. (declare (type stringable name) (type list events errors)) (let ((name-symbol (kintern name)) ;; Intern name in the keyword package (event-list (mapcar #'canonicalize-event-name events))) `(eval-when (:compile-toplevel :load-toplevel :execute) (setq *extensions* (cons (list ',name-symbol ',event-list ',errors) (delete ',name-symbol *extensions* :key #'car)))))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun canonicalize-event-name (event) ;; Returns the event name keyword given an event name stringable (declare (type stringable event)) (declare (clx-values event-key)) (kintern event))) (defun extension-event-key-p (key) (dolist (extension *extensions* nil) (when (member key (second extension)) (return t)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun allocate-extension-event-code (name) ;; Allocate an event-code for an extension. This is executed at ;; COMPILE and LOAD time from DECLARE-EVENT. The event-code is ;; used at compile-time by macros to index the following vectors: ;; *EVENT-KEY-VECTOR* *EVENT-MACRO-VECTOR* *EVENT-HANDLER-VECTOR* ;; *EVENT-SEND-VECTOR* (let ((event-code (get name 'event-code))) (declare (type (or null card8) event-code)) (unless event-code ;; First ensure the name is for a declared extension (unless (extension-event-key-p name) (x-type-error name 'event-key)) (setq event-code (position nil *event-key-vector* :start *first-extension-event-code*)) (setf (svref *event-key-vector* event-code) name) (setf (get name 'event-code) event-code)) event-code))) (defun get-internal-event-code (display code) ;; Given an X11 event-code, return the internal event-code. ;; The internal event-code is used for indexing into the following vectors: ;; *event-key-vector* *event-handler-vector* *event-send-vector* ;; Returns NIL when the event-code is for an extension that isn't handled. (declare (type display display) (type card8 code)) (declare (clx-values (or null card8))) (setq code (logand #x7f code)) (if (< code *first-extension-event-code*) code (let* ((code-offset (- code *first-extension-event-code*)) (event-extensions (display-event-extensions display)) (code (if (< code-offset (length event-extensions)) (aref event-extensions code-offset) 0))) (declare (type card8 code-offset code)) (when (zerop code) (x-cerror "Ignore the event" 'unimplemented-event :event-code code :display display)) code))) (defun get-external-event-code (display event) ;; Given an X11 event name, return the event-code (declare (type display display) (type event-key event)) (declare (clx-values card8)) (let ((code (get-event-code event))) (declare (type (or null card8) code)) (when (>= code *first-extension-event-code*) (setq code (+ *first-extension-event-code* (or (position code (display-event-extensions display)) (x-error 'undefined-event :display display :event-name event))))) code)) (defmacro extension-opcode (display name) ;; Returns the major opcode for extension NAME. ;; This is a macro to enable NAME to be interned for fast run-time ;; retrieval. ;; Note: The case of NAME is important. (let ((name-symbol (kintern name))) ;; Intern name in the keyword package `(or (second (assoc ',name-symbol (display-extension-alist ,display))) (x-error 'absent-extension :name ',name-symbol :display ,display)))) (defun initialize-extensions (display) ;; Initialize extensions for DISPLAY (let ((event-extensions (make-array 16 :element-type 'card8 :initial-element 0)) (extension-alist nil)) (declare (type vector event-extensions) (type list extension-alist)) (dolist (extension *extensions*) (let ((name (first extension)) (events (second extension))) (declare (type keyword name) (type list events)) (multiple-value-bind (major-opcode first-event first-error) (query-extension display name) (declare (type (or null card8) major-opcode first-event first-error)) (when (and major-opcode (plusp major-opcode)) (push (list name major-opcode first-event first-error) extension-alist) (when (plusp first-event) ;; When there are extension events ;; Grow extension vector when needed (let ((max-event (- (+ first-event (length events)) *first-extension-event-code*))) (declare (type card8 max-event)) (when (>= max-event (length event-extensions)) (let ((new-extensions (make-array (+ max-event 16) :element-type 'card8 :initial-element 0))) (declare (type vector new-extensions)) (replace new-extensions event-extensions) (setq event-extensions new-extensions)))) (dolist (event events) (declare (type symbol event)) (setf (aref event-extensions (- first-event *first-extension-event-code*)) (get-event-code event)) (incf first-event))))))) (setf (display-event-extensions display) event-extensions) (setf (display-extension-alist display) extension-alist))) ;; ;; Reply handlers ;; (defvar *pending-command-free-list* nil) (defun start-pending-command (display) (declare (type display display)) (let ((pending-command (or (threaded-atomic-pop *pending-command-free-list* pending-command-next pending-command) (make-pending-command)))) (declare (type pending-command pending-command)) (setf (pending-command-reply-buffer pending-command) nil) (setf (pending-command-process pending-command) (current-process)) (setf (pending-command-sequence pending-command) (ldb (byte 16 0) (1+ (buffer-request-number display)))) ;; Add the pending command to the end of the threaded list of pending ;; commands for the display. (with-event-queue-internal (display) (threaded-nconc pending-command (display-pending-commands display) pending-command-next pending-command)) pending-command)) (defun stop-pending-command (display pending-command) (declare (type display display) (type pending-command pending-command)) (with-event-queue-internal (display) ;; Remove the pending command from the threaded list of pending commands ;; for the display. (threaded-delete pending-command (display-pending-commands display) pending-command-next pending-command) ;; Deallocate any reply buffers in this pending command (loop (let ((reply-buffer (threaded-pop (pending-command-reply-buffer pending-command) reply-next reply-buffer))) (declare (type (or null reply-buffer) reply-buffer)) (if reply-buffer (deallocate-reply-buffer reply-buffer) (return nil))))) ;; Clear pointers to help the Garbage Collector (setf (pending-command-process pending-command) nil) ;; Deallocate this pending-command (threaded-atomic-push pending-command *pending-command-free-list* pending-command-next pending-command) nil) ;;; (defvar *reply-buffer-free-lists* (make-array 32 :initial-element nil)) (defun allocate-reply-buffer (size) (declare (type array-index size)) (if (index<= size +replysize+) (allocate-event) (let ((index (integer-length (index1- size)))) (declare (type array-index index)) (or (threaded-atomic-pop (svref *reply-buffer-free-lists* index) reply-next reply-buffer) (make-reply-buffer (index-ash 1 index)))))) (defun deallocate-reply-buffer (reply-buffer) (declare (type reply-buffer reply-buffer)) (let ((size (reply-size reply-buffer))) (declare (type array-index size)) (if (index<= size +replysize+) (deallocate-event reply-buffer) (let ((index (integer-length (index1- size)))) (declare (type array-index index)) (threaded-atomic-push reply-buffer (svref *reply-buffer-free-lists* index) reply-next reply-buffer))))) ;;; (defun read-error-input (display sequence reply-buffer token) (declare (type display display) (type reply-buffer reply-buffer) (type card16 sequence)) (tagbody start (with-event-queue-internal (display) (let ((command ;; Find any pending command with this sequence number. (threaded-dolist (pending-command (display-pending-commands display) pending-command-next pending-command) (when (= (pending-command-sequence pending-command) sequence) (return pending-command))))) (declare (type (or null pending-command) command)) (cond ((not (null command)) ;; Give this reply to the pending command (threaded-nconc reply-buffer (pending-command-reply-buffer command) reply-next reply-buffer) (process-wakeup (pending-command-process command))) ((member :immediately (display-report-asynchronous-errors display)) ;; No pending command and we should report the error immediately (go report-error)) (t ;; No pending command found, count this as an asynchronous error (threaded-nconc reply-buffer (display-asynchronous-errors display) reply-next reply-buffer))))) (return-from read-error-input nil) report-error (note-input-complete display token) (apply #'report-error display (prog1 (make-error display reply-buffer t) (deallocate-event reply-buffer))))) (defun read-reply-input (display sequence length reply-buffer) (declare (type display display) (type (or null reply-buffer) reply-buffer) (type card16 sequence) (type array-index length)) (unwind-protect (progn (when (index< +replysize+ length) (let ((repbuf nil)) (declare (type (or null reply-buffer) repbuf)) (unwind-protect (progn (setq repbuf (allocate-reply-buffer length)) (buffer-replace (reply-ibuf8 repbuf) (reply-ibuf8 reply-buffer) 0 +replysize+) (deallocate-event (shiftf reply-buffer repbuf nil))) (when repbuf (deallocate-reply-buffer repbuf)))) (when (buffer-input display (reply-ibuf8 reply-buffer) +replysize+ length) (return-from read-reply-input t)) (setf (reply-data-size reply-buffer) length)) (with-event-queue-internal (display) ;; Find any pending command with this sequence number. (let ((command (threaded-dolist (pending-command (display-pending-commands display) pending-command-next pending-command) (when (= (pending-command-sequence pending-command) sequence) (return pending-command))))) (declare (type (or null pending-command) command)) (when command ;; Give this reply to the pending command (threaded-nconc (shiftf reply-buffer nil) (pending-command-reply-buffer command) reply-next reply-buffer) (process-wakeup (pending-command-process command))))) nil) (when reply-buffer (deallocate-reply-buffer reply-buffer)))) (defun read-event-input (display code reply-buffer) (declare (type display display) (type card8 code) (type reply-buffer reply-buffer)) ;; Push the event in the input buffer on the display's event queue (setf (event-code reply-buffer) (get-internal-event-code display code)) (enqueue-event reply-buffer display) nil) (defun note-input-complete (display token) (declare (type display display)) (when (eq (display-input-in-progress display) token) ;; Indicate that input is no longer in progress (setf (display-input-in-progress display) nil) ;; Let the event process get the first chance to do input (let ((process (display-event-process display))) (when (not (null process)) (process-wakeup process))) ;; Then give processes waiting for command responses a chance (unless (display-input-in-progress display) (with-event-queue-internal (display) (threaded-dolist (command (display-pending-commands display) pending-command-next pending-command) (process-wakeup (pending-command-process command))))))) (defun read-input (display timeout force-output-p predicate &rest predicate-args) (declare (type display display) (type (or null number) timeout) (type generalized-boolean force-output-p) (dynamic-extent predicate-args)) (declare (type function predicate) #+clx-ansi-common-lisp (dynamic-extent predicate) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg predicate)) (let ((reply-buffer nil) (token (or (current-process) (cons nil nil)))) (declare (type (or null reply-buffer) reply-buffer)) (unwind-protect (tagbody loop (when (display-dead display) (x-error 'closed-display :display display)) (when (apply predicate predicate-args) (return-from read-input nil)) ;; Check and see if we have to force output (when (and force-output-p (or (and (not (eq (display-input-in-progress display) token)) (not (conditional-store (display-input-in-progress display) nil token))) (null (buffer-listen display)))) (go force-output)) ;; Ensure that only one process is reading input. (unless (or (eq (display-input-in-progress display) token) (conditional-store (display-input-in-progress display) nil token)) (if (eql timeout 0) (return-from read-input :timeout) (apply #'process-block "CLX Input Lock" #'(lambda (display predicate &rest predicate-args) (declare (type display display) (dynamic-extent predicate-args) (type function predicate) #+clx-ansi-common-lisp (dynamic-extent predicate) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg predicate)) (or (apply predicate predicate-args) (null (display-input-in-progress display)) (not (null (display-dead display))))) display predicate predicate-args)) (go loop)) ;; Now start gobbling. (setq reply-buffer (allocate-event)) (with-buffer-input (reply-buffer :sizes (8 16 32)) (let ((type 0)) (declare (type card8 type)) ;; Wait for input before we disallow aborts. (unless (eql timeout 0) (let ((eof-p (buffer-input-wait display timeout))) (when eof-p (return-from read-input eof-p)))) (without-aborts (let ((eof-p (buffer-input display buffer-bbuf 0 +replysize+ (if force-output-p 0 timeout)))) (when eof-p (when (eq eof-p :timeout) (if force-output-p (go force-output) (return-from read-input :timeout))) (setf (display-dead display) t) (return-from read-input eof-p))) (setf (reply-data-size reply-buffer) +replysize+) (when (= (the card8 (setq type (read-card8 0))) 1) ;; Normal replies can be longer than +replysize+, so we ;; have to handle them while aborts are still disallowed. (let ((value (read-reply-input display (read-card16 2) (index+ +replysize+ (index* (read-card32 4) 4)) (shiftf reply-buffer nil)))) (when value (return-from read-input value)) (go loop)))) (if (zerop type) (read-error-input display (read-card16 2) (shiftf reply-buffer nil) token) (read-event-input display (read-card8 0) (shiftf reply-buffer nil))))) (go loop) force-output (note-input-complete display token) (display-force-output display) (setq force-output-p nil) (go loop)) (when (not (null reply-buffer)) (deallocate-reply-buffer reply-buffer)) (note-input-complete display token)))) (defun report-asynchronous-errors (display mode) (when (and (display-asynchronous-errors display) (member mode (display-report-asynchronous-errors display))) (let ((aborted t)) (unwind-protect (loop (let ((error (with-event-queue-internal (display) (threaded-pop (display-asynchronous-errors display) reply-next reply-buffer)))) (declare (type (or null reply-buffer) error)) (if error (apply #'report-error display (prog1 (make-error display error t) (deallocate-event error))) (return (setq aborted nil))))) ;; If we get aborted out of this, deallocate all outstanding asynchronous ;; errors. (when aborted (with-event-queue-internal (display) (loop (let ((reply-buffer (threaded-pop (display-asynchronous-errors display) reply-next reply-buffer))) (declare (type (or null reply-buffer) reply-buffer)) (if reply-buffer (deallocate-event reply-buffer) (return nil)))))))))) (defun wait-for-event (display timeout force-output-p) (declare (type display display) (type (or null number) timeout) (type generalized-boolean force-output-p)) (let ((event-process-p (not (eql timeout 0)))) (declare (type generalized-boolean event-process-p)) (unwind-protect (loop (when event-process-p (conditional-store (display-event-process display) nil (current-process))) (let ((eof (read-input display timeout force-output-p #'(lambda (display) (declare (type display display)) (or (not (null (display-new-events display))) (and (display-asynchronous-errors display) (member :before-event-handling (display-report-asynchronous-errors display)) t))) display))) (when eof (return eof))) ;; Report asynchronous errors here if the user wants us to. (when event-process-p (report-asynchronous-errors display :before-event-handling)) (when (not (null (display-new-events display))) (return nil))) (when (and event-process-p (eq (display-event-process display) (current-process))) (setf (display-event-process display) nil))))) (defun read-reply (display pending-command) (declare (type display display) (type pending-command pending-command)) (loop (when (read-input display nil nil #'(lambda (pending-command) (declare (type pending-command pending-command)) (not (null (pending-command-reply-buffer pending-command)))) pending-command) (x-error 'closed-display :display display)) (let ((reply-buffer (with-event-queue-internal (display) (threaded-pop (pending-command-reply-buffer pending-command) reply-next reply-buffer)))) (declare (type reply-buffer reply-buffer)) ;; Check for error. (with-buffer-input (reply-buffer) (ecase (read-card8 0) (0 (apply #'report-error display (prog1 (make-error display reply-buffer nil) (deallocate-reply-buffer reply-buffer)))) (1 (return reply-buffer))))))) ;;; (defun event-listen (display &optional (timeout 0)) (declare (type display display) (type (or null number) timeout) (clx-values number-of-events-queued eof-or-timeout)) ;; Returns the number of events queued locally, if any, else nil. Hangs ;; waiting for events, forever if timeout is nil, else for the specified ;; number of seconds. (let* ((current-event-symbol (car (display-current-event-symbol display))) (current-event (and (boundp current-event-symbol) (symbol-value current-event-symbol))) (queue (if current-event (reply-next (the reply-buffer current-event)) (display-event-queue-head display)))) (declare (type symbol current-event-symbol) (type (or null reply-buffer) current-event queue)) (if queue (values (with-event-queue-internal (display :timeout timeout) (threaded-length queue reply-next reply-buffer)) nil) (with-event-queue (display :timeout timeout :inline t) (let ((eof-or-timeout (wait-for-event display timeout nil))) (if eof-or-timeout (values nil eof-or-timeout) (values (with-event-queue-internal (display :timeout timeout) (threaded-length (display-new-events display) reply-next reply-buffer)) nil))))))) (defun queue-event (display event-key &rest args &key append-p send-event-p &allow-other-keys) ;; The event is put at the head of the queue if append-p is nil, else the tail. ;; Additional arguments depend on event-key, and are as specified above with ;; declare-event, except that both resource-ids and resource objects are accepted ;; in the event components. (declare (type display display) (type event-key event-key) (type generalized-boolean append-p send-event-p) (dynamic-extent args)) (unless (get event-key 'event-code) (x-type-error event-key 'event-key)) (let* ((event (allocate-event)) (buffer (reply-ibuf8 event)) (event-code (get event-key 'event-code))) (declare (type reply-buffer event) (type buffer-bytes buffer) (type (or null card8) event-code)) (unless event-code (x-type-error event-key 'event-key)) (setf (event-code event) event-code) (with-display (display) (apply (svref *event-send-vector* event-code) display args) (buffer-replace buffer (display-obuf8 display) 0 +replysize+ (index+ 12 (buffer-boffset display))) (setf (aref buffer 0) (if send-event-p (logior event-code #x80) event-code) (aref buffer 2) 0 (aref buffer 3) 0)) (with-event-queue (display) (if append-p (enqueue-event event display) (with-event-queue-internal (display) (threaded-requeue event (display-event-queue-head display) (display-event-queue-tail display) reply-next reply-buffer)))))) (defun enqueue-event (new-event display) (declare (type reply-buffer new-event) (type display display)) ;; Place EVENT at the end of the event queue for DISPLAY (let* ((event-code (event-code new-event)) (event-key (and (index< event-code (length *event-key-vector*)) (svref *event-key-vector* event-code)))) (declare (type array-index event-code) (type (or null keyword) event-key)) (if (null event-key) (unwind-protect (cerror "Ignore this event" "No handler for ~s event" event-key) (deallocate-event new-event)) (with-event-queue-internal (display) (threaded-enqueue new-event (display-event-queue-head display) (display-event-queue-tail display) reply-next reply-buffer) (unless (display-new-events display) (setf (display-new-events display) new-event)))))) (defmacro define-event (name code) `(eval-when (:compile-toplevel :load-toplevel :execute) (setf (svref *event-key-vector* ,code) ',name) (setf (get ',name 'event-code) ,code))) ;; Event names. Used in "type" field in XEvent structures. Not to be ;; confused with event masks above. They start from 2 because 0 and 1 ;; are reserved in the protocol for errors and replies. */ (define-event :key-press 2) (define-event :key-release 3) (define-event :button-press 4) (define-event :button-release 5) (define-event :motion-notify 6) (define-event :enter-notify 7) (define-event :leave-notify 8) (define-event :focus-in 9) (define-event :focus-out 10) (define-event :keymap-notify 11) (define-event :exposure 12) (define-event :graphics-exposure 13) (define-event :no-exposure 14) (define-event :visibility-notify 15) (define-event :create-notify 16) (define-event :destroy-notify 17) (define-event :unmap-notify 18) (define-event :map-notify 19) (define-event :map-request 20) (define-event :reparent-notify 21) (define-event :configure-notify 22) (define-event :configure-request 23) (define-event :gravity-notify 24) (define-event :resize-request 25) (define-event :circulate-notify 26) (define-event :circulate-request 27) (define-event :property-notify 28) (define-event :selection-clear 29) (define-event :selection-request 30) (define-event :selection-notify 31) (define-event :colormap-notify 32) (define-event :client-message 33) (define-event :mapping-notify 34) (defmacro declare-event (event-codes &body declares &environment env) ;; Used to indicate the keyword arguments for handler functions in ;; process-event and event-case. ;; Generates the functions used in SEND-EVENT. ;; A compiler warning is printed when all of EVENT-CODES are not ;; defined by a preceding DEFINE-EXTENSION. ;; The body is a list of declarations, each of which has the form: ;; (type . items) Where type is a data-type, and items is a list of ;; symbol names. The item order corresponds to the order of fields ;; in the event sent by the server. An item may be a list of items. ;; In this case, each item is aliased to the same event field. ;; This is used to give all events an EVENT-WINDOW item. ;; See the INPUT file for lots of examples. (declare (type (or keyword list) event-codes) (type (alist (field-type symbol) (field-names list)) declares)) (when (atom event-codes) (setq event-codes (list event-codes))) (setq event-codes (mapcar #'canonicalize-event-name event-codes)) (let* ((keywords nil) (name (first event-codes)) (get-macro (xintern name '-event-get-macro)) (get-function (xintern name '-event-get)) (put-function (xintern name '-event-put))) (multiple-value-bind (get-code get-index get-sizes) (get-put-items 2 declares nil #'(lambda (type index item args) (flet ((event-get (type index item args) (unless (member type '(pad8 pad16)) `(,(kintern item) (,(getify type) ,index ,@args))))) (if (atom item) (event-get type index item args) (mapcan #'(lambda (item) (event-get type index item args)) item))))) (declare (ignore get-index)) (multiple-value-bind (put-code put-index put-sizes) (get-put-items 2 declares t #'(lambda (type index item args) (unless (member type '(pad8 pad16)) (if (atom item) (progn (push item keywords) `((,(putify type) ,index ,item ,@args))) (let ((names (mapcar #'(lambda (name) (kintern name)) item))) (setq keywords (append item keywords)) `((,(putify type) ,index (check-consistency ',names ,@item) ,@args))))))) (declare (ignore put-index)) `(within-definition (,name declare-event) (defun ,get-macro (display event-key variable) ;; Note: we take pains to macroexpand the get-code here to enable application ;; code to be compiled without having the CLX macros file loaded. `(let ((%buffer ,display)) (declare (ignorable %buffer)) ,(getf `(:display (the display ,display) :event-key (the keyword ,event-key) :event-code (the card8 (logand #x7f (read-card8 0))) :send-event-p (logbitp 7 (read-card8 0)) ,@',(mapcar #'(lambda (form) (clx-macroexpand form env)) get-code)) variable))) (defun ,get-function (display event handler) (declare (type display display) (type reply-buffer event)) (declare (type function handler) #+clx-ansi-common-lisp (dynamic-extent handler) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg handler)) (reading-event (event :display display :sizes (8 16 ,@get-sizes)) (funcall handler :display display :event-key (svref *event-key-vector* (event-code event)) :event-code (logand #x7f (card8-get 0)) :send-event-p (logbitp 7 (card8-get 0)) ,@get-code))) (defun ,put-function (display &key ,@(setq keywords (nreverse keywords)) &allow-other-keys) (declare (type display display)) ,(when (member 'sequence keywords) `(unless sequence (setq sequence (display-request-number display)))) (with-buffer-output (display :sizes ,put-sizes :index (index+ (buffer-boffset display) 12)) ,@put-code)) ,@(mapcar #'(lambda (name) (allocate-extension-event-code name) `(let ((event-code (or (get ',name 'event-code) (allocate-extension-event-code ',name)))) (setf (svref *event-macro-vector* event-code) (function ,get-macro)) (setf (svref *event-handler-vector* event-code) (function ,get-function)) (setf (svref *event-send-vector* event-code) (function ,put-function)))) event-codes) ',name))))) (defun check-consistency (names &rest args) ;; Ensure all args are nil or have the same value. ;; Returns the consistent non-nil value. (let ((value (car args))) (dolist (arg (cdr args)) (if value (when (and arg (not (eq arg value))) (x-error 'inconsistent-parameters :parameters (mapcan #'list names args))) (setq value arg))) value)) (declare-event (:key-press :key-release :button-press :button-release) ;; for key-press and key-release, code is the keycode ;; for button-press and button-release, code is the button number (data code) (card16 sequence) ((or null card32) time) (window root (window event-window)) ((or null window) child) (int16 root-x root-y x y) (card16 state) (boolean same-screen-p) ) (declare-event :motion-notify ((data boolean) hint-p) (card16 sequence) ((or null card32) time) (window root (window event-window)) ((or null window) child) (int16 root-x root-y x y) (card16 state) (boolean same-screen-p)) (declare-event (:enter-notify :leave-notify) ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual)) kind) (card16 sequence) ((or null card32) time) (window root (window event-window)) ((or null window) child) (int16 root-x root-y x y) (card16 state) ((member8 :normal :grab :ungrab) mode) ((bit 0) focus-p) ((bit 1) same-screen-p)) (declare-event (:focus-in :focus-out) ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual :pointer :pointer-root :none)) kind) (card16 sequence) (window (window event-window)) ((member8 :normal :while-grabbed :grab :ungrab) mode)) (declare-event :keymap-notify ((bit-vector256 0) keymap)) (declare-event :exposure (card16 sequence) (window (window event-window)) (card16 x y width height count)) (declare-event :graphics-exposure (card16 sequence) (drawable (drawable event-window)) (card16 x y width height) (card16 minor) ;; Minor opcode (card16 count) (card8 major)) (declare-event :no-exposure (card16 sequence) (drawable (drawable event-window)) (card16 minor) (card8 major)) (declare-event :visibility-notify (card16 sequence) (window (window event-window)) ((member8 :unobscured :partially-obscured :fully-obscured) state)) (declare-event :create-notify (card16 sequence) (window (parent event-window) window) (int16 x y) (card16 width height border-width) (boolean override-redirect-p)) (declare-event :destroy-notify (card16 sequence) (window event-window window)) (declare-event :unmap-notify (card16 sequence) (window event-window window) (boolean configure-p)) (declare-event :map-notify (card16 sequence) (window event-window window) (boolean override-redirect-p)) (declare-event :map-request (card16 sequence) (window (parent event-window) window)) (declare-event :reparent-notify (card16 sequence) (window event-window window parent) (int16 x y) (boolean override-redirect-p)) (declare-event :configure-notify (card16 sequence) (window event-window window) ((or null window) above-sibling) (int16 x y) (card16 width height border-width) (boolean override-redirect-p)) (declare-event :configure-request ((data (member8 :above :below :top-if :bottom-if :opposite)) stack-mode) (card16 sequence) (window (parent event-window) window) ((or null window) above-sibling) (int16 x y) (card16 width height border-width value-mask)) (declare-event :gravity-notify (card16 sequence) (window event-window window) (int16 x y)) (declare-event :resize-request (card16 sequence) (window (window event-window)) (card16 width height)) (declare-event :circulate-notify (card16 sequence) (window event-window window parent) ((member8 :top :bottom) place)) (declare-event :circulate-request (card16 sequence) (window (parent event-window) window) (pad16 1 2) ((member8 :top :bottom) place)) (declare-event :property-notify (card16 sequence) (window (window event-window)) (keyword atom) ;; keyword ((or null card32) time) ((member8 :new-value :deleted) state)) (declare-event :selection-clear (card16 sequence) ((or null card32) time) (window (window event-window)) (keyword selection) ;; keyword ) (declare-event :selection-request (card16 sequence) ((or null card32) time) (window (window event-window) requestor) (keyword selection target) ((or null keyword) property) ) (declare-event :selection-notify (card16 sequence) ((or null card32) time) (window (window event-window)) (keyword selection target) ((or null keyword) property) ) (declare-event :colormap-notify (card16 sequence) (window (window event-window)) ((or null colormap) colormap) (boolean new-p installed-p)) (declare-event :client-message (data format) (card16 sequence) (window (window event-window)) (keyword type) ((client-message-sequence format) data)) (declare-event :mapping-notify (card16 sequence) ((member8 :modifier :keyboard :pointer) request) (card8 start) ;; first key-code (card8 count)) ;; ;; EVENT-LOOP ;; (defun event-loop-setup (display) (declare (type display display) (clx-values progv-vars progv-vals current-event-symbol current-event-discarded-p-symbol)) (let* ((progv-vars (display-current-event-symbol display)) (current-event-symbol (first progv-vars)) (current-event-discarded-p-symbol (second progv-vars))) (declare (type list progv-vars) (type symbol current-event-symbol current-event-discarded-p-symbol)) (values progv-vars (list (if (boundp current-event-symbol) ;; The current event is already bound, so bind it to the next ;; event. (let ((event (symbol-value current-event-symbol))) (declare (type (or null reply-buffer) event)) (and event (reply-next (the reply-buffer event)))) ;; The current event isn't bound, so bind it to the head of the ;; event queue. (display-event-queue-head display)) nil) current-event-symbol current-event-discarded-p-symbol))) (defun event-loop-step-before (display timeout force-output-p current-event-symbol) (declare (type display display) (type (or null number) timeout) (type generalized-boolean force-output-p) (type symbol current-event-symbol) (clx-values event eof-or-timeout)) (unless (symbol-value current-event-symbol) (let ((eof-or-timeout (wait-for-event display timeout force-output-p))) (when eof-or-timeout (return-from event-loop-step-before (values nil eof-or-timeout)))) (setf (symbol-value current-event-symbol) (display-new-events display))) (let ((event (symbol-value current-event-symbol))) (declare (type reply-buffer event)) (with-event-queue-internal (display) (when (eq event (display-new-events display)) (setf (display-new-events display) (reply-next event)))) (values event nil))) (defun dequeue-event (display event) (declare (type display display) (type reply-buffer event) (clx-values next)) ;; Remove the current event from the event queue (with-event-queue-internal (display) (let ((next (reply-next event)) (head (display-event-queue-head display))) (declare (type (or null reply-buffer) next head)) (when (eq event (display-new-events display)) (setf (display-new-events display) next)) (cond ((eq event head) (threaded-dequeue (display-event-queue-head display) (display-event-queue-tail display) reply-next reply-buffer)) ((null head) (setq next nil)) (t (do* ((previous head current) (current (reply-next previous) (reply-next previous))) ((or (null current) (eq event current)) (when (eq event current) (when (eq current (display-event-queue-tail display)) (setf (display-event-queue-tail display) previous)) (setf (reply-next previous) next))) (declare (type reply-buffer previous) (type (or null reply-buffer) current))))) next))) (defun event-loop-step-after (display event discard-p current-event-symbol current-event-discarded-p-symbol &optional aborted) (declare (type display display) (type reply-buffer event) (type generalized-boolean discard-p aborted) (type symbol current-event-symbol current-event-discarded-p-symbol)) (when (and discard-p (not aborted) (not (symbol-value current-event-discarded-p-symbol))) (discard-current-event display)) (let ((next (reply-next event))) (declare (type (or null reply-buffer) next)) (when (symbol-value current-event-discarded-p-symbol) (setf (symbol-value current-event-discarded-p-symbol) nil) (setq next (dequeue-event display event)) (deallocate-event event)) (setf (symbol-value current-event-symbol) next))) (defmacro event-loop ((display event timeout force-output-p discard-p) &body body) ;; Bind EVENT to the events for DISPLAY. ;; This is the "GUTS" of process-event and event-case. `(let ((.display. ,display) (.timeout. ,timeout) (.force-output-p. ,force-output-p) (.discard-p. ,discard-p)) (declare (type display .display.) (type (or null number) .timeout.) (type generalized-boolean .force-output-p. .discard-p.)) (with-event-queue (.display. ,@(and timeout `(:timeout .timeout.))) (multiple-value-bind (.progv-vars. .progv-vals. .current-event-symbol. .current-event-discarded-p-symbol.) (event-loop-setup .display.) (declare (type list .progv-vars. .progv-vals.) (type symbol .current-event-symbol. .current-event-discarded-p-symbol.)) (progv .progv-vars. .progv-vals. (loop (multiple-value-bind (.event. .eof-or-timeout.) (event-loop-step-before .display. .timeout. .force-output-p. .current-event-symbol.) (declare (type (or null reply-buffer) .event.)) (when (null .event.) (return (values nil .eof-or-timeout.))) (let ((.aborted. t)) (unwind-protect (progn (let ((,event .event.)) (declare (type reply-buffer ,event)) ,@body) (setq .aborted. nil)) (event-loop-step-after .display. .event. .discard-p. .current-event-symbol. .current-event-discarded-p-symbol. .aborted.)))))))))) (defun discard-current-event (display) ;; Discard the current event for DISPLAY. ;; Returns NIL when the event queue is empty, else T. ;; To ensure events aren't ignored, application code should only call ;; this when throwing out of event-case or process-next-event, or from ;; inside even-case, event-cond or process-event when :peek-p is T and ;; :discard-p is NIL. (declare (type display display) (clx-values generalized-boolean)) (let* ((symbols (display-current-event-symbol display)) (event (let ((current-event-symbol (first symbols))) (declare (type symbol current-event-symbol)) (when (boundp current-event-symbol) (symbol-value current-event-symbol))))) (declare (type list symbols) (type (or null reply-buffer) event)) (unless (null event) ;; Set the discarded-p flag (let ((current-event-discarded-p-symbol (second symbols))) (declare (type symbol current-event-discarded-p-symbol)) (when (boundp current-event-discarded-p-symbol) (setf (symbol-value current-event-discarded-p-symbol) t))) ;; Return whether the event queue is empty (not (null (reply-next (the reply-buffer event))))))) ;; ;; PROCESS-EVENT ;; (defun process-event (display &key handler timeout peek-p discard-p (force-output-p t)) ;; If force-output-p is true, first invokes display-force-output. Invokes handler ;; on each queued event until handler returns non-nil, and that returned object is ;; then returned by process-event. If peek-p is true, then the event is not ;; removed from the queue. If discard-p is true, then events for which handler ;; returns nil are removed from the queue, otherwise they are left in place. Hangs ;; until non-nil is generated for some event, or for the specified timeout (in ;; seconds, if given); however, it is acceptable for an implementation to wait only ;; once on network data, and therefore timeout prematurely. Returns nil on ;; timeout. If handler is a sequence, it is expected to contain handler functions ;; specific to each event class; the event code is used to index the sequence, ;; fetching the appropriate handler. Handler is called with raw resource-ids, not ;; with resource objects. The arguments to the handler are described using declare-event. ;; ;; T for peek-p means the event (for which the handler returns non-nil) is not removed ;; from the queue (it is left in place), NIL means the event is removed. (declare (type display display) (type (or null number) timeout) (type generalized-boolean peek-p discard-p force-output-p)) (declare (type t handler) #+clx-ansi-common-lisp (dynamic-extent handler) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg #+Genera * #-Genera handler)) (event-loop (display event timeout force-output-p discard-p) (let* ((event-code (event-code event)) ;; Event decoder defined by DECLARE-EVENT (event-decoder (and (index< event-code (length *event-handler-vector*)) (svref *event-handler-vector* event-code)))) (declare (type array-index event-code) (type (or null function) event-decoder)) (if event-decoder (let ((event-handler (if (functionp handler) handler (and (type? handler 'sequence) (< event-code (length handler)) (elt handler event-code))))) (if event-handler (let ((result (funcall event-decoder display event event-handler))) (when result (unless peek-p (discard-current-event display)) (return result))) (cerror "Ignore this event" "No handler for ~s event" (svref *event-key-vector* event-code)))) (cerror "Ignore this event" "Server Error: event with unknown event code ~d received." event-code))))) (defun make-event-handlers (&key (type 'array) default) (declare (type t type) ;Sequence type specifier (type (or null function) default) (clx-values sequence)) ;Default handler for initial content ;; Makes a handler sequence suitable for process-event (make-sequence type +max-events+ :initial-element default)) (defun event-handler (handlers event-key) (declare (type sequence handlers) (type event-key event-key) (clx-values function)) ;; Accessor for a handler sequence (elt handlers (position event-key *event-key-vector* :test #'eq))) (defun set-event-handler (handlers event-key handler) (declare (type sequence handlers) (type event-key event-key) (type function handler) (clx-values handler)) (setf (elt handlers (position event-key *event-key-vector* :test #'eq)) handler)) (defsetf event-handler set-event-handler) ;; ;; EVENT-CASE ;; (defmacro event-case ((&rest args) &body clauses) ;; If force-output-p is true, first invokes display-force-output. Executes the ;; matching clause for each queued event until a clause returns non-nil, and that ;; returned object is then returned by event-case. If peek-p is true, then the ;; event is not removed from the queue. If discard-p is true, then events for ;; which the clause returns nil are removed from the queue, otherwise they are left ;; in place. Hangs until non-nil is generated for some event, or for the specified ;; timeout (in seconds, if given); however, it is acceptable for an implementation ;; to wait only once on network data, and therefore timeout prematurely. Returns ;; nil on timeout. In each clause, event-or-events is an event-key or a list of ;; event-keys (but they need not be typed as keywords) or the symbol t or otherwise ;; (but only in the last clause). The keys are not evaluated, and it is an error ;; for the same key to appear in more than one clause. Args is the list of event ;; components of interest; corresponding values (if any) are bound to variables ;; with these names (i.e., the args are variable names, not keywords, the keywords ;; are derived from the variable names). An arg can also be a (keyword var) form, ;; as for keyword args in a lambda lists. If no t/otherwise clause appears, it is ;; equivalent to having one that returns nil. (declare (arglist (display &key timeout peek-p discard-p (force-output-p t)) (event-or-events ((&rest args) |...|) &body body) |...|)) ;; Event-case is just event-cond with the whole body in the test-form `(event-cond ,args ,@(mapcar #'(lambda (clause) `(,(car clause) ,(cadr clause) (progn ,@(cddr clause)))) clauses))) ;; ;; EVENT-COND ;; (defmacro event-cond ((display &key timeout peek-p discard-p (force-output-p t)) &body clauses) ;; The clauses of event-cond are of the form: ;; (event-or-events binding-list test-form . body-forms) ;; ;; EVENT-OR-EVENTS event-key or a list of event-keys (but they ;; need not be typed as keywords) or the symbol t ;; or otherwise (but only in the last clause). If ;; no t/otherwise clause appears, it is equivalent ;; to having one that returns nil. The keys are ;; not evaluated, and it is an error for the same ;; key to appear in more than one clause. ;; ;; BINDING-LIST The list of event components of interest. ;; corresponding values (if any) are bound to ;; variables with these names (i.e., the binding-list ;; has variable names, not keywords, the keywords are ;; derived from the variable names). An arg can also ;; be a (keyword var) form, as for keyword args in a ;; lambda list. ;; ;; The matching TEST-FORM for each queued event is executed until a ;; clause's test-form returns non-nil. Then the BODY-FORMS are ;; evaluated, returning the (possibly multiple) values of the last ;; form from event-cond. If there are no body-forms then, if the ;; test-form is non-nil, the value of the test-form is returned as a ;; single value. ;; ;; Options: ;; FORCE-OUTPUT-P When true, first invoke display-force-output if no ;; input is pending. ;; ;; PEEK-P When true, then the event is not removed from the queue. ;; ;; DISCARD-P When true, then events for which the clause returns nil ;; are removed from the queue, otherwise they are left in place. ;; ;; TIMEOUT If NIL, hang until non-nil is generated for some event's ;; test-form. Otherwise return NIL after TIMEOUT seconds have ;; elapsed. ;; (declare (arglist (display &key timeout peek-p discard-p force-output-p) (event-or-events (&rest args) test-form &body body) |...|)) (let ((event (gensym)) (disp (gensym)) (peek (gensym))) `(let ((,disp ,display) (,peek ,peek-p)) (declare (type display ,disp)) (event-loop (,disp ,event ,timeout ,force-output-p ,discard-p) (event-dispatch (,disp ,event ,peek) ,@clauses))))) (defun get-event-code (event) ;; Returns the event code given an event-key (declare (type event-key event)) (declare (clx-values card8)) (or (get event 'event-code) (x-type-error event 'event-key))) (defun universal-event-get-macro (display event-key variable) (getf `(:display (the display ,display) :event-key (the keyword ,event-key) :event-code (the card8 (logand 127 (read-card8 0))) :send-event-p (logbitp 7 (read-card8 0))) variable)) (defmacro event-dispatch ((display event peek-p) &body clauses) ;; Helper macro for event-case ;; CLAUSES are of the form: ;; (event-or-events binding-list test-form . body-forms) (let ((event-key (gensym)) (all-events (make-array +max-events+ :element-type 'bit :initial-element 0))) `(reading-event (,event) (let ((,event-key (svref *event-key-vector* (event-code ,event)))) (case ,event-key ,@(mapcar #'(lambda (clause) ; Translate event-cond clause to case clause (let* ((events (first clause)) (arglist (second clause)) (test-form (third clause)) (body-forms (cdddr clause))) (flet ((event-clause (display peek-p first-form rest-of-forms) (if rest-of-forms `(when ,first-form (unless ,peek-p (discard-current-event ,display)) (return (progn ,@rest-of-forms))) ;; No body forms, return the result of the test form (let ((result (gensym))) `(let ((,result ,first-form)) (when ,result (unless ,peek-p (discard-current-event ,display)) (return ,result))))))) (if (member events '(otherwise t)) ;; code for OTHERWISE clause. ;; Find all events NOT used by other clauses (let ((keys (do ((i 0 (1+ i)) (key nil) (result nil)) ((>= i +max-events+) result) (setq key (svref *event-key-vector* i)) (when (and key (zerop (aref all-events i))) (push key result))))) `(otherwise (binding-event-values (,display ,event-key ,(or keys :universal) ,@arglist) ,(event-clause display peek-p test-form body-forms)))) ;; Code for normal clauses (let (true-events) ;; canonicalize event-names (if (consp events) (progn (setq true-events (mapcar #'canonicalize-event-name events)) (dolist (event true-events) (setf (aref all-events (get-event-code event)) 1))) (setf true-events (canonicalize-event-name events) (aref all-events (get-event-code true-events)) 1)) `(,true-events (binding-event-values (,display ,event-key ,true-events ,@arglist) ,(event-clause display peek-p test-form body-forms)))))))) clauses)))))) (defmacro binding-event-values ((display event-key event-keys &rest value-list) &body body) ;; Execute BODY with the variables in VALUE-LIST bound to components of the ;; EVENT-KEYS events. (unless (consp event-keys) (setq event-keys (list event-keys))) (flet ((var-key (var) (kintern (if (consp var) (first var) var))) (var-symbol (var) (if (consp var) (second var) var))) ;; VARS is an alist of: ;; (component-key ((event-key event-key ...) . extraction-code) ;; ((event-key event-key ...) . extraction-code) ...) ;; There should probably be accessor macros for this, instead of things like cdadr. (let ((vars (mapcar #'list value-list)) (multiple-p nil)) ;; Fill in the VARS alist with event-keys and extraction-code (do ((keys event-keys (cdr keys)) (temp nil)) ((endp keys)) (let* ((key (car keys)) (binder (case key (:universal #'universal-event-get-macro) (otherwise (svref *event-macro-vector* (get-event-code key)))))) (dolist (var vars) (let ((code (funcall binder display event-key (var-key (car var))))) (unless code (warn "~a isn't a component of the ~s event" (var-key (car var)) key)) (if (setq temp (member code (cdr var) :key #'cdr :test #'equal)) (push key (caar temp)) (push `((,key) . ,code) (cdr var))))))) ;; Bind all the values `(let ,(mapcar #'(lambda (var) (if (cddr var) ;; if more than one binding form (progn (setq multiple-p t) (var-symbol (car var))) (list (var-symbol (car var)) (cdadr var)))) vars) ;; When some values come from different places, generate code to set them ,(when multiple-p `(case ,event-key ,@(do ((keys event-keys (cdr keys)) (clauses nil) ;; alist of (event-keys bindings) (clause nil nil) (temp)) ((endp keys) (dolist (clause clauses) (unless (cdar clause) ;; Atomize single element lists (setf (car clause) (caar clause)))) clauses) ;; Gather up all the bindings associated with (car keys) (dolist (var vars) (when (cddr var) ;; when more than one binding form (dolist (events (cdr var)) (when (member (car keys) (car events)) ;; Optimize for event-window being the same as some other binding (if (setq temp (member (cdr events) clause :key #'caddr :test #'equal)) (setq clause (nconc clause `((setq ,(car var) ,(second (car temp)))))) (push `(setq ,(car var) ,(cdr events)) clause)))))) ;; Merge bindings for (car keys) with other bindings (when clause (if (setq temp (member clause clauses :key #'cdr :test #'equal)) (push (car keys) (caar temp)) (push `((,(car keys)) . ,clause) clauses)))))) ,@body)))) ;;;----------------------------------------------------------------------------- ;;; Error Handling ;;;----------------------------------------------------------------------------- (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *xerror-vector* '#(unknown-error request-error ; 1 bad request code value-error ; 2 integer parameter out of range window-error ; 3 parameter not a Window pixmap-error ; 4 parameter not a Pixmap atom-error ; 5 parameter not an Atom cursor-error ; 6 parameter not a Cursor font-error ; 7 parameter not a Font match-error ; 8 parameter mismatch drawable-error ; 9 parameter not a Pixmap or Window access-error ; 10 attempt to access private resource" alloc-error ; 11 insufficient resources colormap-error ; 12 no such colormap gcontext-error ; 13 parameter not a GContext id-choice-error ; 14 invalid resource ID for this connection name-error ; 15 font or color name does not exist length-error ; 16 request length incorrect; ; internal Xlib error implementation-error ; 17 server is defective )) ) (defun make-error (display event asynchronous) (declare (type display display) (type reply-buffer event) (type generalized-boolean asynchronous)) (reading-event (event) (let* ((error-code (read-card8 1)) (error-key (get-error-key display error-code)) (error-decode-function (get error-key 'error-decode-function)) (params (funcall error-decode-function display event))) (list* error-code error-key :asynchronous asynchronous :current-sequence (display-request-number display) params)))) (defun report-error (display error-code error-key &rest params) (declare (type display display) (dynamic-extent params)) ;; All errors (synchronous and asynchronous) are processed by calling ;; an error handler in the display. The handler is called with the display ;; as the first argument and the error-key as its second argument. If handler is ;; an array it is expected to contain handler functions specific to ;; each error; the error code is used to index the array, fetching the ;; appropriate handler. Any results returned by the handler are ignored;; ;; it is assumed the handler either takes care of the error completely, ;; or else signals. For all core errors, additional keyword/value argument ;; pairs are: ;; :major integer ;; :minor integer ;; :sequence integer ;; :current-sequence integer ;; :asynchronous (member t nil) ;; For :colormap, :cursor, :drawable, :font, :GContext, :id-choice, :pixmap, and :window ;; errors another pair is: ;; :resource-id integer ;; For :atom errors, another pair is: ;; :atom-id integer ;; For :value errors, another pair is: ;; :value integer (let* ((handler (display-error-handler display)) (handler-function (if (type? handler 'sequence) (elt handler error-code) handler))) (apply handler-function display error-key params))) (defun request-name (code &optional display) (if (< code (length *request-names*)) (svref *request-names* code) (dolist (extension (and display (display-extension-alist display)) "unknown") (when (= code (second extension)) (return (first extension)))))) #-(or clx-ansi-common-lisp excl lcl3.0 CMU) (define-condition request-error (x-error) ((display :reader request-error-display) (error-key :reader request-error-error-key) (major :reader request-error-major) (minor :reader request-error-minor) (sequence :reader request-error-sequence) (current-sequence :reader request-error-current-sequence) (asynchronous :reader request-error-asynchronous)) (:report report-request-error)) (defun report-request-error (condition stream) (let ((error-key (request-error-error-key condition)) (asynchronous (request-error-asynchronous condition)) (major (request-error-major condition)) (minor (request-error-minor condition)) (sequence (request-error-sequence condition)) (current-sequence (request-error-current-sequence condition))) (format stream "~:[~;Asynchronous ~]~a in ~:[request ~d (last request was ~d) ~;current request~2* ~] Code ~d.~d [~a]" asynchronous error-key (= sequence current-sequence) sequence current-sequence major minor (request-name major (request-error-display condition))))) ;; Since the :report arg is evaluated as (function report-request-error) the ;; define-condition must come after the function definition. #+(or clx-ansi-common-lisp excl lcl3.0 CMU) (define-condition request-error (x-error) ((display :reader request-error-display :initarg :display) (error-key :reader request-error-error-key :initarg :error-key) (major :reader request-error-major :initarg :major) (minor :reader request-error-minor :initarg :minor) (sequence :reader request-error-sequence :initarg :sequence) (current-sequence :reader request-error-current-sequence :initarg :current-sequence) (asynchronous :reader request-error-asynchronous :initarg :asynchronous)) (:report report-request-error)) (define-condition resource-error (request-error) ((resource-id :reader resource-error-resource-id :initarg :resource-id)) (:report (lambda (condition stream) (report-request-error condition stream) (format stream " ID #x~x" (resource-error-resource-id condition))))) (define-condition unknown-error (request-error) ((error-code :reader unknown-error-error-code :initarg :error-code)) (:report (lambda (condition stream) (report-request-error condition stream) (format stream " Error Code ~d." (unknown-error-error-code condition))))) (define-condition access-error (request-error) ()) (define-condition alloc-error (request-error) ()) (define-condition atom-error (request-error) ((atom-id :reader atom-error-atom-id :initarg :atom-id)) (:report (lambda (condition stream) (report-request-error condition stream) (format stream " Atom-ID #x~x" (atom-error-atom-id condition))))) (define-condition colormap-error (resource-error) ()) (define-condition cursor-error (resource-error) ()) (define-condition drawable-error (resource-error) ()) (define-condition font-error (resource-error) ()) (define-condition gcontext-error (resource-error) ()) (define-condition id-choice-error (resource-error) ()) (define-condition illegal-request-error (request-error) ()) (define-condition length-error (request-error) ()) (define-condition match-error (request-error) ()) (define-condition name-error (request-error) ()) (define-condition pixmap-error (resource-error) ()) (define-condition value-error (request-error) ((value :reader value-error-value :initarg :value)) (:report (lambda (condition stream) (report-request-error condition stream) (format stream " Value ~d." (value-error-value condition))))) (define-condition window-error (resource-error)()) (define-condition implementation-error (request-error) ()) ;;----------------------------------------------------------------------------- ;; Internal error conditions signaled by CLX (define-condition x-type-error (type-error x-error) ((type-string :reader x-type-error-type-string :initarg :type-string)) (:report (lambda (condition stream) (format stream "~s isn't a ~a" (type-error-datum condition) (or (x-type-error-type-string condition) (type-error-expected-type condition)))))) (define-condition closed-display (x-error) ((display :reader closed-display-display :initarg :display)) (:report (lambda (condition stream) (format stream "Attempt to use closed display ~s" (closed-display-display condition))))) (define-condition lookup-error (x-error) ((id :reader lookup-error-id :initarg :id) (display :reader lookup-error-display :initarg :display) (type :reader lookup-error-type :initarg :type) (object :reader lookup-error-object :initarg :object)) (:report (lambda (condition stream) (format stream "ID ~d from display ~s should have been a ~s, but was ~s" (lookup-error-id condition) (lookup-error-display condition) (lookup-error-type condition) (lookup-error-object condition))))) (define-condition connection-failure (x-error) ((major-version :reader connection-failure-major-version :initarg :major-version) (minor-version :reader connection-failure-minor-version :initarg :minor-version) (host :reader connection-failure-host :initarg :host) (display :reader connection-failure-display :initarg :display) (reason :reader connection-failure-reason :initarg :reason)) (:report (lambda (condition stream) (format stream "Connection failure to X~d.~d server ~a display ~d: ~a" (connection-failure-major-version condition) (connection-failure-minor-version condition) (connection-failure-host condition) (connection-failure-display condition) (connection-failure-reason condition))))) (define-condition reply-length-error (x-error) ((reply-length :reader reply-length-error-reply-length :initarg :reply-length) (expected-length :reader reply-length-error-expected-length :initarg :expected-length) (display :reader reply-length-error-display :initarg :display)) (:report (lambda (condition stream) (format stream "Reply length was ~d when ~d words were expected for display ~s" (reply-length-error-reply-length condition) (reply-length-error-expected-length condition) (reply-length-error-display condition))))) (define-condition reply-timeout (x-error) ((timeout :reader reply-timeout-timeout :initarg :timeout) (display :reader reply-timeout-display :initarg :display)) (:report (lambda (condition stream) (format stream "Timeout after waiting ~d seconds for a reply for display ~s" (reply-timeout-timeout condition) (reply-timeout-display condition))))) (define-condition sequence-error (x-error) ((display :reader sequence-error-display :initarg :display) (req-sequence :reader sequence-error-req-sequence :initarg :req-sequence) (msg-sequence :reader sequence-error-msg-sequence :initarg :msg-sequence)) (:report (lambda (condition stream) (format stream "Reply out of sequence for display ~s.~% Expected ~d, Got ~d" (sequence-error-display condition) (sequence-error-req-sequence condition) (sequence-error-msg-sequence condition))))) (define-condition unexpected-reply (x-error) ((display :reader unexpected-reply-display :initarg :display) (msg-sequence :reader unexpected-reply-msg-sequence :initarg :msg-sequence) (req-sequence :reader unexpected-reply-req-sequence :initarg :req-sequence) (length :reader unexpected-reply-length :initarg :length)) (:report (lambda (condition stream) (format stream "Display ~s received a server reply when none was expected.~@ Last request sequence ~d Reply Sequence ~d Reply Length ~d bytes." (unexpected-reply-display condition) (unexpected-reply-req-sequence condition) (unexpected-reply-msg-sequence condition) (unexpected-reply-length condition))))) (define-condition missing-parameter (x-error) ((parameter :reader missing-parameter-parameter :initarg :parameter)) (:report (lambda (condition stream) (let ((parm (missing-parameter-parameter condition))) (if (consp parm) (format stream "One or more of the required parameters ~a is missing." parm) (format stream "Required parameter ~a is missing or null." parm)))))) ;; This can be signalled anywhere a pseudo font access fails. (define-condition invalid-font (x-error) ((font :reader invalid-font-font :initarg :font)) (:report (lambda (condition stream) (format stream "Can't access font ~s" (invalid-font-font condition))))) (define-condition device-busy (x-error) ((display :reader device-busy-display :initarg :display)) (:report (lambda (condition stream) (format stream "Device busy for display ~s" (device-busy-display condition))))) (define-condition unimplemented-event (x-error) ((display :reader unimplemented-event-display :initarg :display) (event-code :reader unimplemented-event-event-code :initarg :event-code)) (:report (lambda (condition stream) (format stream "Event code ~d not implemented for display ~s" (unimplemented-event-event-code condition) (unimplemented-event-display condition))))) (define-condition undefined-event (x-error) ((display :reader undefined-event-display :initarg :display) (event-name :reader undefined-event-event-name :initarg :event-name)) (:report (lambda (condition stream) (format stream "Event code ~d undefined for display ~s" (undefined-event-event-name condition) (undefined-event-display condition))))) (define-condition absent-extension (x-error) ((name :reader absent-extension-name :initarg :name) (display :reader absent-extension-display :initarg :display)) (:report (lambda (condition stream) (format stream "Extension ~a isn't defined for display ~s" (absent-extension-name condition) (absent-extension-display condition))))) (define-condition inconsistent-parameters (x-error) ((parameters :reader inconsistent-parameters-parameters :initarg :parameters)) (:report (lambda (condition stream) (format stream "inconsistent-parameters:~{ ~s~}" (inconsistent-parameters-parameters condition))))) (define-condition resource-ids-exhausted (x-error) () (:report (lambda (condition stream) (declare (ignore condition)) (format stream "All X resource IDs are in use.")))) (defun get-error-key (display error-code) (declare (type display display) (type array-index error-code)) ;; Return the error-key associated with error-code (if (< error-code (length *xerror-vector*)) (svref *xerror-vector* error-code) ;; Search the extensions for the error (dolist (entry (display-extension-alist display) 'unknown-error) (let* ((event-name (first entry)) (first-error (fourth entry)) (errors (third (assoc event-name *extensions*)))) (declare (type keyword event-name) (type array-index first-error) (type list errors)) (when (and errors (index<= first-error error-code (index+ first-error (index- (length errors) 1)))) (return (nth (index- error-code first-error) errors))))))) (defmacro define-error (error-key function) ;; Associate a function with ERROR-KEY which will be called with ;; parameters DISPLAY and REPLY-BUFFER and ;; returns a plist of keyword/value pairs which will be passed on ;; to the error handler. A compiler warning is printed when ;; ERROR-KEY is not defined in a preceding DEFINE-EXTENSION. ;; Note: REPLY-BUFFER may used with the READING-EVENT and READ-type ;; macros for getting error fields. See DECODE-CORE-ERROR for ;; an example. (declare (type symbol error-key) (type (or symbol list) function)) ;; First ensure the name is for a declared extension (unless (or (find error-key *xerror-vector*) (dolist (extension *extensions*) (when (member error-key (third extension)) (return t)))) (x-type-error error-key 'error-key)) `(setf (get ',error-key 'error-decode-function) (function ,function))) ;; All core errors use this, so we make it available to extensions. (defun decode-core-error (display event &optional arg) ;; All core errors have the following keyword/argument pairs: ;; :major integer ;; :minor integer ;; :sequence integer ;; In addition, many have an additional argument that comes from the ;; same place in the event, but is named differently. When the ARG ;; argument is specified, the keyword ARG with card32 value starting ;; at byte 4 of the event is returned with the other keyword/argument ;; pairs. (declare (type display display) (type reply-buffer event) (type (or null keyword) arg)) (declare (clx-values keyword/arg-plist)) display (reading-event (event) (let* ((sequence (read-card16 2)) (minor-code (read-card16 8)) (major-code (read-card8 10)) (result (list :major major-code :minor minor-code :sequence sequence))) (when arg (setq result (list* arg (read-card32 4) result))) result))) (defun decode-resource-error (display event) (decode-core-error display event :resource-id)) (define-error unknown-error (lambda (display event) (list* :error-code (aref (reply-ibuf8 event) 1) (decode-core-error display event)))) (define-error request-error decode-core-error) ; 1 bad request code (define-error value-error ; 2 integer parameter out of range (lambda (display event) (decode-core-error display event :value))) (define-error window-error decode-resource-error) ; 3 parameter not a Window (define-error pixmap-error decode-resource-error) ; 4 parameter not a Pixmap (define-error atom-error ; 5 parameter not an Atom (lambda (display event) (decode-core-error display event :atom-id))) (define-error cursor-error decode-resource-error) ; 6 parameter not a Cursor (define-error font-error decode-resource-error) ; 7 parameter not a Font (define-error match-error decode-core-error) ; 8 parameter mismatch (define-error drawable-error decode-resource-error) ; 9 parameter not a Pixmap or Window (define-error access-error decode-core-error) ; 10 attempt to access private resource" (define-error alloc-error decode-core-error) ; 11 insufficient resources (define-error colormap-error decode-resource-error) ; 12 no such colormap (define-error gcontext-error decode-resource-error) ; 13 parameter not a GContext (define-error id-choice-error decode-resource-error) ; 14 invalid resource ID for this connection (define-error name-error decode-core-error) ; 15 font or color name does not exist (define-error length-error decode-core-error) ; 16 request length incorrect; ; internal Xlib error (define-error implementation-error decode-core-error) ; 17 server is defective cl-clx-sbcl-0.7.4.20160323.orig/glx.lisp0000644000175000017500000005327212715665272015316 0ustar pdmpdm(defpackage :glx (:use :common-lisp :xlib) (:import-from :xlib "DEFINE-ACCESSOR" "DEF-CLX-CLASS" "DECLARE-EVENT" "ALLOCATE-RESOURCE-ID" "DEALLOCATE-RESOURCE-ID" "PRINT-DISPLAY-NAME" "WITH-BUFFER-REQUEST" "WITH-BUFFER-REQUEST-AND-REPLY" "READ-CARD32" "WRITE-CARD32" "CARD32-GET" "CARD8-GET" "SEQUENCE-GET" "SEQUENCE-PUT" "DATA" ;; Types "ARRAY-INDEX" "BUFFER-BYTES" "WITH-DISPLAY" "BUFFER-FLUSH" "BUFFER-WRITE" "BUFFER-FORCE-OUTPUT" "ASET-CARD8" "ASET-CARD16" "ASET-CARD32" ) (:export ;; Constants "+VENDOR+" "+VERSION+" "+EXTENSIONS+" ;; Conditions "BAD-CONTEXT" "BAD-CONTEXT-STATE" "BAD-DRAWABLE" "BAD-PIXMAP" "BAD-CONTEXT-TAG" "BAD-CURRENT-WINDOW" "BAD-RENDER-REQUEST" "BAD-LARGE-REQUEST" "UNSUPPORTED-PRIVATE-REQUEST" "BAD-FB-CONFIG" "BAD-PBUFFER" "BAD-CURRENT-DRAWABLE" "BAD-WINDOW" ;; Requests "QUERY-VERSION" "QUERY-SERVER-STRING" "CREATE-CONTEXT" "DESTROY-CONTEXT" "IS-DIRECT" "QUERY-CONTEXT" "GET-DRAWABLE-ATTRIBUTES" "MAKE-CURRENT" ;;"GET-VISUAL-CONFIGS" "CHOOSE-VISUAL" "VISUAL-ATTRIBUTE" "VISUAL-ID" "RENDER" "SWAP-BUFFERS" "WAIT-GL" "WAIT-X" )) (in-package :glx) (declaim (optimize (debug 3) (safety 3))) (define-extension "GLX" :events (:glx-pbuffer-clobber) :errors (bad-context bad-context-state bad-drawable bad-pixmap bad-context-tag bad-current-window bad-render-request bad-large-request unsupported-private-request bad-fb-config bad-pbuffer bad-current-drawable bad-window)) ;;; Opcodes. (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +render+ 1) (defconstant +create-context+ 3) (defconstant +destroy-context+ 4) (defconstant +make-current+ 5) (defconstant +is-direct+ 6) (defconstant +query-version+ 7) (defconstant +wait-gl+ 8) (defconstant +wait-x+ 9) (defconstant +copy-context+ 10) (defconstant +swap-buffers+ 11) (defconstant +get-visual-configs+ 14) (defconstant +destroy-glx-pixmap+ 15) (defconstant +query-server-string+ 19) (defconstant +client-info+ 20) (defconstant +get-fb-configs+ 21) (defconstant +query-context+ 25) (defconstant +get-drawable-attributes+ 29) ) ;;; Constants (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +vendor+ 1) (defconstant +version+ 2) (defconstant +extensions+ 3) ) ;;; Types ;;; FIXME: ;;; - Are all the 32-bit values unsigned? Do we care? ;;; - These are not used much, yet. (progn (deftype attribute-pair ()) (deftype bitfield () 'mask32) (deftype bool32 () 'card32) ; 1 for true and 0 for false (deftype enum () 'card32) (deftype fbconfigid () 'card32) ;; FIXME: How to define these two? (deftype float32 () 'single-float) (deftype float64 () 'double-float) ;;(deftype glx-context () 'card32) (deftype context-tag () 'card32) ;;(deftype glx-drawable () 'card32) (deftype glx-pixmap () 'card32) (deftype glx-pbuffer () 'card32) (deftype glx-render-command () #|TODO|#) (deftype glx-window () 'card32) #-(and) (deftype visual-property () "An ordered list of 32-bit property values followed by unordered pairs of property types and property values." ;; FIXME: maybe CLX-LIST or even just LIST? 'clx-sequence)) ;;; FIXME: DEFINE-ACCESSOR interns getter and setter in XLIB package ;;; (using XINTERN). Therefore the accessors defined below can only ;;; be accessed using double-colon, which is a bad style. Or these ;;; forms must be taken to another file so the accessors exist before ;;; we get to this file. #-(and) (define-accessor glx-context-tag (32) ((index) `(read-card32 ,index)) ((index thing) `(write-card32 ,index ,thing))) #-(and) (define-accessor glx-enum (32) ((index) `(read-card32 ,index)) ((index thing) `(write-card32 ,index ,thing))) ;;; FIXME: I'm just not sure we need a seperate accessors for what ;;; essentially are aliases for other types. Maybe use compiler ;;; macros? ;;; ;;; This trick won't do because CLX wants e.g. CONTEXT-TAG to be a ;;; known accessor. The only trick left I think is to change the ;;; XINTERN function to intern the new symbols in the same package as ;;; he symbol part of it comes from. Don't know if it would break ;;; anything, thought. (I would be quite surprised if it did -- there ;;; is only one package in CLX after all: XLIB.) ;;; ;;; I also found the origin of the error (about symbol not being a ;;; known accessor): INDEX-INCREMENT function. Looks like all we have ;;; to do is to add an XLIB::BYTE-WIDTH property to the type symbol ;;; plist. But accessors are macros, not functions, anyway. #-(and) (progn (declaim (inline context-tag-get context-tag-put enum-get enum-put)) (defun context-tag-get (index) (card32-get index)) (defun context-tag-put (index thing) (card32-put index thing)) (defun enum-get (index) (card32-get index)) (defun enum-put (index thing) (card32-put index thing)) ) ;;; Structures (def-clx-class (context (:constructor %make-context) (:print-function print-context) (:copier nil)) (id 0 :type resource-id) (display nil :type (or null display)) (tag 0 :type card32) (drawable nil :type (or null drawable)) ;; TODO: There can only be one current context (as far as I ;; understand). If so, we'd need only one buffer (otherwise it's a ;; big waste to have a quarter megabyte buffer for each context; or ;; we could allocate/grow the buffer on demand). ;; ;; 256k buffer for Render command. Big requests are served with ;; RenderLarge command. First 8 octets are Render request fields. ;; (rbuf (make-array (+ 8 (* 256 1024)) :element-type '(unsigned-byte 8)) :type buffer-bytes) ;; Index into RBUF where the next rendering command should be inserted. (index 8 :type array-index)) (defun print-context (ctx stream depth) (declare (type context ctx) (ignore depth)) (print-unreadable-object (ctx stream :type t) (print-display-name (context-display ctx) stream) (write-string " " stream) (princ (context-id ctx) stream))) (def-clx-class (visual (:constructor %make-visual) (:print-function print-visual) (:copier nil)) (id 0 :type resource-id) (attributes nil :type list)) (defun print-visual (visual stream depth) (declare (type visual visual) (ignore depth)) (print-unreadable-object (visual stream :type t) (write-string "ID: " stream) (princ (visual-id visual) stream) (write-string " " stream) (princ (visual-attributes visual) stream))) ;;; Events. (defconstant +damaged+ #x8017) (defconstant +saved+ #x8018) (defconstant +window+ #x8019) (defconstant +pbuffer+ #x801a) (declare-event :glx-pbuffer-clobber (card16 sequence) (card16 event-type) ;; +DAMAGED+ or +SAVED+ (card16 draw-type) ;; +WINDOW+ or +PBUFFER+ (resource-id drawable) ;; FIXME: (bitfield buffer-mask) (card32 buffer-mask) (card16 aux-buffer) (card16 x y width height count)) ;;; Errors. (define-condition bad-context (request-error) ()) (define-condition bad-context-state (request-error) ()) (define-condition bad-drawable (request-error) ()) (define-condition bad-pixmap (request-error) ()) (define-condition bad-context-tag (request-error) ()) (define-condition bad-current-window (request-error) ()) (define-condition bad-render-request (request-error) ()) (define-condition bad-large-request (request-error) ()) (define-condition unsupported-private-request (request-error) ()) (define-condition bad-fb-config (request-error) ()) (define-condition bad-pbuffer (request-error) ()) (define-condition bad-current-drawable (request-error) ()) (define-condition bad-window (request-error) ()) (define-error bad-context decode-core-error) (define-error bad-context-state decode-core-error) (define-error bad-drawable decode-core-error) (define-error bad-pixmap decode-core-error) (define-error bad-context-tag decode-core-error) (define-error bad-current-window decode-core-error) (define-error bad-render-request decode-core-error) (define-error bad-large-request decode-core-error) (define-error unsupported-private-request decode-core-error) (define-error bad-fb-config decode-core-error) (define-error bad-pbuffer decode-core-error) (define-error bad-current-drawable decode-core-error) (define-error bad-window decode-core-error) ;;; Requests. (defun query-version (display) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +query-version+) (card32 1) (card32 3)) (values (card32-get 8) (card32-get 12)))) (defun query-server-string (display screen name) "NAME is one of +VENDOR+, +VERSION+ or +EXTENSIONS+" (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +query-server-string+) (card32 (or (position screen (display-roots display) :test #'eq) 0)) (card32 name)) (let* ((length (card32-get 12)) (bytes (sequence-get :format card8 :result-type '(simple-array card8 (*)) :index 32 :length length))) (declare (type (simple-array card8 (*)) bytes) (type fixnum length)) (map-into (make-string (1- length)) #'code-char bytes)))) (defun client-info (display) ;; TODO: This should be invoked automatically when using this ;; library in initialization stage. ;; ;; TODO: No extensions supported yet. ;; ;; *** Maybe the LENGTH field must be filled in some special way ;; (similar to data)? (with-buffer-request (display (extension-opcode display "GLX")) (data +client-info+) (card32 4) ; length of the request (card32 1) ; major (card32 3) ; minor (card32 0) ; n )) ;;; XXX: This looks like an internal thing. Should name appropriately. (defun make-context (display) (let ((ctx (%make-context :display display))) (setf (context-id ctx) (allocate-resource-id display ctx 'context)) ;; Prepare render request buffer. ctx)) (defun create-context (screen visual &optional (share-list 0) (is-direct nil)) "Do NOT use the direct mode, yet!" (let* ((root (screen-root screen)) (display (drawable-display root)) (ctx (make-context display))) (with-buffer-request (display (extension-opcode display "GLX")) (data +create-context+) (resource-id (context-id ctx)) (resource-id visual) (card32 (or (position screen (display-roots display) :test #'eq) 0)) (resource-id share-list) (boolean is-direct)) ctx)) ;;; TODO: Maybe make this var private to GLX-MAKE-CURRENT and GLX-GET-CURRENT-CONTEXT only? ;;; (defvar *current-context* nil) (defun destroy-context (ctx) (let ((id (context-id ctx)) (display (context-display ctx))) (with-buffer-request (display (extension-opcode display "GLX")) (data +destroy-context+) (resource-id id)) (deallocate-resource-id display id 'context) (setf (context-id ctx) 0) (when (eq ctx *current-context*) (setf *current-context* nil)))) (defun is-direct (ctx) (let ((display (context-display ctx))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +is-direct+) (resource-id (context-id ctx))) (card8-get 8)))) (defun query-context (ctx) ;; TODO: What are the attribute types? (let ((display (context-display ctx))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +query-context+) (resource-id (context-id ctx))) (let ((num-attributes (card32-get 8))) ;; FIXME: Is this really so? (declare (type fixnum num-attributes)) (loop repeat num-attributes for i fixnum upfrom 32 by 8 collecting (cons (card32-get i) (card32-get (+ i 4)))))))) (defun get-drawable-attributes (drawable) (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +get-drawable-attributes+) (drawable drawable)) (let ((num-attributes (card32-get 8))) ;; FIXME: Is this really so? (declare (type fixnum num-attributes)) (loop repeat num-attributes for i fixnum upfrom 32 by 8 collecting (cons (card32-get i) (card32-get (+ i 4)))))))) ;;; TODO: What is the idea behind passing drawable to this function? ;;; Can a context be made current for different drawables at different ;;; times? (Man page on glXMakeCurrent says that context's viewport ;;; is set to the size of drawable when creating; it does not change ;;; afterwards.) ;;; (defun make-current (drawable ctx) (let ((display (drawable-display drawable)) (old-tag (if *current-context* (context-tag *current-context*) 0))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +make-current+) (resource-id (drawable-id drawable)) (resource-id (context-id ctx)) ;; *** CARD32 is really a CONTEXT-TAG (card32 old-tag)) (let ((new-tag (card32-get 8))) (setf (context-tag ctx) new-tag (context-drawable ctx) drawable (context-display ctx) display *current-context* ctx))))) ;;; FIXME: Decide how to represent and use these. (eval-when (:load-toplevel :compile-toplevel :execute) (macrolet ((generate-config-properties () (let ((list '((:glx-visual visual-id) (:glx-class card32) (:glx-rgba bool32) (:glx-red-size card32) (:glx-green-size card32) (:glx-blue-size card32) (:glx-alpha-size card32) (:glx-accum-red-size card32) (:glx-accum-green-size card32) (:glx-accum-blue-size card32) (:glx-accum-alpha-size card32) (:glx-double-buffer bool32) (:glx-stereo bool32) (:glx-buffer-size card32) (:glx-depth-size card32) (:glx-stencil-size card32) (:glx-aux-buffers card32) (:glx-level int32)))) `(progn ,@(loop for (symbol type) in list collect `(setf (get ',symbol 'visual-config-property-type) ',type)) (defparameter *visual-config-properties* (map 'vector #'car ',list)) (declaim (type simple-vector *visual-config-properties*)) (deftype visual-config-property () '(member ,@(mapcar #'car list))))))) (generate-config-properties))) (defun make-visual (attributes) (let ((id-cons (first attributes))) (assert (eq :glx-visual (car id-cons)) (id-cons) "GLX visual id must be first in attributes list!") (%make-visual :id (cdr id-cons) :attributes (rest attributes)))) (defun visual-attribute (visual attribute) (assert (or (numberp attribute) (find attribute *visual-config-properties*)) (attribute) "~S is not a known GLX visual attribute." attribute) (cdr (assoc attribute (visual-attributes visual)))) ;;; TODO: Make this return nice structured objects with field values of correct type. ;;; FIXME: Looks like every other result is corrupted. (defun get-visual-configs (screen) (let ((display (drawable-display (screen-root screen)))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +get-visual-configs+) (card32 (or (position screen (display-roots display) :test #'eq) 0))) (let* ((num-visuals (card32-get 8)) (num-properties (card32-get 12)) (num-ordered (length *visual-config-properties*))) ;; FIXME: Is this really so? (declare (type fixnum num-ordered num-visuals num-properties)) (loop with index fixnum = 28 repeat num-visuals collecting (make-visual (nconc (when (<= num-ordered num-properties) (map 'list #'(lambda (property) (cons property (card32-get (incf index 4)))) *visual-config-properties*)) (when (< num-ordered num-properties) (loop repeat (/ (- num-properties num-ordered) 2) collecting (cons (card32-get (incf index 4)) (card32-get (incf index 4)))))))))))) (defun choose-visual (screen attributes) "ATTRIBUTES is a list of desired attributes for a visual. The elements may be either a symbol, which means that the boolean attribute with that name must be true; or it can be a list of the form: (attribute-name value &optional (test '<=)) which means that the attribute named attribute-name must satisfy the test when applied to the given value and attribute's value in visual. Example: '(:glx-rgba (:glx-alpha-size 4) :glx-double-buffer (:glx-class 4 =)." ;; TODO: Add type checks ;; ;; TODO: This function checks only supplied attributes; should check ;; all attributes, with default for boolean type being false, and ;; for number types zero. ;; ;; TODO: Make this smarter, like the docstring says, instead of ;; parrotting the inflexible C API. ;; (flet ((visual-matches-p (visual attributes) (dolist (attribute attributes t) (etypecase attribute (symbol (not (null (visual-attribute visual attribute)))) (cons (<= (second attribute) (visual-attribute visual (car attribute)))))))) (let* ((visuals (get-visual-configs screen)) (candidates (loop for visual in visuals when (visual-matches-p visual attributes) collect visual)) (result (first candidates))) (dolist (candidate (rest candidates)) ;; Visuals with glx-class 3 (pseudo-color) and 4 (true-color) ;; are preferred over glx-class 2 (static-color) and 5 (direct-color). (let ((class (visual-attribute candidate :glx-class))) (when (or (= class 3) (= class 4)) (setf result candidate)))) result))) (defun render () (declare (optimize (debug 3))) (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx)) (rbuf (context-rbuf ctx)) (index (context-index ctx))) (declare (type buffer-bytes rbuf) (type array-index index)) (when (< 8 index) (with-display (display) ;; Flush display's buffer first so we don't get messed up with X requests. (buffer-flush display) ;; First, update the Render request fields. (aset-card8 (extension-opcode display "GLX") rbuf 0) (aset-card8 1 rbuf 1) (aset-card16 (ceiling index 4) rbuf 2) (aset-card32 (context-tag ctx) rbuf 4) ;; Then send the request. (buffer-write rbuf display 0 (context-index ctx)) ;; Start filling from the beginning (setf (context-index ctx) 8))) (values))) (defun swap-buffers () (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) ;; Make sure all rendering commands are sent away. (glx:render) (with-buffer-request (display (extension-opcode display "GLX")) (data +swap-buffers+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx)) (resource-id (drawable-id (context-drawable ctx)))) (display-force-output display))) ;;; FIXME: These two are more complicated than sending messages. As I ;;; understand it, wait-gl should inhibit any X requests until all GL ;;; requests are sent... (defun wait-gl () (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request (display (extension-opcode display "GLX")) (data +wait-gl+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx))))) (defun wait-x () (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request (display (extension-opcode display "GLX")) (data +wait-x+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx))))) cl-clx-sbcl-0.7.4.20160323.orig/extensions/0000755000175000017500000000000012715665272016021 5ustar pdmpdmcl-clx-sbcl-0.7.4.20160323.orig/extensions/composite.lisp0000644000175000017500000001144312715665272020717 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- ;;; --------------------------------------------------------------------------- ;;; Title: Composite Extension ;;; Created: 2014-11-17 ;;; Author: Johannes Martinez ;;; --------------------------------------------------------------------------- ;;; ;;; (c) copyright 2014 by Johannes Martinez ;;; ;;; 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. ;;; (in-package :xlib) (export '(composite-query-version composite-redirect-window composite-redirect-subwindows composite-unredirect-window composite-unredirect-subwindows composite-get-overlay-window )) (define-extension "Composite") (defconstant +composite-major+ 0) (defconstant +composite-minor+ 4) (defconstant +redirect-automatic+ 0) (defconstant +redirect-manual+ 1) ;; xrequests (defconstant +composite-QueryVersion+ 0) (defconstant +composite-RedirectWindow+ 1) (defconstant +composite-RedirectSubwindows+ 2) (defconstant +composite-UnredirectWindow+ 3) (defconstant +composite-UnredirectSubwindows+ 4) (defconstant +composite-CreateRegionFromBorderClip+ 5) (defconstant +composite-NameWindowPixmap+ 6) (defconstant +composite-GetOverlayWindow+ 7) (defconstant +composite-ReleaseOverlayWindow+ 8) (defmacro composite-opcode (display) `(extension-opcode ,display "Composite")) ;; types (deftype update-type () '(card8)) ;; x requests (defun composite-query-version (display) "" (declare (type display display)) (with-buffer-request-and-reply (display (composite-opcode display) nil :sizes (32)) ((data +composite-QueryVersion+) (card32 +composite-major+) (card32 +composite-minor+)) (values (card32-get 8) (card32-get 12)))) (defun composite-redirect-window (window update-type) "" (let ((display (window-display window))) (declare (type display display) (type window window) (type update-type update-type)) (with-buffer-request (display (composite-opcode display)) (data +composite-redirectwindow+) (window window) (card8 update-type) (card8 0) (card16 0)))) (defun composite-redirect-subwindows (window update-type) "" (let ((display (window-display window))) (declare (type display display) (type window window) (type update-type update-type)) (with-buffer-request (display (composite-opcode display)) (data +composite-redirectsubwindows+) (window window) (card8 update-type) (card8 0) (card16 0)))) (defun composite-unredirect-window (window) "" (let ((display (window-display window))) (declare (type display display) (type window window)) (with-buffer-request (display (composite-opcode display)) (data +composite-unredirectwindow+) (window window)))) (defun composite-unredirect-subwindows (window) "" (let ((display (window-display window))) (declare (type display display) (type window window)) (with-buffer-request (display (composite-opcode display)) (data +composite-unredirectsubwindows+) (window window)))) (defun composite-create-region-from-border-clip (window region) "" (let ((display (window-display window))) (declare (type display display) (type window window)) (with-buffer-request (display (composite-opcode display)) (data +composite-createregionfromborderclip+) (card32 region) (window window)))) (defun composite-name-window-pixmap (window drawable) "" (let ((display (window-display window))) (declare (type display display) (type window window)) (with-buffer-request (display (composite-opcode display)) ((data +composite-namewindowpixmap+) (window window) (drawable drawable))))) (defun composite-get-overlay-window (window) "" (let ((display (window-display window))) (declare (type display display) (type window window)) (with-buffer-request-and-reply (display (composite-opcode display) nil :sizes (32)) ((data +composite-getoverlaywindow+) (window window) ) (values (card32-get 8))))) (defun composite-release-overlay-window (window) "" (let ((display (window-display window)))) (declare (type display display) (type window window)) (with-buffer-request (display (composite-opcode display)) ((data +composite-releaseoverlaywindow+) (window window)))) cl-clx-sbcl-0.7.4.20160323.orig/extensions/screensaver.lisp0000644000175000017500000000532012715665272021232 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- ;;; --------------------------------------------------------------------------- ;;; Title: X11 MIT Screensaver extension ;;; Created: 2005-08-28 01:41 ;;; Author: Istvan Marko ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2005 by Istvan Marko ;;; ;;; 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. ;;; ;;; Description: ;;; ;;; This is a partial interface to the MIT-SCREEN-SAVER ;;; extension. Only the ScreenSaverQueryVersion and ;;; ScreenSaverQueryInfo requests are implemented because I couldn't ;;; think of a use for the rest. In fact, the only use I see for this ;;; extension is screen-saver-get-idle which provides and easy way to ;;; find out how long has it been since the last keyboard or mouse ;;; activity. ;;; A description of this extension can be found at ;;; doc/hardcopy/saver/saver.PS.gz in the X11 distribution. (in-package :xlib) (export '(screen-saver-query-version screen-saver-query-info screen-saver-get-idle) :xlib) (define-extension "MIT-SCREEN-SAVER") (defun screen-saver-query-version (display) (with-buffer-request-and-reply (display (extension-opcode display "MIT-SCREEN-SAVER") nil) ((data 0) (card8 1) ;client major version (card8 0) ;client minor version (card16 0)) ; unused (values (card16-get 8) ; server major version (card16-get 10)))) ; server minor version (defun screen-saver-query-info (display drawable) (with-buffer-request-and-reply (display (extension-opcode display "MIT-SCREEN-SAVER") nil) ((data 1) (drawable drawable)) (values (card8-get 1) ; state: off, on, disabled (window-get 8) ; screen saver window if active (card32-get 12) ; tilorsince msecs. how soon before the screen saver kicks in or how long has it been active (card32-get 16) ; idle msecs (card8-get 24)))) ; kind: Blanked, Internal, External (defun screen-saver-get-idle (display drawable) "How long has it been since the last keyboard or mouse input" (multiple-value-bind (state window tilorsince idle kind) (screen-saver-query-info display drawable) (declare (ignore state window kind)) (values idle tilorsince))) cl-clx-sbcl-0.7.4.20160323.orig/extensions/glx.lisp0000644000175000017500000005327212715665272017515 0ustar pdmpdm(defpackage :glx (:use :common-lisp :xlib) (:import-from :xlib "DEFINE-ACCESSOR" "DEF-CLX-CLASS" "DECLARE-EVENT" "ALLOCATE-RESOURCE-ID" "DEALLOCATE-RESOURCE-ID" "PRINT-DISPLAY-NAME" "WITH-BUFFER-REQUEST" "WITH-BUFFER-REQUEST-AND-REPLY" "READ-CARD32" "WRITE-CARD32" "CARD32-GET" "CARD8-GET" "SEQUENCE-GET" "SEQUENCE-PUT" "DATA" ;; Types "ARRAY-INDEX" "BUFFER-BYTES" "WITH-DISPLAY" "BUFFER-FLUSH" "BUFFER-WRITE" "BUFFER-FORCE-OUTPUT" "ASET-CARD8" "ASET-CARD16" "ASET-CARD32" ) (:export ;; Constants "+VENDOR+" "+VERSION+" "+EXTENSIONS+" ;; Conditions "BAD-CONTEXT" "BAD-CONTEXT-STATE" "BAD-DRAWABLE" "BAD-PIXMAP" "BAD-CONTEXT-TAG" "BAD-CURRENT-WINDOW" "BAD-RENDER-REQUEST" "BAD-LARGE-REQUEST" "UNSUPPORTED-PRIVATE-REQUEST" "BAD-FB-CONFIG" "BAD-PBUFFER" "BAD-CURRENT-DRAWABLE" "BAD-WINDOW" ;; Requests "QUERY-VERSION" "QUERY-SERVER-STRING" "CREATE-CONTEXT" "DESTROY-CONTEXT" "IS-DIRECT" "QUERY-CONTEXT" "GET-DRAWABLE-ATTRIBUTES" "MAKE-CURRENT" ;;"GET-VISUAL-CONFIGS" "CHOOSE-VISUAL" "VISUAL-ATTRIBUTE" "VISUAL-ID" "RENDER" "SWAP-BUFFERS" "WAIT-GL" "WAIT-X" )) (in-package :glx) (declaim (optimize (debug 3) (safety 3))) (define-extension "GLX" :events (:glx-pbuffer-clobber) :errors (bad-context bad-context-state bad-drawable bad-pixmap bad-context-tag bad-current-window bad-render-request bad-large-request unsupported-private-request bad-fb-config bad-pbuffer bad-current-drawable bad-window)) ;;; Opcodes. (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +render+ 1) (defconstant +create-context+ 3) (defconstant +destroy-context+ 4) (defconstant +make-current+ 5) (defconstant +is-direct+ 6) (defconstant +query-version+ 7) (defconstant +wait-gl+ 8) (defconstant +wait-x+ 9) (defconstant +copy-context+ 10) (defconstant +swap-buffers+ 11) (defconstant +get-visual-configs+ 14) (defconstant +destroy-glx-pixmap+ 15) (defconstant +query-server-string+ 19) (defconstant +client-info+ 20) (defconstant +get-fb-configs+ 21) (defconstant +query-context+ 25) (defconstant +get-drawable-attributes+ 29) ) ;;; Constants (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +vendor+ 1) (defconstant +version+ 2) (defconstant +extensions+ 3) ) ;;; Types ;;; FIXME: ;;; - Are all the 32-bit values unsigned? Do we care? ;;; - These are not used much, yet. (progn (deftype attribute-pair ()) (deftype bitfield () 'mask32) (deftype bool32 () 'card32) ; 1 for true and 0 for false (deftype enum () 'card32) (deftype fbconfigid () 'card32) ;; FIXME: How to define these two? (deftype float32 () 'single-float) (deftype float64 () 'double-float) ;;(deftype glx-context () 'card32) (deftype context-tag () 'card32) ;;(deftype glx-drawable () 'card32) (deftype glx-pixmap () 'card32) (deftype glx-pbuffer () 'card32) (deftype glx-render-command () #|TODO|#) (deftype glx-window () 'card32) #-(and) (deftype visual-property () "An ordered list of 32-bit property values followed by unordered pairs of property types and property values." ;; FIXME: maybe CLX-LIST or even just LIST? 'clx-sequence)) ;;; FIXME: DEFINE-ACCESSOR interns getter and setter in XLIB package ;;; (using XINTERN). Therefore the accessors defined below can only ;;; be accessed using double-colon, which is a bad style. Or these ;;; forms must be taken to another file so the accessors exist before ;;; we get to this file. #-(and) (define-accessor glx-context-tag (32) ((index) `(read-card32 ,index)) ((index thing) `(write-card32 ,index ,thing))) #-(and) (define-accessor glx-enum (32) ((index) `(read-card32 ,index)) ((index thing) `(write-card32 ,index ,thing))) ;;; FIXME: I'm just not sure we need a seperate accessors for what ;;; essentially are aliases for other types. Maybe use compiler ;;; macros? ;;; ;;; This trick won't do because CLX wants e.g. CONTEXT-TAG to be a ;;; known accessor. The only trick left I think is to change the ;;; XINTERN function to intern the new symbols in the same package as ;;; he symbol part of it comes from. Don't know if it would break ;;; anything, thought. (I would be quite surprised if it did -- there ;;; is only one package in CLX after all: XLIB.) ;;; ;;; I also found the origin of the error (about symbol not being a ;;; known accessor): INDEX-INCREMENT function. Looks like all we have ;;; to do is to add an XLIB::BYTE-WIDTH property to the type symbol ;;; plist. But accessors are macros, not functions, anyway. #-(and) (progn (declaim (inline context-tag-get context-tag-put enum-get enum-put)) (defun context-tag-get (index) (card32-get index)) (defun context-tag-put (index thing) (card32-put index thing)) (defun enum-get (index) (card32-get index)) (defun enum-put (index thing) (card32-put index thing)) ) ;;; Structures (def-clx-class (context (:constructor %make-context) (:print-function print-context) (:copier nil)) (id 0 :type resource-id) (display nil :type (or null display)) (tag 0 :type card32) (drawable nil :type (or null drawable)) ;; TODO: There can only be one current context (as far as I ;; understand). If so, we'd need only one buffer (otherwise it's a ;; big waste to have a quarter megabyte buffer for each context; or ;; we could allocate/grow the buffer on demand). ;; ;; 256k buffer for Render command. Big requests are served with ;; RenderLarge command. First 8 octets are Render request fields. ;; (rbuf (make-array (+ 8 (* 256 1024)) :element-type '(unsigned-byte 8)) :type buffer-bytes) ;; Index into RBUF where the next rendering command should be inserted. (index 8 :type array-index)) (defun print-context (ctx stream depth) (declare (type context ctx) (ignore depth)) (print-unreadable-object (ctx stream :type t) (print-display-name (context-display ctx) stream) (write-string " " stream) (princ (context-id ctx) stream))) (def-clx-class (visual (:constructor %make-visual) (:print-function print-visual) (:copier nil)) (id 0 :type resource-id) (attributes nil :type list)) (defun print-visual (visual stream depth) (declare (type visual visual) (ignore depth)) (print-unreadable-object (visual stream :type t) (write-string "ID: " stream) (princ (visual-id visual) stream) (write-string " " stream) (princ (visual-attributes visual) stream))) ;;; Events. (defconstant +damaged+ #x8017) (defconstant +saved+ #x8018) (defconstant +window+ #x8019) (defconstant +pbuffer+ #x801a) (declare-event :glx-pbuffer-clobber (card16 sequence) (card16 event-type) ;; +DAMAGED+ or +SAVED+ (card16 draw-type) ;; +WINDOW+ or +PBUFFER+ (resource-id drawable) ;; FIXME: (bitfield buffer-mask) (card32 buffer-mask) (card16 aux-buffer) (card16 x y width height count)) ;;; Errors. (define-condition bad-context (request-error) ()) (define-condition bad-context-state (request-error) ()) (define-condition bad-drawable (request-error) ()) (define-condition bad-pixmap (request-error) ()) (define-condition bad-context-tag (request-error) ()) (define-condition bad-current-window (request-error) ()) (define-condition bad-render-request (request-error) ()) (define-condition bad-large-request (request-error) ()) (define-condition unsupported-private-request (request-error) ()) (define-condition bad-fb-config (request-error) ()) (define-condition bad-pbuffer (request-error) ()) (define-condition bad-current-drawable (request-error) ()) (define-condition bad-window (request-error) ()) (define-error bad-context decode-core-error) (define-error bad-context-state decode-core-error) (define-error bad-drawable decode-core-error) (define-error bad-pixmap decode-core-error) (define-error bad-context-tag decode-core-error) (define-error bad-current-window decode-core-error) (define-error bad-render-request decode-core-error) (define-error bad-large-request decode-core-error) (define-error unsupported-private-request decode-core-error) (define-error bad-fb-config decode-core-error) (define-error bad-pbuffer decode-core-error) (define-error bad-current-drawable decode-core-error) (define-error bad-window decode-core-error) ;;; Requests. (defun query-version (display) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +query-version+) (card32 1) (card32 3)) (values (card32-get 8) (card32-get 12)))) (defun query-server-string (display screen name) "NAME is one of +VENDOR+, +VERSION+ or +EXTENSIONS+" (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +query-server-string+) (card32 (or (position screen (display-roots display) :test #'eq) 0)) (card32 name)) (let* ((length (card32-get 12)) (bytes (sequence-get :format card8 :result-type '(simple-array card8 (*)) :index 32 :length length))) (declare (type (simple-array card8 (*)) bytes) (type fixnum length)) (map-into (make-string (1- length)) #'code-char bytes)))) (defun client-info (display) ;; TODO: This should be invoked automatically when using this ;; library in initialization stage. ;; ;; TODO: No extensions supported yet. ;; ;; *** Maybe the LENGTH field must be filled in some special way ;; (similar to data)? (with-buffer-request (display (extension-opcode display "GLX")) (data +client-info+) (card32 4) ; length of the request (card32 1) ; major (card32 3) ; minor (card32 0) ; n )) ;;; XXX: This looks like an internal thing. Should name appropriately. (defun make-context (display) (let ((ctx (%make-context :display display))) (setf (context-id ctx) (allocate-resource-id display ctx 'context)) ;; Prepare render request buffer. ctx)) (defun create-context (screen visual &optional (share-list 0) (is-direct nil)) "Do NOT use the direct mode, yet!" (let* ((root (screen-root screen)) (display (drawable-display root)) (ctx (make-context display))) (with-buffer-request (display (extension-opcode display "GLX")) (data +create-context+) (resource-id (context-id ctx)) (resource-id visual) (card32 (or (position screen (display-roots display) :test #'eq) 0)) (resource-id share-list) (boolean is-direct)) ctx)) ;;; TODO: Maybe make this var private to GLX-MAKE-CURRENT and GLX-GET-CURRENT-CONTEXT only? ;;; (defvar *current-context* nil) (defun destroy-context (ctx) (let ((id (context-id ctx)) (display (context-display ctx))) (with-buffer-request (display (extension-opcode display "GLX")) (data +destroy-context+) (resource-id id)) (deallocate-resource-id display id 'context) (setf (context-id ctx) 0) (when (eq ctx *current-context*) (setf *current-context* nil)))) (defun is-direct (ctx) (let ((display (context-display ctx))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +is-direct+) (resource-id (context-id ctx))) (card8-get 8)))) (defun query-context (ctx) ;; TODO: What are the attribute types? (let ((display (context-display ctx))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +query-context+) (resource-id (context-id ctx))) (let ((num-attributes (card32-get 8))) ;; FIXME: Is this really so? (declare (type fixnum num-attributes)) (loop repeat num-attributes for i fixnum upfrom 32 by 8 collecting (cons (card32-get i) (card32-get (+ i 4)))))))) (defun get-drawable-attributes (drawable) (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +get-drawable-attributes+) (drawable drawable)) (let ((num-attributes (card32-get 8))) ;; FIXME: Is this really so? (declare (type fixnum num-attributes)) (loop repeat num-attributes for i fixnum upfrom 32 by 8 collecting (cons (card32-get i) (card32-get (+ i 4)))))))) ;;; TODO: What is the idea behind passing drawable to this function? ;;; Can a context be made current for different drawables at different ;;; times? (Man page on glXMakeCurrent says that context's viewport ;;; is set to the size of drawable when creating; it does not change ;;; afterwards.) ;;; (defun make-current (drawable ctx) (let ((display (drawable-display drawable)) (old-tag (if *current-context* (context-tag *current-context*) 0))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +make-current+) (resource-id (drawable-id drawable)) (resource-id (context-id ctx)) ;; *** CARD32 is really a CONTEXT-TAG (card32 old-tag)) (let ((new-tag (card32-get 8))) (setf (context-tag ctx) new-tag (context-drawable ctx) drawable (context-display ctx) display *current-context* ctx))))) ;;; FIXME: Decide how to represent and use these. (eval-when (:load-toplevel :compile-toplevel :execute) (macrolet ((generate-config-properties () (let ((list '((:glx-visual visual-id) (:glx-class card32) (:glx-rgba bool32) (:glx-red-size card32) (:glx-green-size card32) (:glx-blue-size card32) (:glx-alpha-size card32) (:glx-accum-red-size card32) (:glx-accum-green-size card32) (:glx-accum-blue-size card32) (:glx-accum-alpha-size card32) (:glx-double-buffer bool32) (:glx-stereo bool32) (:glx-buffer-size card32) (:glx-depth-size card32) (:glx-stencil-size card32) (:glx-aux-buffers card32) (:glx-level int32)))) `(progn ,@(loop for (symbol type) in list collect `(setf (get ',symbol 'visual-config-property-type) ',type)) (defparameter *visual-config-properties* (map 'vector #'car ',list)) (declaim (type simple-vector *visual-config-properties*)) (deftype visual-config-property () '(member ,@(mapcar #'car list))))))) (generate-config-properties))) (defun make-visual (attributes) (let ((id-cons (first attributes))) (assert (eq :glx-visual (car id-cons)) (id-cons) "GLX visual id must be first in attributes list!") (%make-visual :id (cdr id-cons) :attributes (rest attributes)))) (defun visual-attribute (visual attribute) (assert (or (numberp attribute) (find attribute *visual-config-properties*)) (attribute) "~S is not a known GLX visual attribute." attribute) (cdr (assoc attribute (visual-attributes visual)))) ;;; TODO: Make this return nice structured objects with field values of correct type. ;;; FIXME: Looks like every other result is corrupted. (defun get-visual-configs (screen) (let ((display (drawable-display (screen-root screen)))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +get-visual-configs+) (card32 (or (position screen (display-roots display) :test #'eq) 0))) (let* ((num-visuals (card32-get 8)) (num-properties (card32-get 12)) (num-ordered (length *visual-config-properties*))) ;; FIXME: Is this really so? (declare (type fixnum num-ordered num-visuals num-properties)) (loop with index fixnum = 28 repeat num-visuals collecting (make-visual (nconc (when (<= num-ordered num-properties) (map 'list #'(lambda (property) (cons property (card32-get (incf index 4)))) *visual-config-properties*)) (when (< num-ordered num-properties) (loop repeat (/ (- num-properties num-ordered) 2) collecting (cons (card32-get (incf index 4)) (card32-get (incf index 4)))))))))))) (defun choose-visual (screen attributes) "ATTRIBUTES is a list of desired attributes for a visual. The elements may be either a symbol, which means that the boolean attribute with that name must be true; or it can be a list of the form: (attribute-name value &optional (test '<=)) which means that the attribute named attribute-name must satisfy the test when applied to the given value and attribute's value in visual. Example: '(:glx-rgba (:glx-alpha-size 4) :glx-double-buffer (:glx-class 4 =)." ;; TODO: Add type checks ;; ;; TODO: This function checks only supplied attributes; should check ;; all attributes, with default for boolean type being false, and ;; for number types zero. ;; ;; TODO: Make this smarter, like the docstring says, instead of ;; parrotting the inflexible C API. ;; (flet ((visual-matches-p (visual attributes) (dolist (attribute attributes t) (etypecase attribute (symbol (not (null (visual-attribute visual attribute)))) (cons (<= (second attribute) (visual-attribute visual (car attribute)))))))) (let* ((visuals (get-visual-configs screen)) (candidates (loop for visual in visuals when (visual-matches-p visual attributes) collect visual)) (result (first candidates))) (dolist (candidate (rest candidates)) ;; Visuals with glx-class 3 (pseudo-color) and 4 (true-color) ;; are preferred over glx-class 2 (static-color) and 5 (direct-color). (let ((class (visual-attribute candidate :glx-class))) (when (or (= class 3) (= class 4)) (setf result candidate)))) result))) (defun render () (declare (optimize (debug 3))) (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx)) (rbuf (context-rbuf ctx)) (index (context-index ctx))) (declare (type buffer-bytes rbuf) (type array-index index)) (when (< 8 index) (with-display (display) ;; Flush display's buffer first so we don't get messed up with X requests. (buffer-flush display) ;; First, update the Render request fields. (aset-card8 (extension-opcode display "GLX") rbuf 0) (aset-card8 1 rbuf 1) (aset-card16 (ceiling index 4) rbuf 2) (aset-card32 (context-tag ctx) rbuf 4) ;; Then send the request. (buffer-write rbuf display 0 (context-index ctx)) ;; Start filling from the beginning (setf (context-index ctx) 8))) (values))) (defun swap-buffers () (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) ;; Make sure all rendering commands are sent away. (glx:render) (with-buffer-request (display (extension-opcode display "GLX")) (data +swap-buffers+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx)) (resource-id (drawable-id (context-drawable ctx)))) (display-force-output display))) ;;; FIXME: These two are more complicated than sending messages. As I ;;; understand it, wait-gl should inhibit any X requests until all GL ;;; requests are sent... (defun wait-gl () (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request (display (extension-opcode display "GLX")) (data +wait-gl+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx))))) (defun wait-x () (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request (display (extension-opcode display "GLX")) (data +wait-x+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx))))) cl-clx-sbcl-0.7.4.20160323.orig/extensions/xrender.lisp0000644000175000017500000014431212715665272020366 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- ;;; --------------------------------------------------------------------------- ;;; Title: The X Render Extension ;;; Created: 2002-08-03 ;;; Author: Gilbert Baumann ;;; $Id: xrender.lisp,v 1.5 2004/12/06 11:48:57 csr21 Exp $ ;;; --------------------------------------------------------------------------- ;;; ;;; (c) copyright 2002, 2003 by Gilbert Baumann ;;; (c) copyright 2002 by Christian Sunesson ;;; ;;; 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. ;;; ;;; NOTE: we need to watch maximum request sizes and somehow work ;;; around them. Sometimes e.g. in AddGlyphs this is not possible, ;;; which is a design failure. ;;; TODO ;; - some request are still to be implemented at all. ;; + Can they not wait? Xrender seems to be in flux as the specification ;; isn't even conforming to the acctual protocol. However backwards ;; wierd that sound. --noss ;; - we need to invent something for the color values of e.g. ;; fill-rectangles; I would prefer some generic functions, so that ;; we later can map CLIM design directly to colors. ;; - we want some conviencene function to turn graphics contexts into ;; render pictures. --GB 2002-08-21 ;; - also: uniform-alpha-picture display alpha-value ;; uniform-color-picture display red green blue ;; --GB 2002-08-21 ;; - maybe we should aim for a higher level interface to ;; color-trapzoids and color-triangles and offer a low level [raw] ;; interface also for high performance apps? ;; - Write tests. ;;;; API issues ;; - On one hand we want convenience functions like RENDER-TRIANGLE or ;; WITH-UNIFORM-COLOR-PICTURE. On the other hand if you are up to ;; write a full rasterization library you obviously want high ;; performance entry points as RENDER-TRIANGLES-1. ;; - We want to extend XLIB:COLOR into something with alpha channel. ;; How to name it? ;; - WITH-UNIFORM-COLOR-PICTURE (var picture r g b &optional alpha) &body body ;; ;; Example: ;; (WITH-UNIFORM-COLOR-PICTURE (color dest 1.0 1.0 0.0) ;; (RENDER-TRIANGLE dest color ...)) ;; - Pose the filter and the transform slots of a picture. ;; - Also introduce a PICTURE-DEFAULT-MASK-FORMAT? ;; - COPY-PICTURE? ;; - WITH-PICTURE-OPTIONS ? ;; ;; (WITH-PICTURE-OPTIONS (pic :repeat :on) ...) ;; - WITH-PICTURE ? ;; ;; (WITH-PICTURE (picture drawable ...) ...) ;; (in-package :xlib) ;; Beginning to collect the external interface for documentation. (export '(render-create-picture render-free-picture render-create-glyph-set render-reference-glyph-set render-free-glyph-set render-add-glyph render-add-glyph-from-picture render-free-glyph render-fill-rectangle picture-format-display picture-format-id picture-format-type picture-format-depth picture-format-red-byte picture-format-green-byte picture-format-blue-byte picture-format-alpha-byte picture-format-colormap ;; picture object picture-repeat picture-alpha-map picture-alpha-x-origin picture-alpha-y-origin picture-clip-x-origin picture-clip-y-origin picture-clip-mask picture-graphics-exposures picture-subwindow-mode picture-poly-edge picture-poly-mode picture-dither picture-component-alpha picture-drawable find-matching-picture-formats find-window-picture-format render-free-picture render-free-glyph-set render-query-version ;; render-query-picture-formats render-fill-rectangle render-triangles render-trapezoids render-composite render-create-glyph-set render-reference-glyph-set render-composite-glyphs render-add-glyph render-add-glyph-from-picture render-free-glyphs)) (pushnew :clx-ext-render *features*) (define-extension "RENDER") ;;;; Request constants ;; Note: Although version numbers are given render.h where the request ;; numbers are defined, render-query-version returns 0.0 all displays ;; i tested. --GB 2004-07-21 (defconstant +X-RenderQueryVersion+ 0) ;done (defconstant +X-RenderQueryPictFormats+ 1) (defconstant +X-RenderQueryPictIndexValues+ 2) ;0.7 (defconstant +X-RenderQueryDithers+ 3) (defconstant +X-RenderCreatePicture+ 4) ;done (defconstant +X-RenderChangePicture+ 5) ;done (defconstant +X-RenderSetPictureClipRectangles+ 6) ;done (defconstant +X-RenderFreePicture+ 7) ;done (defconstant +X-RenderComposite+ 8) ;we need better arglist (defconstant +X-RenderScale+ 9) (defconstant +X-RenderTrapezoids+ 10) ;low-level done (defconstant +X-RenderTriangles+ 11) ;low-level done (defconstant +X-RenderTriStrip+ 12) (defconstant +X-RenderTriFan+ 13) (defconstant +X-RenderColorTrapezoids+ 14) ;nyi in X server, not mentioned in renderproto.h (defconstant +X-RenderColorTriangles+ 15) ;nyi in X server, not mentioned in renderproto.h (defconstant +X-RenderTransform+ 16) ;commented out in render.h (defconstant +X-RenderCreateGlyphSet+ 17) ;done (defconstant +X-RenderReferenceGlyphSet+ 18) ;done (defconstant +X-RenderFreeGlyphSet+ 19) ;done (defconstant +X-RenderAddGlyphs+ 20) ;done, untested (defconstant +X-RenderAddGlyphsFromPicture+ 21) ;done, untested (defconstant +X-RenderFreeGlyphs+ 22) ;done, untested (defconstant +X-RenderCompositeGlyphs8+ 23) ;done (defconstant +X-RenderCompositeGlyphs16+ 24) ;done (defconstant +X-RenderCompositeGlyphs32+ 25) ;done ;; >= 0.1 (defconstant +X-RenderFillRectangles+ 26) ;single rectangle version done ;; >= 0.5 (defconstant +X-RenderCreateCursor+ 27) ;; >= 0.6 (defconstant +X-RenderSetPictureTransform+ 28) ;I don't understand what this one should do. (defconstant +X-RenderQueryFilters+ 29) ;seems to be there on server side ; some guts of its implementation there. (defconstant +X-RenderSetPictureFilter+ 30) (defconstant +X-RenderCreateAnimCursor+ 31) ;What has render to do with cursors? ;;;; ;; Sanity measures: ;; We do away with the distinction between pict-format and ;; picture-format-info. That is we cache picture-format-infos. (defstruct picture-format display (id 0 :type (unsigned-byte 29)) type depth red-byte green-byte blue-byte alpha-byte colormap) (def-clx-class (glyph-set (:copier nil) ) (id 0 :type resource-id) (display nil :type (or null display)) (plist nil :type list) ; Extension hook (format)) (defstruct render-info major-version minor-version picture-formats) (defun display-render-info (display) (getf (xlib:display-plist display) 'render-info)) (defun (setf display-render-info) (new-value display) (setf (getf (xlib:display-plist display) 'render-info) new-value)) (defun ensure-render-initialized (display) "Ensures that the RENDER extension is initialized. Should be called by every function, which attempts to generate RENDER requests." ;; xxx locking? (unless (display-render-info display) (let ((q (make-render-info))) (multiple-value-bind (maj min) (render-query-version display) (setf (render-info-major-version q) maj (render-info-minor-version q) min) (setf (render-info-picture-formats q) (make-hash-table :test #'eql)) (dolist (pf (render-query-picture-formats display)) (setf (gethash (picture-format-id pf) (render-info-picture-formats q)) pf)) (setf (display-render-info display) q))))) (defun find-matching-picture-formats (display &key depth-min depth-max depth red-min red-max red green-min green-max green blue-min blue-max blue alpha-min alpha-max alpha type colormap) ;; (ensure-render-initialized display) (let ((res nil)) (maphash (lambda (k f) (declare (ignore k)) (when (and (or (null type) (eql (picture-format-type f) type)) (or (null colormap) (eql (picture-format-colormap f) colormap)) ;; min (or (null depth-min) (>= (picture-format-depth f) depth-min)) (or (null red-min) (>= (byte-size (picture-format-red-byte f)) red-min)) (or (null green-min) (>= (byte-size (picture-format-green-byte f)) green-min)) (or (null blue-min) (>= (byte-size (picture-format-blue-byte f)) blue-min)) (or (null alpha-min) (>= (byte-size (picture-format-alpha-byte f)) alpha-min)) ;; max (or (null depth-max) (<= (picture-format-depth f) depth-max)) (or (null red-max) (<= (byte-size (picture-format-red-byte f)) red-max)) (or (null green-max) (<= (byte-size (picture-format-green-byte f)) green-max)) (or (null blue-max) (<= (byte-size (picture-format-blue-byte f)) blue-max)) (or (null alpha-max) (<= (byte-size (picture-format-alpha-byte f)) alpha-max)) ;; match (or (null depth) (= (picture-format-depth f) depth)) (or (null red) (= (byte-size (picture-format-red-byte f)) red)) (or (null green) (= (byte-size (picture-format-green-byte f)) green)) (or (null blue) (= (byte-size (picture-format-blue-byte f)) blue)) (or (null alpha) (= (byte-size (picture-format-alpha-byte f)) alpha))) (pushnew f res))) (render-info-picture-formats (display-render-info display))) res)) (defun find-window-picture-format (window) "Find the picture format which matches the given window." (let* ((vi (window-visual-info window)) (display (window-display window))) (ensure-render-initialized display) (case (visual-info-class vi) ((:true-color) (maphash (lambda (k f) (declare (ignore k)) (when (and (eql (picture-format-type f) :direct) (eql (picture-format-depth f) (drawable-depth window)) (eql (dpb -1 (picture-format-red-byte f) 0) (visual-info-red-mask vi)) (eql (dpb -1 (picture-format-green-byte f) 0) (visual-info-green-mask vi)) (eql (dpb -1 (picture-format-blue-byte f) 0) (visual-info-blue-mask vi)) (eql (byte-size (picture-format-alpha-byte f)) 0)) (return-from find-window-picture-format f))) (render-info-picture-formats (display-render-info display)))) (t )))) (eval-when (:compile-toplevel :load-toplevel :execute) (define-accessor picture (32) ((index) index :blip) ((index thing) `(resource-id-put ,index (picture-id ,thing)))) (define-accessor glyph-set (32) ((index) index :blip) ((index thing) `(resource-id-put ,index (glyph-set-id ,thing))))) ;;; picture format (defmethod print-object ((object picture-format) stream) (let ((abbrev (with-output-to-string (bag) ;; build an abbreviated representation of the format (let ((bytes (sort (list (cons "r" (picture-format-red-byte object)) (cons "g" (picture-format-green-byte object)) (cons "b" (picture-format-blue-byte object)) (cons "a" (picture-format-alpha-byte object))) #'> :key #'(lambda (x) (byte-position (cdr x)))))) (dolist (k bytes) (unless (zerop (byte-size (cdr k))) (format bag " ~A~D" (car k) (byte-size (cdr k))))))))) (print-unreadable-object (object stream :type t :identity nil) (format stream "~D ~S ~S ~S~A" (picture-format-id object) (picture-format-colormap object) (picture-format-depth object) (picture-format-type object) abbrev)))) (eval-when (:compile-toplevel :load-toplevel :execute) (define-accessor picture-format (32) ((index) `(gethash (read-card32 ,index) (render-info-picture-formats (display-render-info .display.)))) ((index thing) `(write-card32 ,index (picture-format-id ,thing)))) (define-accessor render-op (8) ((index) `(member8-get ,index :clear :src :dst :over :over-reverse :in :in-reverse :out :out-reverse :atop :atop-reverse :xor :add :saturate '#:undefined-pict-op-Eh '#:undefined-pict-op-Fh :disjoint-clear :disjoint-src :disjoint-dst :disjoint-over :disjoint-over-reverse :disjoint-in :disjoint-in-reverse :disjoint-out :disjoint-out-reverse :disjoint-atop :disjoint-atop-reverse :disjoint-xor '#:undefined-pict-op-1Ch '#:undefined-pict-op-1Dh '#:undefined-pict-op-1Eh '#:undefined-pict-op-1Fh :conjoint-clear :conjoint-src :conjoint-dst :conjoint-over :conjoint-over-reverse :conjoint-in :conjoint-in-reverse :conjoint-out :conjoint-out-reverse :conjoint-atop :conjoint-atop-reverse :conjoint-xor)) ((index thing) `(member8-put ,index ,thing :clear :src :dst :over :over-reverse :in :in-reverse :out :out-reverse :atop :atop-reverse :xor :add :saturate '#:undefined-pict-op-Eh '#:undefined-pict-op-Fh :disjoint-clear :disjoint-src :disjoint-dst :disjoint-over :disjoint-over-reverse :disjoint-in :disjoint-in-reverse :disjoint-out :disjoint-out-reverse :disjoint-atop :disjoint-atop-reverse :disjoint-xor '#:undefined-pict-op-1Ch '#:undefined-pict-op-1Dh '#:undefined-pict-op-1Eh '#:undefined-pict-op-1Fh :conjoint-clear :conjoint-src :conjoint-dst :conjoint-over :conjoint-over-reverse :conjoint-in :conjoint-in-reverse :conjoint-out :conjoint-out-reverse :conjoint-atop :conjoint-atop-reverse :conjoint-xor))) (deftype render-op () '(member :clear :src :dst :over :over-reverse :in :in-reverse :out :out-reverse :atop :atop-reverse :xor :add :saturate :disjoint-clear :disjoint-src :disjoint-dst :disjoint-over :disjoint-over-reverse :disjoint-in :disjoint-in-reverse :disjoint-out :disjoint-out-reverse :disjoint-atop :disjoint-atop-reverse :disjoint-xor :conjoint-clear :conjoint-src :conjoint-dst :conjoint-over :conjoint-over-reverse :conjoint-in :conjoint-in-reverse :conjoint-out :conjoint-out-reverse :conjoint-atop :conjoint-atop-reverse :conjoint-xor))) ;; Now these pictures objects are like graphics contexts. I was about ;; to introduce a synchronous mode, realizing that the RENDER protocol ;; provides no provision to actually query a picture object's values. ;; *sigh* (def-clx-class (picture (:copier nil)) (id 0 :type resource-id) (display nil :type (or null display)) (plist nil :type list) ; Extension hook (format) (%changed-p) (%server-values) (%values) (%drawable)) (defun picture-drawable (picture) (picture-%drawable picture)) ;; xx make id, display, format readonly (defun %render-change-picture-clip-rectangles (picture rectangles) "Dont call me, use (SETF PICTURE-CLIP-MASK) instead." (declare (optimize (speed 0))) (let ((display (picture-display picture))) (ensure-render-initialized display) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderSetPictureClipRectangles+) (picture picture) (int16 (picture-clip-x-origin picture)) (int16 (picture-clip-y-origin picture)) ((sequence :format int16) rectangles)))) (macrolet ((foo (&rest specs) `(progn ,@(loop for (type slot default) in specs for index from 0 collect `(progn (defun ,(xintern 'picture- slot) (picture) (aref (picture-%values picture) ,index)) (defun (setf ,(xintern 'picture- slot)) (new-value picture) (setf (picture-%changed-p picture) t) (setf (aref (picture-%values picture) ,index) new-value)))) (defun synchronise-picture-state (picture) (when (picture-%changed-p picture) (let ((display (picture-display picture))) (ensure-render-initialized display) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderChangePicture+) (picture picture) (mask ,@(loop for (type slot default) in specs for index from 0 collect `(,type (and ,(cond ((eql slot 'clip-mask) `(not (typep (aref (picture-%values picture) ,index) 'sequence))) (t 't)) (not (eq (aref (picture-%values picture) ,index) (aref (picture-%server-values picture) ,index))) (setf (aref (picture-%server-values picture) ,index) (aref (picture-%values picture) ,index)))))))) ,(let ((index (position 'clip-mask specs :key #'second))) `(unless (eql (aref (picture-%values picture) ,index) (aref (picture-%server-values picture) ,index)) (%render-change-picture-clip-rectangles picture (aref (picture-%values picture) ,index)) (setf (aref (picture-%server-values picture) ,index) (aref (picture-%values picture) ,index)))) (setf (picture-%changed-p picture) nil))) (defun render-create-picture (drawable &key format (picture (make-picture :display (drawable-display drawable))) ,@(loop for (type slot default-value) in specs collect (cond ((eql slot 'clip-mask) `(clip-mask :none)) (t slot))) ) ;; xxx also offer to give a colormap instead of a picture-format ;; values! (let ((display (drawable-display drawable))) (ensure-render-initialized display) (unless format ;; xxx check for drawable being a window (setf format (find-window-picture-format drawable))) (let ((pid (allocate-resource-id display picture 'picture))) (setf (picture-id picture) pid) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderCreatePicture+) (resource-id pid) (drawable drawable) (picture-format format) (mask ,@(loop for (type slot default) in specs collect (cond ((eql slot 'clip-mask) (list type `(and (not (typep clip-mask 'sequence)) clip-mask))) (t (list type slot))))))) (when (typep clip-mask 'sequence) (%render-change-picture-clip-rectangles picture clip-mask)) (setf (picture-format picture) format) (setf (picture-%server-values picture) (vector ,@(loop for (type slot default) in specs collect `(or ,slot ,default)))) (setf (picture-%values picture) (copy-seq (picture-%server-values picture))) (setf (picture-%drawable picture) drawable) picture)) (defconstant +picture-state-length+ ,(length specs)) ))) (foo ((member :off :on) repeat :off) ((or (member :none) picture) alpha-map :none) (int16 alpha-x-origin 0) (int16 alpha-y-origin 0) (int16 clip-x-origin 0) (int16 clip-y-origin 0) ;; ### Now that is not correct is it?: ((or (member :none) pixmap) clip-mask :none) ((member :off :on) graphics-exposures :on) ((member :clip-by-children :include-inferiors) subwindow-mode :clip-by-children) ((member :sharp :smooth) poly-edge :smooth) ((member :precise :imprecise) poly-mode :precise) ((or (member :none) #||xatom||#) dither :none) ((member :off :on) component-alpha :off))) (defun render-free-picture (picture) (let ((display (picture-display picture))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderFreePicture+) (picture picture)))) (defun render-free-glyph-set (glyph-set) (let ((display (glyph-set-display glyph-set))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderFreeGlyphSet+) (glyph-set glyph-set)))) (defun render-query-version (display) (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil) ((data +X-RenderQueryVersion+) (card32 0) (card32 1)) (values (card32-get 8) (card32-get 12) ))) (defun render-query-picture-formats (display) (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil) ((data +X-RenderQueryPictFormats+)) (let ((n-picture-formats (card32-get 8)) (n-screens (card32-get 12)) (n-depths (card32-get 16)) (n-visuals (card32-get 20)) (n-subpixel (card32-get 24))) (declare (ignore n-screens n-depths n-visuals n-subpixel)) (loop for i below n-picture-formats collect (let ((off (+ (* 8 4) (* i 28)))) ;size of picture-format-info (make-picture-format :display display :id (card32-get (+ off 0)) :type (member8-get (+ off 4) :indexed :direct) :depth (card8-get (+ off 5)) :red-byte (byte (integer-length (card16-get (+ off 10))) (card16-get (+ off 8))) :green-byte (byte (integer-length (card16-get (+ off 14))) (card16-get (+ off 12))) :blue-byte (byte (integer-length (card16-get (+ off 18))) (card16-get (+ off 16))) :alpha-byte (byte (integer-length (card16-get (+ off 22))) (card16-get (+ off 20))) :colormap (let ((cmid (card32-get (+ off 24)))) (unless (zerop cmid) (lookup-colormap display cmid))))))))) (defun render-fill-rectangle (picture op color x1 y1 w h) (let ((display (picture-display picture))) (ensure-render-initialized display) (synchronise-picture-state picture) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderFillRectangles+) (render-op op) (pad8 0) (pad16 0) (resource-id (picture-id picture)) (card16 (elt color 0)) (card16 (elt color 1)) (card16 (elt color 2)) (card16 (elt color 3)) (int16 x1) (int16 y1) (card16 w) (card16 h)))) ;; fill rectangles, colors. (defun render-triangles (picture op source src-x src-y format coord-sequence) ;; For performance reasons we do a special typecase on (simple-array ;; (unsigned-byte 32) (*)), so that it'll be possible to have high ;; performance rasters. (macrolet ((guts () '(let ((display (picture-display picture))) (synchronise-picture-state picture) (synchronise-picture-state source) (labels ((funk (x) (ash x 16))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderTriangles+) (render-op op) (pad8 0) (pad16 0) (resource-id (picture-id source)) (resource-id (picture-id picture)) (picture-format format) (int16 src-x) (int16 src-y) ((sequence :format int32 :transform #'funk) coord-sequence)))))) (typecase coord-sequence ((simple-array (unsigned-byte 32) (*)) (locally (declare (type (simple-array (unsigned-byte 32) (*)) coord-sequence)) (guts))) (t (guts))))) #|| (defun render-set-picture-transform (picture mxx mxy dx mxy myy dy &optional (mwx 0) (mwy 0) (dw 1)) ...) ||# (defun render-set-picture-transform (picture a b c d e f p q r) (let ((display (picture-display picture))) (ensure-render-initialized display) (synchronise-picture-state picture) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderSetPictureTransform+) #| (card8 0) ;; render-op op) ;op (card8 0) ;pad (card16 0) ;pad |# (resource-id (picture-id picture)) (card32 a) (card32 b) (card32 c) (card32 d) (card32 e) (card32 f) (card32 p) (card32 q) (card32 r)))) (defun render-query-filters (drawable) (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil) ((data +X-RenderQueryFilters+) (drawable drawable)) (let* ((len (card32-get 4)) (n-aliases (card32-get 8)) (n-filters (card32-get 12)) (off (+ (* 8 4) (* 4 (ceiling (* 2 n-aliases) 4))))) (print (list :aliases (loop for i below n-aliases collect (card16-get (+ (* 8 4) (* i 2)))))) (print (list :foo len n-aliases n-filters (loop for i below len collect (card8-get (+ off 0 (* 4 i))) collect (card8-get (+ off 1 (* 4 i))) collect (card8-get (+ off 2 (* 4 i))) collect (card8-get (+ off 3 (* 4 i)))))) (print (labels ((grab-string (j) (let ((n (card8-get j))) (incf j) (values (map 'string #'code-char (loop repeat n collect (card8-get j) do (incf j))) j)))) (loop repeat n-filters collect (multiple-value-bind (s j) (grab-string off) (setf off j) (intern (string-upcase s) :keyword))))) #+NIL (loop for i below n-picture-formats collect (let ((off (+ (* 8 4) (* i 28)))) ;size of picture-format-info (make-picture-format :display display :id (card32-get (+ off 0)) :type (member8-get (+ off 4) :indexed :direct) :depth (card8-get (+ off 5)) :red-byte (byte (integer-length (card16-get (+ off 10))) (card16-get (+ off 8))) :green-byte (byte (integer-length (card16-get (+ off 14))) (card16-get (+ off 12))) :blue-byte (byte (integer-length (card16-get (+ off 18))) (card16-get (+ off 16))) :alpha-byte (byte (integer-length (card16-get (+ off 22))) (card16-get (+ off 20))) :colormap (let ((cmid (card32-get (+ off 24)))) (unless (zerop cmid) (lookup-colormap display cmid)))))))))) (defun render-set-filter (picture filter) (let ((display (picture-display picture))) (ensure-render-initialized display) (synchronise-picture-state picture) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderSetPictureFilter+) (resource-id (picture-id picture)) (card16 (length filter)) (pad16 0) ((sequence :format card8) (map 'vector #'char-code filter))))) #|| (defun render-triangle (destination source x1 y1 x2 y2 x3 y3 &key (src-x 0) (src-y 0) (format nil) (op :over)) (render-triangles-1 destination op source ...) ) ||# (defun render-trapezoids (picture op source src-x src-y mask-format coord-sequence) ;; coord-sequence is top bottom ;; left-x1 left-y1 left-x2 left-y2 ;; right-x1 right-y1 right-x2 right-y2 ... ;; (let ((display (picture-display picture))) (synchronise-picture-state picture) (synchronise-picture-state source) (labels ((funk (x) (ash x 16))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderTrapezoids+) (render-op op) (pad8 0) (pad16 0) (resource-id (picture-id source)) (resource-id (picture-id picture)) ((or (member :none) picture-format) mask-format) (int16 src-x) (int16 src-y) ((sequence :format int32 :transform #'funk) coord-sequence))))) (defun render-composite (op source mask dest src-x src-y mask-x mask-y dst-x dst-y width height) (let ((display (picture-display source))) (synchronise-picture-state source) (when mask (synchronise-picture-state mask)) (synchronise-picture-state dest) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderComposite+) (render-op op) (pad8 0) (pad16 0) (resource-id (picture-id source)) (resource-id (if mask (picture-id mask) 0)) (resource-id (picture-id dest)) (int16 src-x) (int16 src-y) (int16 mask-x) (int16 mask-y) (int16 dst-x) (int16 dst-y) (card16 width) (card16 height)))) (defun render-create-glyph-set (format &key glyph-set) (let ((display (picture-format-display format))) (let* ((glyph-set (or glyph-set (make-glyph-set :display display))) (gsid (setf (glyph-set-id glyph-set) (allocate-resource-id display glyph-set 'glyph-set)))) (declare (ignore gsid)) (setf (glyph-set-format glyph-set) format) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderCreateGlyphSet+) (glyph-set glyph-set) (picture-format format)) glyph-set))) (defun render-reference-glyph-set (existing-glyph-set &key glyph-set) (let ((display (glyph-set-display existing-glyph-set))) (let* ((glyph-set (or glyph-set (make-glyph-set :display display))) (gsid (setf (glyph-set-id glyph-set) (allocate-resource-id display glyph-set 'glyph-set)))) (declare (ignore gsid)) (setf (glyph-set-format glyph-set) (glyph-set-format existing-glyph-set)) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderReferenceGlyphSet+) (glyph-set glyph-set) (glyph-set existing-glyph-set)) glyph-set))) (defun render-composite-glyphs-8 (dest glyph-set source dest-x dest-y sequence &key (op :over) (alu op) ;for the fun of it (src-x 0) (src-y 0) (mask-format :none) (start 0) (end (length sequence))) (let ((display (picture-display dest))) (ensure-render-initialized display) (synchronise-picture-state dest) (synchronise-picture-state source) (when (stringp sequence) ;; lazy me, but then you should not confuse glyphs with ;; characters anyway. (setf sequence (map 'vector #'char-code sequence))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderCompositeGlyphs8+) (render-op alu) (pad8 0) (pad16 0) (picture source) (picture dest) ((or (member :none) picture-format) mask-format) (glyph-set glyph-set) (int16 src-x) (int16 src-y) (card8 (- end start)) ;length of glyph elt (pad8 0) (pad16 0) (int16 dest-x) (int16 dest-y) ;dx, dy ((sequence :format card8) sequence)))) (defmacro %render-composite-glyphs (opcode type transform display dest glyph-set source dest-x dest-y sequence alu src-x src-y mask-format start end) (let ((size (ecase type (card8 1) (card16 2) (card32 4))) ;; FIXME: the last chunk for CARD8 can be 254. (chunksize (ecase type (card8 252) (card16 254) (card32 254)))) `(multiple-value-bind (nchunks leftover) (floor (- end start) ,chunksize) (let* ((payloadsize (+ (* nchunks (+ 8 (* ,chunksize ,size))) (if (> leftover 0) (+ 8 (* 4 (ceiling (* leftover ,size) 4))) 0))) (request-length (+ 7 (/ payloadsize 4)))) (declare (integer request-length)) (with-buffer-request (,display (extension-opcode ,display "RENDER") :length (* 4 request-length)) (data ,opcode) (length request-length) (render-op ,alu) (pad8 0) (pad16 0) (picture ,source) (picture ,dest) ((or (member :none) picture-format) ,mask-format) (glyph-set ,glyph-set) (int16 ,src-x) (int16 ,src-y) (progn (let ((boffset (+ buffer-boffset 28)) (start ,start) (end ,end) (dest-x ,dest-x) (dest-y ,dest-y)) (dotimes (i nchunks) (set-buffer-offset boffset) (put-items (0) (card8 ,chunksize) (card8 0) (card16 0) (int16 dest-x) (int16 dest-y) ((sequence :start start :end (+ start ,chunksize) :format ,type :transform ,transform :appending t) ,sequence)) (setq dest-x 0 dest-y 0) (incf boffset (+ 8 (* ,chunksize ,size))) (incf start ,chunksize)) (when (> leftover 0) (set-buffer-offset boffset) (put-items (0) (card8 leftover) (card8 0) (card16 0) (int16 dest-x) (int16 dest-y) ((sequence :start start :end end :format ,type :transform ,transform :appending t) ,sequence)) ;; padding? (incf boffset (+ 8 (* 4 (ceiling (* leftover ,size) 4))))) (setf (buffer-boffset ,display) boffset)))))))) (defun render-composite-glyphs (dest glyph-set source dest-x dest-y sequence &key (op :over) (alu op) ;for the fun of it (src-x 0) (src-y 0) (mask-format :none) (start 0) (end (length sequence))) ;; xxx do we want to go with some translate function as draw-glyphs? (declare (type array-index start end)) (let ((display (picture-display dest))) (ensure-render-initialized display) (synchronise-picture-state dest) (synchronise-picture-state source) ;; hmm find out the element size (typecase sequence ((array (unsigned-byte 8) (*)) (%render-composite-glyphs +X-RenderCompositeGlyphs8+ card8 nil display dest glyph-set source dest-x dest-y sequence alu src-x src-y mask-format start end)) ((array (unsigned-byte 16) (*)) (%render-composite-glyphs +X-RenderCompositeGlyphs16+ card16 nil display dest glyph-set source dest-x dest-y sequence alu src-x src-y mask-format start end)) ((array (unsigned-byte 32) (*)) (%render-composite-glyphs +X-RenderCompositeGlyphs32+ card32 nil display dest glyph-set source dest-x dest-y sequence alu src-x src-y mask-format start end)) (string (%render-composite-glyphs #.(cond ((<= char-code-limit (expt 2 8)) '+X-RenderCompositeGlyphs8+) ((<= char-code-limit (expt 2 16)) '+X-RenderCompositeGlyphs16+) ((<= char-code-limit (expt 2 32)) '+X-RenderCompositeGlyphs32+) (t (error "Wow!"))) #.(cond ((<= char-code-limit (expt 2 8)) 'card8) ((<= char-code-limit (expt 2 16)) 'card16) ((<= char-code-limit (expt 2 32)) 'card32) (t (error "Wow!"))) #'char-code display dest glyph-set source dest-x dest-y sequence alu src-x src-y mask-format start end)) (t ;; should we bother testing the array element type? (%render-composite-glyphs +X-RenderCompositeGlyphs32+ card32 #'(lambda (elt) (if (characterp elt) (char-code elt) elt)) display dest glyph-set source dest-x dest-y sequence alu src-x src-y mask-format start end))) )) ;; --- idea: Allow data to be an image to avoid unecessary consing? - noss (defun render-add-glyph (glyph-set id &key x-origin y-origin x-advance y-advance data) (let ((display (glyph-set-display glyph-set))) (ensure-render-initialized display) (let* ((w (array-dimension data 1)) (h (array-dimension data 0)) (bitmap-format (display-bitmap-format display)) (unit (bitmap-format-unit bitmap-format)) (byte-lsb-first-p (display-image-lsb-first-p display)) (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) (let* ((byte-per-line (* 4 (ceiling (* w (picture-format-depth (glyph-set-format glyph-set))) 32))) (request-length (+ 28 (* h byte-per-line)))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderAddGlyphs+) (length (ceiling request-length 4)) (glyph-set glyph-set) (card32 1) ;number glyphs (card32 id) ;id (card16 w) (card16 h) (int16 x-origin) (int16 y-origin) (int16 x-advance) (int16 y-advance) (progn (setf (buffer-boffset display) (advance-buffer-offset 28)) (let ((im (create-image :width w :height h :depth 8 :data data))) (write-image-z display im 0 0 w h byte-per-line ;padded bytes per line unit byte-lsb-first-p bit-lsb-first-p)) ))) ))) (defun render-add-glyph-from-picture (glyph-set picture &key x-origin y-origin x-advance y-advance x y width height) ;; untested, the duplication of x-origin seems bogus. ;; Still untested, but these modifications seem to be more likely, (x,y) would be the offset into the picture. ;; and orgin advance would be properties of the defined glyph. (let ((display (glyph-set-display glyph-set))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderAddGlyphsFromPicture+) (glyph-set glyph-set) (picture picture) (card16 width) (card16 height) (card16 x-origin) (card16 y-origin) (card16 x-advance) (card16 y-advance) (card16 x) (card16 y)))) ;; untested (defun render-free-glyphs (glyph-set glyphs) "This request removes glyphs from glyph-set. Each glyph must exist in glyph-set (else a Match error results)." (let ((display (glyph-set-display glyph-set))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderFreeGlyphs+) (glyph-set glyph-set) ((sequence :format card32) glyphs)))) #|| ;;; -------------------------------------------------------------------------------- ;; testing code: (defun x (op) (let ((dpy (open-display ""))) (render-query-version dpy) (unwind-protect (let* ((win (screen-root (first (display-roots dpy)))) (display dpy) (pf (find-window-picture-format win)) (pm (xlib:create-pixmap :depth (xlib:drawable-depth win) :drawable win :width 1 :height 1)) (pm.p (render-create-picture pm :format pf :repeat :on)) (win.p (render-create-picture win :format pf)) (gs (render-create-glyph-set (first (find-matching-picture-formats dpy :alpha 8 :red-max 0 :green-max 0 :blue-max 0))))) (xlib:clear-area win) (render-fill-rectangle pm.p :src (list #xFFFF 0 0 0) 0 0 100 100) (render-add-glyph gs 18 :data (make-array (list 3 3) :initial-contents '((255 000 000) (000 255 000) (000 000 255)) :element-type '(unsigned-byte 8)) :x-advance 4 :y-advance 0 :x-origin 0 :y-origin 0) (let ((w 50) (h 50)) (let ((data (make-array (list h w) :element-type '(unsigned-byte 8) :initial-element 0))) (dotimes (i w) (dotimes (j h) (setf (aref data i j) (* 3 i)))) (render-add-glyph gs 17 :data data :x-advance (+ w 2) :y-advance 0 :x-origin 0 :y-origin 0))) (render-composite-glyphs-8 win.p gs pm.p 200 330 (vector 17 18 18 17 17 17 17 17 17 17) :alu op ) ;; (display-finish-output dpy) (close-display dpy))))) (defun z (op) (let ((dpy (open-display ""))) (unwind-protect (let* ((win (screen-root (first (display-roots dpy)))) (pic (render-create-picture win)) (fmt (first (find-matching-picture-formats dpy :red-min 8 :green-min 8 :blue-min 8 :alpha-min 8))) (px (xlib:create-pixmap :width 256 :height 256 :depth (picture-format-depth fmt) :drawable win)) (px.pic (render-create-picture px :format fmt)) (px.gc (xlib:create-gcontext :drawable px))) (xlib:clear-area win) ;; (render-fill-rectangle px.pic :src (list #x8000 #x0000 #x8000 #xFFFF) 0 0 256 256) (render-composite :src pic pic px.pic 350 350 350 350 0 0 256 256) ;; (render-fill-rectangle px.pic :over (list #x8000 #x8000 #x8000 #x8000) 0 0 100 100) (render-composite :src px.pic px.pic pic 0 0 0 0 350 350 256 256) (render-fill-rectangle pic op (list #x0 #x0 #x0 #x8000) 200 200 800 800) (display-finish-output dpy)) (close-display dpy)))) ;;; ---------------------------------------------------------------------------------------------------- (defun y (op) (let ((dpy (open-display ""))) (render-query-version dpy) (unwind-protect (let* ((win (screen-root (first (display-roots dpy)))) (pic (render-create-picture win)) (px (xlib:create-pixmap :drawable win :width 256 :height 256 :depth 32)) (px.gc (xlib:create-gcontext :drawable px))) (dotimes (x 256) (dotimes (y 256) (setf (xlib:gcontext-foreground px.gc) (dpb x (byte 8 24) (dpb y (byte 8 16) (dpb y (byte 8 8) y)))) (xlib:draw-point px px.gc x y) )) (xlib:clear-area win) (let ((q (render-create-picture px :format (first (find-matching-picture-formats dpy :depth 32 :alpha 8 :red 8 :green 8 :blue 8)) :component-alpha :on :repeat :off))) (render-composite op q q pic 0 0 0 0 100 100 400 400)) (let () ;;(render-fill-rectangle pic op (list 255 255 255 255) 100 100 200 200) (display-finish-output dpy))) (close-display dpy)))) (defun zz () (let* ((dpy (xlib:open-display "")) (win (screen-root (first (display-roots dpy)))) (pic (render-create-picture win))) (xlib:clear-area win) (setf (picture-clip-mask pic) (list 100 100 200 2000)) (render-fill-rectangle pic :over (list #xFFFF 0 0 #x400) 0 0 2000 2000) (display-finish-output dpy) (close-display dpy))) ||# ;;;; Cursors (defun render-create-cursor (picture &optional (x 0) (y 0)) (let ((display (picture-display picture))) (ensure-render-initialized display) (synchronise-picture-state picture) (let* ((cursor (make-cursor :display display)) (cid (allocate-resource-id display cursor 'cursor))) (setf (cursor-id cursor) cid) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderCreateCursor+) (resource-id cid) (resource-id (picture-id picture)) (card16 x) (card16 y)) cursor))) (defun render-create-anim-cursor (cursors delays) "Create animated cursor. cursors length must be the same as delays length." (let ((display (cursor-display (first cursors)))) (ensure-render-initialized display) (let* ((cursor (make-cursor :display display)) (cid (allocate-resource-id display cursor 'cursor)) (cursors-length (length cursors)) (cursors-delays (make-list (* 2 (length cursors))))) (setf (xlib:cursor-id cursor) cid) (dotimes (i cursors-length) (setf (elt cursors-delays (* 2 i)) (cursor-id (elt cursors i)) (elt cursors-delays (1+ (* 2 i))) (elt delays i))) (xlib::with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderCreateAnimCursor+) (resource-id cid) ((sequence :format card32) cursors-delays)) cursor))) cl-clx-sbcl-0.7.4.20160323.orig/extensions/shape.lisp0000644000175000017500000001564612715665272020026 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- ;;; --------------------------------------------------------------------------- ;;; Title: X11 Shape extension ;;; Created: 1999-05-14 11:31 ;;; Author: Gilbert Baumann ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1999 by Gilbert Baumann ;;; ;;; Permission is granted to any individual or institution to use, ;;; copy, modify, and distribute this software, provided that this ;;; complete copyright and permission notice is maintained, intact, in ;;; all copies and supporting documentation. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ;;; ;;; Use xc/doc/hardcopy/Xext/shape.PS.gz obtainable from e.g. ;; ftp://ftp.xfree86.org/pub/XFree86/current/untarred/xc/hardcopy/Xext/shape.PS.gz (in-package :xlib) (export '(shape-query-version shape-rectangles shape-mask shape-combine shape-offset shape-query-extents shape-select-input shape-input-selected-p shape-get-rectangles) :xlib) (define-extension "SHAPE" :events (:shape-notify)) (declare-event :shape-notify ((data (member8 :bounding :clip)) kind) ;shape kind (card16 sequence) (window (window event-window)) ;affected window (int16 x) ;extents (int16 y) (card16 width) (card16 height) ((or null card32) time) ;timestamp (boolean shaped-p)) (defun encode-shape-kind (kind) (ecase kind (:bounding 0) (:clip 1))) (defun encode-shape-operation (operation) (ecase operation (:set 0) (:union 1) (:interset 2) (:subtract 3) (:invert 4))) (defun encode-shape-rectangle-ordering (ordering) (ecase ordering ((:unsorted :un-sorted nil) 0) ((:y-sorted) 1) ((:yx-sorted) 2) ((:yx-banded) 3))) (defun shape-query-version (display) (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") nil :sizes 16) ((data 0)) (values (card16-get 8) (card16-get 10)))) (defun shape-rectangles (window rectangles &key (kind :bounding) (x-offset 0) (y-offset 0) (operation :set) (ordering :unsorted)) (let* ((display (xlib:window-display window))) (with-buffer-request (display (extension-opcode display "SHAPE")) (data 1) (card8 (encode-shape-operation operation)) (card8 (encode-shape-kind kind)) (card8 (encode-shape-rectangle-ordering ordering)) (card8 0) ;unused (window window) (int16 x-offset) (int16 y-offset) ((sequence :format int16) rectangles)))) (defun shape-mask (window pixmap &key (kind :bounding) (x-offset 0) (y-offset 0) (operation :set)) (let* ((display (xlib:window-display window))) (with-buffer-request (display (extension-opcode display "SHAPE")) (data 2) (card8 (encode-shape-operation operation)) (card8 (encode-shape-kind kind)) (card16 0) ;unused (window window) (int16 x-offset) (int16 y-offset) ((or pixmap (member :none)) pixmap)))) (defun shape-combine (window source-window &key (kind :bounding) (source-kind :bounding) (x-offset 0) (y-offset 0) (operation :set)) (let* ((display (xlib:window-display window))) (with-buffer-request (display (extension-opcode display "SHAPE")) (data 3) (card8 (encode-shape-operation operation)) (card8 (encode-shape-kind kind)) (card8 (encode-shape-kind source-kind)) (card8 0) ;unused (window window) (int16 x-offset) (int16 y-offset) (window source-window)))) (defun shape-offset (window &key (kind :bounding) (x-offset 0) (y-offset 0)) (let* ((display (xlib:window-display window))) (with-buffer-request (display (extension-opcode display "SHAPE")) (data 4) (card8 (encode-shape-kind kind)) (card8 0) (card8 0) (card8 0) ;unused (window window) (int16 x-offset) (int16 y-offset)))) (defun shape-query-extents (window) (let* ((display (xlib:window-display window))) (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") nil :sizes (8 16 32)) ((data 5) (window window)) (values (boolean-get 8) ;bounding shaped (boolean-get 9) ;clip shaped (int16-get 12) ;bounding shape extents x (int16-get 14) ;bounding shape extents y (card16-get 16) ;bounding shape extents width (card16-get 18) ;bounding shape extents height (int16-get 20) ;clip shape extents x (int16-get 22) ;clip shape extents y (card16-get 24) ;clip shape extents width (card16-get 26))))) ;clip shape extents height (defun shape-select-input (window selected-p) (let* ((display (window-display window))) (with-buffer-request (display (extension-opcode display "SHAPE")) (data 6) (window window) (boolean selected-p)) )) (defun shape-input-selected-p (window) (let* ((display (window-display window))) (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") nil :sizes (8)) ((data 7) ;also wrong in documentation (window window)) (boolean-get 1)))) (defun shape-get-rectangles (window &optional (kind :bounding) (result-type 'list)) (let* ((display (window-display window))) (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") nil :sizes (8 16 32)) ((data 8) ;this was wrong in the specification (window window) (card8 (ecase kind (:bounding 0) (:clip 1)))) (values (sequence-get :length (print (* 4 (card32-get 8))) :result-type result-type :format int16 :index +replysize+) (ecase (card8-get 1) (0 :unsorted) (1 :y-sorted) (2 :yx-sorted) (3 :yx-banded) ))))) cl-clx-sbcl-0.7.4.20160323.orig/extensions/xinerama.lisp0000644000175000017500000000547712715665272020533 0ustar pdmpdm;;; -*- Mode: Lisp -*- ;;; ;;; Copyright (C) 2008, Julian Stecklina ;;; ;;; (( ;;; )) This file is COFFEEWARE. As long as you retain this notice ;;; | |o) you can do whatever you want with this code. If you think, ;;; |___|jgs it's worth it, you may buy the author a coffee in return. ;;; ;;; Description: ;;; ;;; This is an implementation of the XINERAMA extension. It does not ;;; include the obsolete PanoramiX calls. (defpackage "XLIB.XINERAMA" (:use "COMMON-LISP" "XLIB") (:nicknames "XINERAMA") (:import-from "XLIB" "WITH-BUFFER-REQUEST" "WITH-BUFFER-REQUEST-AND-REPLY" "DATA" "BOOLEAN" "BOOLEAN-GET" "CARD8" "CARD8-GET" "CARD16" "CARD16-GET" "CARD32" "CARD32-GET" "INT16" "INT16-GET") (:export "SCREEN-INFO" "SCREEN-INFO-NUMBER" "SCREEN-INFO-X" "SCREEN-INFO-Y" "SCREEN-INFO-WIDTH" "SCREEN-INFO-HEIGHT" "XINERAMA-QUERY-VERSION" "XINERAMA-IS-ACTIVE" "XINERAMA-QUERY-SCREENS")) (in-package "XINERAMA") (define-extension "XINERAMA") (defun xinerama-opcode (display) (extension-opcode display "XINERAMA")) (defconstant +major-version+ 1) (defconstant +minor-version+ 1) (defconstant +get-version+ 0) (defconstant +get-state+ 1) (defconstant +get-screen-count+ 2) (defconstant +get-screen-size+ 3) (defconstant +is-active+ 4) (defconstant +query-screens+ 5) (defstruct screen-info (number 0 :type (unsigned-byte 32)) (x 0 :type (signed-byte 16)) (y 0 :type (signed-byte 16)) (width 0 :type (unsigned-byte 16)) (height 0 :type (unsigned-byte 16))) (defun xinerama-query-version (display) (with-buffer-request-and-reply (display (xinerama-opcode display) nil) ((data +get-version+) (card8 +major-version+) (card8 +minor-version+)) (values (card16-get 8) ; server major version (card16-get 10)))) ; server minor version (defun xinerama-is-active (display) "Returns T, iff Xinerama is supported and active." (with-buffer-request-and-reply (display (xinerama-opcode display) nil) ((data +is-active+)) (values ;; XCB says this is actually a CARD32, but why?! (boolean-get 8)))) (defun xinerama-query-screens (display) "Returns a list of screen-info structures." (with-buffer-request-and-reply (display (xinerama-opcode display) nil) ((data +query-screens+)) (values (loop with index = 32 for number from 0 below (card32-get 8) collect (prog1 (make-screen-info :number number :x (int16-get index) :y (int16-get (+ index 2)) :width (card16-get (+ index 4)) :height (card16-get (+ index 6))) (incf index 8)))))) ;;; EOF cl-clx-sbcl-0.7.4.20160323.orig/extensions/dri2.lisp0000644000175000017500000001362412715665272017560 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- ;;; --------------------------------------------------------------------------- ;;; Title: DRI Extension ;;; Created: 2014-11-17 ;;; Author: Johannes Martinez ;;; --------------------------------------------------------------------------- ;;; ;;; (c) copyright 2014 by Johannes Martinez ;;; ;;; 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. ;;; (in-package :xlib) (export '(dri2-query-version dri2-authenticate dri2-connect dri2-get-buffersxo)) (define-extension "DRI2") (defun dri2-opcode (display) (extension-opcode display "DRI2")) ;; version (defconstant +dri-major+ 2) (defconstant +dri-minor+ 0) ;; drivers (defconstant DRI 0) (defconstant VDPAU 1) ;; 0x0 DRI2BufferFrontLeft ;; 0x1 DRI2BufferBackLeft ;; 0x2 DRI2BufferFrontRight ;; 0x3 DRI2BufferBackRight ;; 0x4 DRI2BufferDepth ;; 0x5 DRI2BufferStencil ;; 0x6 DRI2BufferAccum ;; 0x7 DRI2BufferFakeFrontLeft ;; 0x8 DRI2BufferFakeFrontRight ;; 0x9 DRI2BufferDepthStencil ;; 0xa DRI2BufferHiz ;; x requests (defconstant +dri2-query-version+ 0) (defconstant +dri2-connect+ 1) (defconstant +dri2-authenticate+ 2) (defconstant +dri2-create-drawable+ 3) (defconstant +dri2-destroy-drawable+ 4) (defconstant +dri2-get-buffers+ 5) (defconstant +dri2-copy-region+ 6) (defconstant +dri2-get-buffers-with-format+ 7) (defconstant +dri2-swap-buffers+ 8) (defconstant +dri2-get-msc+ 9) (defconstant +dri2-wait-msc+ 10) (defconstant +dri2-wait-sbc+ 11) (defconstant +dri2-swap-interval+ 12) (defconstant +dri2-get-param+ 13) ;; structs (def-clx-class (dri2-buffer (:copier nil)) (attachment 0 :type card32) (name 0 :type card32) (pitch 0 :type card32) (cpp 0 :type card32) (flags 0 :type card32)) ;; x requests (defun dri2-query-version (display) "" (with-buffer-request-and-reply (display (dri2-opcode display) nil) ((data +dri2-query-version+) (card32 +dri-major+) (card32 +dri-minor+)) (values (card32-get 8) (card32-get 12)) )) (defun dri2-connect (window driver-type) "" (let ((display (window-display window))) (with-buffer-request-and-reply (display (dri2-opcode display) nil) ((data +dri2-connect+) (window window) (card32 driver-type)) (let* ((driver-name-length (card32-get 8)) (device-name-length (card32-get 12)) (device-start (+ 32 (- 4 (mod driver-name-length 4))))) (values (string-get driver-name-length 32) (string-get device-name-length device-start)))))) (defun dri2-authenticate (window token) "" (let ((display (window-display window))) (with-buffer-request-and-reply (display (dri2-opcode display) nil) ((data +dri2-authenticate+) (window window) (card32 token)) (values (card32-get 8))))) (defun dri2-create-drawable (drawable) "" (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display (dri2-opcode display) nil) ((data +dri2-create-drawable+)) (values)))) (defun dri2-destroy-drawable (drawable) "" (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display (dri2-opcode display) nil) () (values)))) (defun dri2-get-buffers (drawable attachment-list) "" (let* ((display (drawable-display drawable)) (len (length attachment-list) ) (seq (make-array len :initial-contents attachment-list)) ) (with-buffer-request-and-reply (display (dri2-opcode display) nil) ((data +dri2-get-buffers+) (drawable drawable) (card32 len) (( sequence :format card32) seq)) ;; (let ((num (card32-get 16))) ;; (values ;; (card32-get 8) ;; (card32-get 12) ;; (loop :for buf :from 1 :to num ;; :for offset := 32 :then (+ offset 20) ;; :collect (make-dri2-buffer :attachment (card32-get offset) ;; :name (card32-get (+ offset 4)) ;; :pitch (card32-get (+ offset 8)) ;; :cpp (card32-get (+ offset 12)) ;; :flags (card32-get (+ offset 16)))))) (values (card32-get 16) (card32-get 12) (card32-get 8)) ))) (defun dri2-copy-region (drawable) "" (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display (dri2-opcode display) nil) ((data +dri2-copy-region+)) (values)))) (defun dri2-get-buffers-with-format (drawable) "" (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display (dri2-opcode display) nil) ((data +dri2-get-buffers-with-format+)) (values)))) (defun dri2-swap-buffers (drawable) "" (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display (dri2-opcode display) nil) ((data +dri2-swap-buffers+)) (values)))) (defun dri2-get-msc (drawable) "" (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display (dri2-opcode display) nil) ((data +dri2-get-msc+)) (values)))) (defun dri2-wait-msc (drawable) "" (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display (dri2-opcode display) nil) ((data +dri2-wait-msc+)) (values)))) (defun dri2-swap-interval () "" (with-buffer-request (display (dri2-opcode display)) (data +dri2-swap-interval+))) (defun dri2-get-param (drawable) "" (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display (dri2-opcode display) nil) ((data +dri2-get-param+)) (values)))) cl-clx-sbcl-0.7.4.20160323.orig/extensions/dpms.lisp0000644000175000017500000001354512715665272017665 0ustar pdmpdm ;;;; Original Author: Matthew Kennedy ;;;; ;;;; Documentation strings derived from DPMS.txt distributed with the Xorg X11 ;;;; server implementation. DPMS.txt contains the following copyright: ;;;; ;;;; Copyright (C) Digital Equipment Corporation, 1996 ;;;; ;;;; Permission to use, copy, modify, distribute, and sell this documentation ;;;; for any purpose is hereby granted without fee, provided that the above ;;;; copyright notice and this permission notice appear in all copies. Digital ;;;; Equipment Corporation makes no representations about the suitability for ;;;; any purpose of the information in this document. This documentation is ;;;; provided ``as is'' without express or implied warranty. (defpackage :dpms (:use :common-lisp) (:import-from :xlib "DEFINE-EXTENSION" "DISPLAY" "WITH-BUFFER-REQUEST-AND-REPLY" "WITH-BUFFER-REQUEST" "EXTENSION-OPCODE" "CARD8-GET" "CARD16-GET" "BOOLEAN-GET" "CARD8" "CARD16" "DATA") (:export "DPMS-GET-VERSION" "DPMS-CAPABLE" "DPMS-GET-TIMEOUTS" "DPMS-SET-TIMEOUTS" "DPMS-ENABLE" "DPMS-DISABLE" "DPMS-FORCE-LEVEL" "DPMS-INFO")) (in-package :dpms) (define-extension "DPMS") (defmacro dpms-opcode (display) `(extension-opcode ,display "DPMS")) (defconstant +get-version+ 0) (defconstant +capable+ 1) (defconstant +get-timeouts+ 2) (defconstant +set-timeouts+ 3) (defconstant +enable+ 4) (defconstant +disable+ 5) (defconstant +force-level+ 6) (defconstant +info+ 7) (defun dpms-get-version (display &optional (major-version 1) (minor-version 1)) "Return two values: the major and minor version of the DPMS implementation the server supports. If supplied, the MAJOR-VERSION and MINOR-VERSION indicate what version of the protocol the client wants the server to implement." (declare (type display display)) (with-buffer-request-and-reply (display (dpms-opcode display) nil) ((data +get-version+) (card16 major-version) (card16 minor-version)) (values (card16-get 8) (card16-get 10)))) (defun dpms-capable (display) "True if the currently running server's devices are capable of DPMS operations. The truth value of this request is implementation defined, but is generally based on the capabilities of the graphic card and monitor combination. Also, the return value in the case of heterogeneous multi-head servers is implementation defined." (declare (type display display)) (with-buffer-request-and-reply (display (dpms-opcode display) nil) ((data +capable+)) (boolean-get 8))) (defun dpms-get-timeouts (display) "Return three values: the current values of the DPMS timeout values. The timeout values are (in order returned): standby, suspend and off. All values are in units of seconds. A value of zero for any timeout value indicates that the mode is disabled." (declare (type display display)) (with-buffer-request-and-reply (display (dpms-opcode display) nil) ((data +get-timeouts+)) (values (card16-get 8) (card16-get 10) (card16-get 12)))) (defun dpms-set-timeouts (display standby suspend off) "Set the values of the DPMS timeouts. All values are in units of seconds. A value of zero for any timeout value disables that mode." (declare (type display display)) (with-buffer-request (display (dpms-opcode display)) (data +set-timeouts+) (card16 standby) (card16 suspend) (card16 off) (card16 0)) ;unused (values)) (defun dpms-enable (display) "Enable the DPMS characteristics of the server using the server's currently stored timeouts. If DPMS is already enabled, no change is affected." (declare (type display display)) (with-buffer-request (display (dpms-opcode display)) (data +enable+)) (values)) (defun dpms-disable (display) "Disable the DPMS characteristics of the server. It does not affect the core or extension screen savers. If DPMS is already disabled, no change is effected. This request is provided so that DPMS may be disabled without damaging the server's stored timeout values." (declare (type display display)) (with-buffer-request (display (dpms-opcode display)) ((data +disable+))) (values)) (defun dpms-force-level (display power-level) "Forces a specific DPMS level on the server. Valid keyword values for POWER-LEVEL are: DPMS-MODE-ON, DPMS-MODE-STANDBY, DPMS-MODE-SUSPEND and DPMS-MODE-OFF." (declare (type display display)) (with-buffer-request (display (dpms-opcode display)) (data +force-level+) (card16 (ecase power-level (:dpms-mode-on 0) (:dpms-mode-standby 1) (:dpms-mode-suspend 2) (:dpms-mode-off 3))) (card16 0)) ;unused (values)) (defun dpms-info (display) "Returns two valus: the DPMS power-level and state value for the display. State is one of the keywords DPMS-ENABLED or DPMS-DISABLED. If state is DPMS-ENABLED, then power level is returned as one of the keywords DPMS-MODE-ON, DPMS-MODE-STANDBY, DPMS-MODE-SUSPEND or DPMS-MODE-OFF. If state is DPMS-DISABLED, then power-level is undefined and returned as NIL." (declare (type display display)) (with-buffer-request-and-reply (display (dpms-opcode display) nil) ((data +info+)) (let ((state (if (boolean-get 10) :dpms-enabled :dpms-disabled))) (values (unless (eq state :dpms-disabled) (ecase (card16-get 8) (0 :dpms-mode-on) (1 :dpms-mode-standby) (2 :dpms-mode-suspend) (3 :dpms-mode-off))) state)))) ;;; Local Variables: ;;; indent-tabs-mode: nil ;;; End: cl-clx-sbcl-0.7.4.20160323.orig/extensions/big-requests.lisp0000644000175000017500000000224512715665272021327 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- ;;; ;;; (c) copyright 2006 Richard Kreuter ;;; (c) copyright 2007 by Christophe Rhodes ;;; ;;; 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. (in-package "XLIB") ;;; No new events or errors are defined by this extension. (Big ;;; Requests Extension, section 3) ;;; ;;; The name of this extension is "BIG-REQUESTS" (Big Requests ;;; Extension, section 4) (define-extension "BIG-REQUESTS") (defun enable-big-requests (display) (declare (type display display)) (let ((opcode (extension-opcode display "BIG-REQUESTS"))) (with-buffer-request-and-reply (display opcode nil) ((data 0)) (let ((maximum-request-length (card32-get 8))) (setf (display-extended-max-request-length display) maximum-request-length))))) cl-clx-sbcl-0.7.4.20160323.orig/extensions/xvidmode.lisp0000644000175000017500000007063312715665272020542 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- ;;; --------------------------------------------------------------------------- ;;; Title: XFree86 video mode extension ;;; Created: 2003 03 28 15:28 ;;; Author: Iban Hatchondo ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2003 by Iban Hatchondo ;;; ;;; 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. ;;; ;;; THIS IS NOT AN X CONSORTIUM STANDARD OR AN X PROJECT TEAM SPECIFICATION ;;; DESCRIPTION ;;; ;;; These functions provide an interface to the server extension ;;; XFree86-VidModeExtension which allows the video modes to be ;;; queried, adjusted dynamically and the mode switching to be ;;; controlled. ;;; [ personal notes ] ;;; ;;; The documentation on this extension is very poor, probably, ;;; because it is not an X standard nor an X project team spec. ;;; Because of that, it need to be tested on some XFree 3.3.6, ;;; and XFree 4.3.x to ensure that all request are correctly ;;; constructed as well as to indentify any obsolete/wrong ;;; functions I made. (in-package :xlib) (export '(mode-info mode-info-dotclock mode-info-hdisplay mode-info-hsyncstart mode-info-hsyncend mode-info-htotal mode-info-hskew mode-info-vdisplay mode-info-vsyncstart mode-info-vsyncend mode-info-vtotal mode-info-flags mode-info-privsize mode-info-private make-mode-info xfree86-vidmode-query-version xfree86-vidmode-set-client-version xfree86-vidmode-get-permissions xfree86-vidmode-mod-mode-line xfree86-vidmode-get-mode-line xfree86-vidmode-get-all-mode-lines xfree86-vidmode-add-mode-line xfree86-vidmode-delete-mode-line xfree86-vidmode-validate-mode-line xfree86-vidmode-get-gamma xfree86-vidmode-set-gamma xfree86-vidmode-get-gamma-ramp xfree86-vidmode-set-gamma-ramp xfree86-vidmode-get-gamma-ramp-size xfree86-vidmode-lock-mode-switch xfree86-vidmode-switch-to-mode xfree86-vidmode-switch-mode xfree86-vidmode-select-next-mode xfree86-vidmode-select-prev-mode xfree86-vidmode-get-monitor xfree86-vidmode-get-viewport xfree86-vidmode-set-viewport xfree86-vidmode-get-dotclocks) :xlib) ;; current version numbers ;; ;; major 0 == uses parameter-to-wire functions in XFree86 libXxf86vm. ;; major 1 == uses parameter-to-wire functions hard-coded in xvidtune client. ;; major 2 == uses new protocol version in XFree86 4.0. (defconstant +xf86vidmode-major-version+ 2) (defconstant +xf86vidmode-minor-version+ 2) ;; requests number. (defconstant +query-version+ 0) (defconstant +get-mode-line+ 1) (defconstant +mod-mode-line+ 2) (defconstant +switch-mode+ 3) (defconstant +get-monitor+ 4) (defconstant +lock-mode-switch+ 5) (defconstant +get-all-mode-lines+ 6) (defconstant +add-mode-line+ 7) (defconstant +delete-mode-line+ 8) (defconstant +validate-mode-line+ 9) (defconstant +switch-to-mode+ 10) (defconstant +get-viewport+ 11) (defconstant +set-viewport+ 12) ;; new for version 2.x of this extension. (defconstant +get-dot-clocks+ 13) (defconstant +set-client-version+ 14) (defconstant +set-gamma+ 15) (defconstant +get-gamma+ 16) (defconstant +get-gamma-ramp+ 17) (defconstant +set-gamma-ramp+ 18) (defconstant +get-gamma-ramp-size+ 19) (defconstant +get-permisions+ 20) (define-extension "XFree86-VidModeExtension" :events (:xfree86-vidmode-notify) :errors (xf86-vidmode-bad-clock xf86-vidmode-bad-htimings xf86-vidmode-bad-vtimings xf86-vidmode-mode-unsuitable xf86-vidmode-extension-disabled xf86-vidmode-client-not-local xf86-vidmode-zoom-locked)) (define-condition xf86-vidmode-bad-clock (request-error) ()) (define-condition xf86-vidmode-bad-htimings (request-error) ()) (define-condition xf86-vidmode-bad-vtimings (request-error) ()) (define-condition xf86-vidmode-mode-unsuitable (request-error) ()) (define-condition xf86-vidmode-extension-disabled (request-error) ()) (define-condition xf86-vidmode-client-not-local (request-error) ()) (define-condition xf86-vidmode-zoom-locked (request-error) ()) (define-error xf86-vidmode-bad-clock decode-core-error) (define-error xf86-vidmode-bad-htimings decode-core-error) (define-error xf86-vidmode-bad-vtimings decode-core-error) (define-error xf86-vidmode-mode-unsuitable decode-core-error) (define-error xf86-vidmode-extension-disabled decode-core-error) (define-error xf86-vidmode-client-not-local decode-core-error) (define-error xf86-vidmode-zoom-locked decode-core-error) (declare-event :XFree86-VidMode-notify (card16 sequence) (window (window event-window)) ; the root window of event screen (int16 state) ; what happend (int16 kind) ; what happend (boolean forced-p) ; extents of a new region ((or null card32) time)) ; event timestamp (defstruct mode-info (dotclock 0 :type card32) (hdisplay 0 :type card16) (hsyncstart 0 :type card16) (hsyncend 0 :type card16) (htotal 0 :type card16) (hskew 0 :type card32) (vdisplay 0 :type card16) (vsyncstart 0 :type card16) (vsyncend 0 :type card16) (vtotal 0 :type card16) (flags 0 :type card32) (privsize 0 :type card32) (private nil :type sequence)) (defmacro vidmode-opcode (display) `(extension-opcode ,display "XFree86-VidModeExtension")) (declaim (inline screen-position)) (defun screen-position (screen display) (declare (type display display) (type screen screen)) (declare (clx-values position)) (let ((position (position screen (xlib:display-roots display)))) (if (not (numberp position)) (error "screen ~A not found in display ~A" screen display) position))) (declaim (inline __card32->card16__)) (defun __card32->card16__ (i) (declare (type card32 i)) #+clx-little-endian (progn (values (ldb (byte 16 0) i) (ldb (byte 32 16) i))) #-clx-little-endian (progn (values (ldb (byte 32 16) i) (ldb (byte 16 0) i)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; ;;;; public XFree86-VidMode Extension routines ;;;; ;;;; ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun xfree86-vidmode-query-version (display) "Determine the version of the extension built into the server. return two values major-version and minor-version in that order." (declare (type display display)) (with-buffer-request-and-reply (display (vidmode-opcode display) nil :sizes 16) ((data +query-version+)) (let ((major (card16-get 8)) (minor (card16-get 10))) (declare (type card16 major minor)) (when (>= major 2) (XFree86-VidMode-set-client-version display)) (values major minor)))) (defun xfree86-vidmode-set-client-version (display) (declare (type display display)) (with-buffer-request (display (vidmode-opcode display)) (data +set-client-version+) (card16 +xf86vidmode-major-version+) (card16 +xf86vidmode-minor-version+))) (defun xfree86-vidmode-get-permissions (dpy screen) (declare (type display dpy) (type screen screen)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-permisions+) (card16 (screen-position screen dpy)) (card16 0)) (values (card32-get 8)))) (defun xfree86-vidmode-mod-mode-line (display screen mode-line) "Change the settings of the current video mode provided the requested settings are valid (e.g. they don't exceed the capabilities of the monitor)." (declare (type display display) (type screen screen)) (let* ((major (xfree86-vidmode-query-version display)) (v (mode-info->v-card16 mode-line major))) (declare (type card16 major) (type simple-vector v)) (with-buffer-request (display (vidmode-opcode display)) (data +mod-mode-line+) (card32 (screen-position screen display)) ((sequence :format card16 :start 2) v)))) (defun xfree86-vidmode-get-mode-line (display screen) "Query the settings for the currently selected video mode. return a mode-info structure fields with the server answer. If there are any server private values (currently only applicable to the S3 server) the function will store it into the returned structure." (declare (clx-values mode-info) (type display display) (type screen screen)) (let ((major (xfree86-vidmode-query-version display)) (offset 8)) (declare (type fixnum offset) (type card16 major)) (with-buffer-request-and-reply (display (vidmode-opcode display) nil :sizes (8 16 32)) ((data +get-mode-line+) (card16 (screen-position screen display)) (card16 0)) (let ((mode-info (make-mode-info :dotclock (card32-get offset) :hdisplay (card16-get (incf offset 4)) :hsyncstart (card16-get (incf offset 2)) :hsyncend (card16-get (incf offset 2)) :htotal (card16-get (incf offset 2)) :hskew (if (< major 2) 0 (card16-get (incf offset 2))) :vdisplay (card16-get (incf offset 2)) :vsyncstart (card16-get (incf offset 2)) :vsyncend (card16-get (incf offset 2)) :vtotal (card16-get (incf offset 2)) :flags (card32-get (incf offset (if (< major 2) 2 4))))) (size (card32-get (incf offset (if (< major 2) 4 16))))) (declare (type card32 size)) (incf offset 4) (setf (mode-info-privsize mode-info) size (mode-info-private mode-info) (sequence-get :format card32 :index offset :length size :result-type 'list)) mode-info)))) (defun xfree86-vidmode-get-all-mode-lines (dpy screen) "Returns a list containing all video modes (as mode-info structure). The first element of the list corresponds to the current video mode." (declare (type display dpy) (type screen screen)) (multiple-value-bind (major minor) (xfree86-vidmode-query-version dpy) (declare (type card16 major minor)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-all-mode-lines+) (card16 (screen-position screen dpy))) (values ;; Note: There was a bug in the protocol implementation in versions ;; 0.x with x < 8 (the .private field wasn't being passed over the wire). ;; Check the server's version, and accept the old format if appropriate. (loop with bug-p = (and (= major 0) (< minor 8)) with offset of-type fixnum = 32 for i of-type card32 from 0 below (or (card32-get 8) 0) collect (let ((mode-info (make-mode-info :dotclock (card32-get offset) :hdisplay (card16-get (incf offset 4)) :hsyncstart (card16-get (incf offset 2)) :hsyncend (card16-get (incf offset 2)) :htotal (card16-get (incf offset 2)) :hskew (if (< major 2) 0 (card32-get (incf offset 2))) :vdisplay (card16-get (incf offset 4)) :vsyncstart (card16-get (incf offset 2)) :vsyncend (card16-get (incf offset 2)) :vtotal (card16-get (incf offset 2)) :flags (card32-get (incf offset (if (< major 2) 2 6))))) (size (card32-get (incf offset (if (< major 2) 4 16))))) (declare (type card32 size)) (incf offset 4) (when bug-p (setf size 0)) (setf (mode-info-privsize mode-info) size (mode-info-private mode-info) (sequence-get :format card32 :index offset :length size :result-type 'list)) (incf offset (* 4 size)) mode-info)))))) (defun xfree86-vidmode-add-mode-line (dpy scr new &key (after (make-mode-info))) (declare (type display dpy) (type screen scr)) (let* ((private (mode-info-private new)) (privsize (mode-info-privsize new)) (major (xfree86-vidmode-query-version dpy)) (i (if (< major 2) 14 22)) (v (make-array (- (+ (* 2 i) (* 2 privsize)) 2) :initial-element 0))) (declare (type card32 privsize) (type fixnum i) (type card16 major) (type simple-vector v)) (mode-info->v-card16 new major :encode-private nil :data v) (mode-info->v-card16 after major :encode-private nil :data v :index i) (setf i (- (* 2 i) 2)) ;; strore private info (sequence card32) according clx bytes order. (loop for card of-type card32 in private do (multiple-value-bind (w1 w2) (__card32->card16__ card) (setf (svref v (incf i)) w1 (svref v (incf i)) w2))) (with-buffer-request (dpy (vidmode-opcode dpy)) (data +add-mode-line+) (card32 (screen-position scr dpy)) ((sequence :format card16) v)))) (defun xfree86-vidmode-delete-mode-line (dpy scr mode-info) "Delete mode argument. The specified mode must match an existing mode. To be considered a match, all of the fields of the given mode-info structure must match, except the privsize and private fields. If the mode to be deleted is the current mode, a mode switch to the next mode will occur first. The last remaining mode can not be deleted." (declare (type display dpy) (type screen scr)) (let* ((major (xfree86-vidmode-query-version dpy)) (v (mode-info->v-card16 mode-info major))) (declare (type card16 major) (type simple-vector v)) (with-buffer-request (dpy (vidmode-opcode dpy)) (data +delete-mode-line+) (card32 (screen-position scr dpy)) ((sequence :format card16) v)))) (defconstant +mode-status+ '#(:MODE_BAD ; unspecified reason :MODE_ERROR ; error condition :MODE_OK ; Mode OK :MODE_HSYNC ; hsync out of range :MODE_VSYNC ; vsync out of range :MODE_H_ILLEGAL ; mode has illegal horizontal timings :MODE_V_ILLEGAL ; mode has illegal horizontal timings :MODE_BAD_WIDTH ; requires an unsupported linepitch :MODE_NO_MODE ; no mode with a maching name :MODE_NO_INTERLACE ; interlaced mode not supported :MODE_NO_DBLESCAN ; doublescan mode not supported :MODE_NO_VSCAN ; multiscan mode not supported :MODE_MEM ; insufficient video memory :MODE_VIRTUAL_X ; mode width too large for specified virtual size :MODE_VIRTUAL_Y ; mode height too large for specified virtual size :MODE_MEM_VIRT ; insufficient video memory given virtual size :MODE_NOCLOCK ; no fixed clock available :MODE_CLOCK_HIGH ; clock required is too high :MODE_CLOCK_LOW ; clock required is too low :MODE_CLOCK_RANGE ; clock/mode isn't in a ClockRange :MODE_BAD_HVALUE ; horizontal timing was out of range :MODE_BAD_VVALUE ; vertical timing was out of range :MODE_BAD_VSCAN ; VScan value out of range :MODE_HSYNC_NARROW ; horizontal sync too narrow :MODE_HSYNC_WIDE ; horizontal sync too wide :MODE_HBLANK_NARROW ; horizontal blanking too narrow :MODE_HBLANK_WIDE ; horizontal blanking too wide :MODE_VSYNC_NARROW ; vertical sync too narrow :MODE_VSYNC_WIDE ; vertical sync too wide :MODE_VBLANK_NARROW ; vertical blanking too narrow :MODE_VBLANK_WIDE ; vertical blanking too wide :MODE_PANEL ; exceeds panel dimensions :MODE_INTERLACE_WIDTH ; width too large for interlaced mode :MODE_ONE_WIDTH ; only one width is supported :MODE_ONE_HEIGHT ; only one height is supported :MODE_ONE_SIZE ; only one resolution is supported )) (defun decode-status-mode (status) (declare (type int32 status)) (svref +mode-status+ (+ status 2))) (defun xfree86-vidmode-validate-mode-line (dpy scr mode-info) "Checked the validity of a mode-info argument. If the specified mode can be used by the server (i.e. meets all the constraints placed upon a mode by the combination of the server, card, and monitor) the function returns :mode_ok otherwise it returns a keyword indicating the reason why the mode is invalid." (declare (type display dpy) (type screen scr)) (let* ((major (xfree86-vidmode-query-version dpy)) (v (mode-info->v-card16 mode-info major))) (declare (type card16 major) (type simple-vector v)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +validate-mode-line+) (card32 (screen-position scr dpy)) ((sequence :format card16) v)) (let ((status (integer-get 8))) (declare (type int32 status)) (when status (decode-status-mode status)))))) (defun xfree86-vidmode-get-gamma (display screen) (declare (type display display) (type screen screen)) (with-buffer-request-and-reply (display (vidmode-opcode display) nil :sizes (8 16 32)) ((data +get-gamma+) (card16 (screen-position screen display)) (card16 0) (card32 0) (card32 0) (card32 0) (card32 0) (card32 0) (card32 0)) (values (/ (the card32 (or (card32-get 8) 0)) 10000.0) (/ (the card32 (or (card32-get 12) 0)) 10000.0) (/ (the card32 (or (card32-get 16) 0)) 10000.0)))) (defun xfree86-vidmode-set-gamma (dpy scr &key (red 1.0) (green 1.0) (blue 1.0)) (declare (type display dpy) (type screen scr) (type (single-float 0.100f0 10.000f0) red green blue)) (with-buffer-request (dpy (vidmode-opcode dpy)) (data +set-gamma+) (card16 (screen-position scr dpy)) (card16 0) (card32 (truncate (* red 10000))) (card32 (truncate (* green 10000))) (card32 (truncate (* blue 10000))) (card32 0) (card32 0) (card32 0))) (defun xfree86-vidmode-get-gamma-ramp (dpy scr size) (declare (type display dpy) (type screen scr) (type card16 size)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-gamma-ramp+) (card16 (screen-position scr dpy)) (card16 size)) (let ((rep-size (* (the card16 (or (card16-get 8) 0)) 2))) (declare (type fixnum rep-size)) (unless (zerop rep-size) (let* ((off1 (+ 32 rep-size (* 2 (mod rep-size 2)))) (off2 (+ off1 rep-size (* 2 (mod rep-size 2))))) (declare (type fixnum off1 off2)) (values (sequence-get :format card16 :length (card16-get 8) :index 32 :result-type 'list) (sequence-get :format card16 :length (card16-get 8) :index off1 :result-type 'list) (sequence-get :format card16 :length (card16-get 8) :index off2 :result-type 'list))))))) (defun xfree86-vidmode-set-gamma-ramp (dpy scr size &key red green blue) (declare (type (or null simple-vector) red green blue) (type card16 size) (type display dpy) (type screen scr)) (with-buffer-request (dpy (vidmode-opcode dpy)) (data +set-gamma-ramp+) (card16 (screen-position scr dpy)) (card16 size) ((sequence :format card16) (if (zerop (mod size 2)) (concatenate 'vector red green blue) (concatenate 'vector red '#(0) green '#(0) blue '#(0)))))) (defun xfree86-vidmode-get-gamma-ramp-size (dpy screen) (declare (type display dpy) (type screen screen)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-gamma-ramp-size+) (card16 (screen-position screen dpy)) (card16 0)) (card16-get 8))) (defun xfree86-vidmode-lock-mode-switch (display screen lock-p) "Allow or disallow mode switching whether the request to switch modes comes from a call to the mode switching functions or from one of the mode switch key sequences (e.g. Ctrl-Alt-+ Ctrl-Alt--)." (declare (type display display) (type screen screen) (type boolean lock-p)) (with-buffer-request (display (vidmode-opcode display)) (data +lock-mode-switch+) (card16 (screen-position screen display)) (card16 (if lock-p 1 0)))) (defun xfree86-vidmode-switch-to-mode (display screen mode-info) "Switch directly to the specified mode. The specified mode must match an existing mode. Matching is as specified in the description of the xf86-vidmode-delete-mode-line function." (declare (type display display) (type screen screen)) (multiple-value-bind (major minor) (xfree86-vidmode-query-version display) (declare (type card16 major minor)) ;; Note: There was a bug in the protocol implementation in versions ;; 0.x with x < 8 (the .private field wasn't being passed over the wire). ;; Check the server's version, and accept the old format if appropriate. (let ((bug-p (and (= major 0) (< minor 8))) (privsize (mode-info-privsize mode-info))) (declare (type boolean bug-p)) (and bug-p (setf (mode-info-privsize mode-info) 0)) (let ((v (mode-info->v-card16 mode-info major :encode-private bug-p))) (declare (type simple-vector v)) (and bug-p (setf (mode-info-privsize mode-info) privsize)) (with-buffer-request (display (vidmode-opcode display)) (data +switch-to-mode+) (card32 (screen-position screen display)) ((sequence :format card16) v)))))) (defun xfree86-vidmode-switch-mode (display screen zoom) "Change the video mode to next (or previous) video mode, depending of zoom sign. If positive, switch to next mode, else switch to prev mode." (declare (type display display) (type screen screen) (type card16 zoom)) (with-buffer-request (display (vidmode-opcode display)) (data +switch-mode+) (card16 (screen-position screen display)) (card16 zoom))) (defun xfree86-vidmode-select-next-mode (display screen) "Change the video mode to next video mode" (declare (type display display) (type screen screen)) (with-buffer-request (display (vidmode-opcode display)) (data +switch-mode+) (card16 (screen-position screen display)) (card16 1))) (defun xfree86-vidmode-select-prev-mode (display screen) "Change the video mode to previous video mode" (declare (type display display) (type screen screen)) (with-buffer-request (display (vidmode-opcode display)) (data +switch-mode+) (card16 (screen-position screen display)) (card16 #xFFFF))) (defun xfree86-vidmode-get-monitor (dpy screen) "Information known to the server about the monitor is returned. Multiple value return: hsync (list of hi, low, ...) vsync (list of hi, low, ...) vendor name model name The hi and low values will be equal if a discreate value was given in the XF86Config file." (declare (type display dpy) (type screen screen)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-monitor+) (card16 (screen-position screen dpy)) (card16 0)) (let* ((vendor-name-length (card8-get 8)) (model-name-length (card8-get 9)) (pad (- 4 (mod vendor-name-length 4))) (nhsync (card8-get 10)) (nvsync (card8-get 11)) (vindex (+ 32 (* 4 (+ nhsync nvsync)))) (mindex (+ vindex vendor-name-length pad)) (hsync (sequence-get :length nhsync :index 32 :result-type 'list)) (vsync (sequence-get :length nvsync :index (+ 32 (* nhsync 4)) :result-type 'list))) (declare (type card8 nhsync nvsync vendor-name-length model-name-length) (type fixnum pad vindex mindex)) (values (loop for i of-type card32 in hsync collect (/ (ldb (byte 16 0) i) 100.) collect (/ (ldb (byte 32 16) i) 100.)) (loop for i of-type card32 in vsync collect (/ (ldb (byte 16 0) i) 100.) collect (/ (ldb (byte 32 16) i) 100.)) (string-get vendor-name-length vindex) (string-get model-name-length mindex))))) (defun xfree86-vidmode-get-viewport (dpy screen) "Query the location of the upper left corner of the viewport into the virtual screen. The upper left coordinates will be returned as a multiple value." (declare (type display dpy) (type screen screen)) (multiple-value-bind (major minor) (xfree86-vidmode-query-version dpy) (declare (type card16 major minor)) ;; Note: There was a bug in the protocol implementation in versions ;; 0.x with x < 8 (no reply was sent, so the client would hang) ;; Check the server's version, and don't wait for a reply with older ;; versions. (when (and (= major 0) (< minor 8)) (format cl:*error-output* "running an old version ~a ~a~%" major minor) (return-from xfree86-vidmode-get-viewport nil)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-viewport+) (card16 (screen-position screen dpy)) (card16 0)) (values (card32-get 8) (card32-get 12))))) (defun xfree86-vidmode-set-viewport (dpy screen &key (x 0) (y 0)) "Set upper left corner of the viewport into the virtual screen to the x and y keyword parameters value (zero will be theire default value)." (declare (type display dpy) (type screen screen) (type card32 x y)) (with-buffer-request (dpy (vidmode-opcode dpy)) (data +set-viewport+) (card16 (screen-position screen dpy)) (card16 0) (card32 x) (card32 y))) (defun xfree86-vidmode-get-dotclocks (dpy screen) "Returns as a multiple value return the server dotclock informations: flags maxclocks clock list" (declare (type display dpy) (type screen screen)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-dot-clocks+) (card16 (screen-position screen dpy)) (card16 0)) (values (card32-get 8) ; flags (card32-get 16) ; max clocks (sequence-get :length (card32-get 12) :format card32 :index 32 :result-type 'list)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; ;;;; private utility routines ;;;; ;;;; ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun mode-info->v-card16 (mode-info major &key (encode-private t) (index 0) data) (declare (type integer index) (type card16 major) (type boolean encode-private) (type (or null simple-vector) data)) (let ((dotclock (mode-info-dotclock mode-info)) (hdisplay (mode-info-hdisplay mode-info)) (hsyncstart (mode-info-hsyncstart mode-info)) (hsyncend (mode-info-hsyncend mode-info)) (htotal (mode-info-htotal mode-info)) (hskew (mode-info-hskew mode-info)) (vdisplay (mode-info-vdisplay mode-info)) (vsyncstart (mode-info-vsyncstart mode-info)) (vsyncend (mode-info-vsyncend mode-info)) (vtotal (mode-info-vtotal mode-info)) (flags (mode-info-flags mode-info)) (privsize (mode-info-privsize mode-info)) (private (mode-info-private mode-info))) (declare (type card16 hdisplay hsyncstart hsyncend htotal hskew) (type card16 vdisplay vsyncstart vsyncend vtotal) (type card32 dotclock flags privsize) (type (or null sequence) private)) (let* ((size (+ (if (< major 2) 14 22) (* privsize 2))) (v (or data (make-array size :initial-element 0)))) (declare (type fixnum size) (type simple-vector v)) ;; store dotclock (card32) according clx bytes order. (multiple-value-bind (w1 w2) (__card32->card16__ dotclock) (setf (svref v index) w1 (svref v (incf index)) w2)) (setf (svref v (incf index)) hdisplay (svref v (incf index)) hsyncstart (svref v (incf index)) hsyncend (svref v (incf index)) htotal) (unless (< major 2) (setf (svref v (incf index)) hskew)) (setf (svref v (incf index)) vdisplay (svref v (incf index)) vsyncstart (svref v (incf index)) vsyncend (svref v (incf index)) vtotal) (unless (< major 2) (incf index)) ;; strore flags (card32) according clx bytes order. (multiple-value-bind (w1 w2) (__card32->card16__ flags) (setf (svref v (incf index)) w1 (svref v (incf index)) w2)) ;; strore privsize (card32) according clx bytes order. (multiple-value-bind (w1 w2) (__card32->card16__ privsize) (setf (svref v (incf index)) w1 (svref v (incf index)) w2)) ;; reserverd byte32 1 2 3 (unless (< major 2) (incf index 6)) ;; strore private info (sequence card32) according clx bytes order. (when encode-private (loop for i of-type int32 in private do (multiple-value-bind (w1 w2) (__card32->card16__ i) (setf (svref v (incf index)) w1 (svref v (incf index)) w2)))) v))) cl-clx-sbcl-0.7.4.20160323.orig/extensions/dbe.lisp0000644000175000017500000001562612715665272017456 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- ;;; --------------------------------------------------------------------------- ;;; Title: Double Buffer Extension ;;; Created: 2014-11-17 ;;; Author: Johannes Martinez ;;; --------------------------------------------------------------------------- ;;; ;;; (c) copyright 2014 by Johannes Martinez ;;; ;;; 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. ;;; (in-package :xlib) (export '(;; x requests dbe-query-version dbe-get-visual-info dbe-allocate-back-buffer-name dbe-deallocate-back-buffer-name dbe-swap-buffers dbe-begin-idiom dbe-end-idiom dbe-get-back-buffer-attributes ;; convenience function create-back-buffer ;; swap-hint constants +undefined+ +background+ +untouched+ +copied+) :xlib) (define-extension "DOUBLE-BUFFER" :errors (dbe-bad-buffer)) ;; version (defconstant +major+ 1) (defconstant +minor+ 0) ;; request codes (defconstant +query-version+ 0) (defconstant +allocate-back-buffer-name+ 1) (defconstant +deallocate-back-buffer-name+ 2) (defconstant +swap-buffers+ 3) (defconstant +begin-idiom+ 4) (defconstant +end-idiom+ 5) (defconstant +get-visual-info+ 6) (defconstant +get-back-buffer-attributes+ 7) ;; swap actions (defconstant +undefined+ #x00) (defconstant +background+ #x01) (defconstant +untouched+ #x02) (defconstant +copied+ #x03) ;; Errors ?? (define-condition dbe-bad-buffer (request-error) ()) (define-error dbe-bad-buffer decode-core-error) ;; class and structure definitions ;; use def-clx-class instead of deftype to be consistent with clx and be able to submit ;; back-buffers to other x-requests that accept drawables, for convenience should probably just ;; have get-visual-info return visual-ids or visual-info structs (def-clx-class (back-buffer (:include drawable) (:copier nil) (:print-function print-drawable))) (defstruct visinfo (visual-id 0 :type (unsigned-byte 32)) (depth 0 :type (unsigned-byte 8)) (perflevel 0 :type (unsigned-byte 8)) (unused 0 :type (unsigned-byte 16))) ;; convenience function (defun create-back-buffer (window) "Returns a back-buffer structure associated with the given window" (let* ((display (window-display window)) (bb (make-back-buffer :display display)) (id (allocate-resource-id display bb 'back-buffer))) (declare (type display display) (type window window) (type drawable bb)) (setf (back-buffer-id bb) id) (if (window-p window) (dbe-allocate-back-buffer-name window bb)) bb)) ;; X requests (defun dbe-query-version (display) "Returns Major and Minor versions as values" (declare (display display)) (with-buffer-request-and-reply (display (extension-opcode display "DOUBLE-BUFFER") nil) ((data +query-version+) (card8 +major+) (card8 +minor+)) (values (card8-get 8) (card8-get 9)))) (defun dbe-allocate-back-buffer-name (window back-buffer &optional (swap-hint +copied+)) "Associates the given back-buffer with given window, optional swap-hint " (let ((display (window-display window))) (declare (type display display) (type window window) (type back-buffer back-buffer) (type card8 swap-hint)) (with-buffer-request (display (extension-opcode display "DOUBLE-BUFFER")) (data +allocate-back-buffer-name+) (window window) (drawable back-buffer) (card8 swap-hint) (pad8) ;unused (pad16)))) ;unused (defun dbe-deallocate-back-buffer-name (back-buffer) "disconnects back-buffer from window, does not free xid from the server allowing buffer to be associated with another window" (let ((display (back-buffer-display back-buffer))) (declare (type display display) (type back-buffer back-buffer)) (with-buffer-request (display (extension-opcode display "DOUBLE-BUFFER")) (data +deallocate-back-buffer-name+) (drawable back-buffer)))) (defun dbe-swap-buffers (window-list) "takes a list of (window swap-action) pairs and swaps their back-buffers" (let ((display (window-display (caar window-list))) (num (length window-list)) (seq (lst->array window-list))) (declare (type display display) (type fixnum num) (type simple-array seq)) (with-buffer-request (display (extension-opcode display "DOUBLE-BUFFER")) (data +swap-buffers+) (card32 num) ((sequence :format card32) seq)))) (defun dbe-begin-idiom (display) (with-buffer-request (display (extension-opcode display "DOUBLE-BUFFER")) (data +begin-idiom+))) (defun dbe-end-idiom (display) (with-buffer-request (display (extension-opcode display "DOUBLE-BUFFER")) (data +end-idiom+))) (defun dbe-get-visual-info (drawable-list) "Not very useful in this modern graphics age, nothing added or taken away from the bare x." (let ((display (drawable-display (car drawable-list))) (num (length drawable-list)) (wl (map 'vector #'drawable-id drawable-list))) (declare (type display display) (type fixnum num)) (with-buffer-request-and-reply (display (extension-opcode display "DOUBLE-BUFFER") nil :sizes (8 16 32)) ((data +get-visual-info+) (card32 num) ((sequence :format card32) wl)) (values (let ((num (card32-get 8)) (next 32) (result-list ())) (declare (type fixnum num next)) (dotimes (i num (nreverse result-list)) (push (loop :for i :from 1 :to (card32-get next) :for off := (+ next 4) :then (+ off 8) :collect (make-visinfo :visual-id (card32-get off) :depth (card8-get (+ off 4)) :perflevel (card8-get (+ off 5))) :finally (setf next (+ off 8 ))) result-list))))))) (defun dbe-get-back-buffer-attributes (back-buffer) "Returns the window that a back-buffer outputs to or nil if not associated with any window" (declare (type back-buffer back-buffer)) (let ((display (back-buffer-display back-buffer))) (declare (type display display)) (with-buffer-request-and-reply (display (extension-opcode display "DOUBLE-BUFFER") nil :sizes 32) ((data +get-back-buffer-attributes+) (drawable back-buffer)) (values (or-get 8 null window))))) ;; utility functions (defun lst->array (lst) (make-array (* 2 (length lst)) :initial-contents (loop :for x :in lst :collect (drawable-id (car x)) :collect (cadr x)))) cl-clx-sbcl-0.7.4.20160323.orig/extensions/xtest.lisp0000644000175000017500000001077112715665272020067 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- ;;; ;;; Implementation of the XTest extension as described by ;;; http://www.x.org/docs/Xext/xtest.pdf ;;; ;;; Written by Lionel Flandrin in july ;;; 2008 and placed in the public domain. ;;; ;;; TODO: ;;; * Implement XTestSetVisualIDOfVisual and XTestDiscard ;;; * Add the missing (declare (type ... (defpackage :xtest (:use :common-lisp :xlib) (:import-from :xlib #:data #:card8 #:card8-get #:card16 #:card16-get #:card32 #:card32-get #:extension-opcode #:define-extension #:gcontext #:resource-id #:window-id #:cursor #:make-cursor #:with-buffer-request-and-reply #:with-buffer-request #:display) (:export ;; Constants #:+major-version+ #:+minor-version+ ;; Functions #:set-gc-context-of-gc #:get-version #:compare-cursor #:fake-motion-event #:fake-button-event #:fake-key-event #:grab-control)) (in-package :xtest) (define-extension "XTEST") (defmacro opcode (display) `(extension-opcode ,display "XTEST")) ;;; The version we implement (defconstant +major-version+ 2) (defconstant +minor-version+ 2) (defconstant +none+ 0) (defconstant +current-cursor+ 1) ;;; XTest opcodes (defconstant +get-version+ 0) (defconstant +compare-cursor+ 1) (defconstant +fake-input+ 2) (defconstant +grab-control+ 3) ;;; Fake events (defconstant +fake-key-press+ 2) (defconstant +fake-key-release+ 3) (defconstant +fake-button-press+ 4) (defconstant +fake-button-release+ 5) (defconstant +fake-motion-notify+ 6) ;;; Client operations (defun set-gc-context-of-gc (gcontext gcontext-id) (declare (type gcontext gcontext) (type resource-id gcontext-id)) (setf (gcontext-id gcontext) gcontext-id)) ;;; Server requests (defun get-version (display &optional (major +major-version+) (minor +minor-version+)) "Returns the major and minor version of the server's XTest implementation" (declare (type display display)) (with-buffer-request-and-reply (display (opcode display) nil) ((data +get-version+) (card8 major) (card16 minor)) (values (card8-get 1) (card16-get 8)))) (defun compare-cursor (display window &optional (cursor-id +current-cursor+)) (declare (type display display) (type resource-id cursor-id) (type window window)) (with-buffer-request-and-reply (display (opcode display) nil) ((data +compare-cursor+) (resource-id (window-id window)) (resource-id cursor-id)) (values (card8-get 1)))) (defun fake-motion-event (display x y &key (delay 0) relative (root-window-id 0)) "Move the mouse pointer at coordinates (x, y). If :relative is t, the movement is relative to the pointer's current position" (declare (type display display)) (with-buffer-request (display (opcode display)) (data +fake-input+) (card8 +fake-motion-notify+) (card8 (if relative 1 0)) (pad16 0) (card32 delay) (card32 root-window-id) (pad32 0 0) (card16 x) (card16 y) (pad32 0 0))) (defun fake-button-event (display button pressed &key (delay 0)) "Send a fake button event (button pressed or released) to the server. Most of the time, button 1 is the left one, 2 the middle and 3 the right one but it's not always the case." (declare (type display display)) (with-buffer-request (display (opcode display)) (data +fake-input+) (card8 (if pressed +fake-button-press+ +fake-button-release+)) (card8 button) (pad16 0) (card32 delay) (pad32 0 0 0 0 0 0))) (defun fake-key-event (display keycode pressed &key (delay 0)) "Send a fake key event (key pressed or released) to the server based on its keycode." (declare (type display display)) (with-buffer-request (display (opcode display)) (data +fake-input+) (card8 (if pressed +fake-key-press+ +fake-key-release+)) (card8 keycode) (pad16 0) (card32 delay) (pad32 0 0 0 0 0 0))) (defun grab-control (display grab?) "Make the client grab the server, that is allow it to make requests even when another client grabs the server." (declare (type display display)) (with-buffer-request (display (opcode display)) (data +grab-control+) (card8 (if grab? 1 0)) (pad8 0) (pad16 0))) ;;; Local Variables: ;;; indent-tabs-mode: nil ;;; End: cl-clx-sbcl-0.7.4.20160323.orig/extensions/randr.lisp0000644000175000017500000010753712715665272020035 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- ;;; --------------------------------------------------------------------------- ;;; Title: RandR Extension ;;; Created: 2014-11-17 ;;; Author: Johannes Martinez ;;; --------------------------------------------------------------------------- ;;; ;;; (c) copyright 2014 by Johannes Martinez ;;; ;;; 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. ;;; (in-package :xlib) (export '(rr-query-version rr-get-screen-info rr-set-screen-config ;; 1.2 rr-get-screen-size-range rr-set-screen-size rr-get-screen-resources rr-get-output-info rr-list-output-properties rr-query-output-property rr-configure-output-property rr-change-output-property rr-delete-output-property rr-get-output-property rr-create-mode rr-destroy-mode rr-add-output-mode rr-delete-output-mode rr-get-crtc-info rr-get-crtc-gamma-size rr-get-crtc-gamma rr-set-crtc-gamma ;; 1.3 rr-get-screen-resources-current rr-set-crtc-transform rr-get-crtc-transform rr-get-panning rr-set-panning rr-set-output-primary rr-get-output-primary ;; 1.4 rr-get-providers rr-get-provider-info rr-set-provider-output-source rr-set-provider-offload-sink rr-list-provider-properties ;; mask related make-mode-flag-keys make-mode-flag-mask make-rr-select-mask make-rr-select-keys make-rotation-keys make-rotation-mask ;; struct related rr-panning-top rr-panning-left rr-panning-width rr-panning-height rr-panning-track-top rr-panning-track-left rr-panning-track-width rr-panning-track-height rr-panning-border-left rr-panning-border-top rr-panning-border-bottom rr-panning-border-right rr-panning make-rr-transform )) (define-extension "RANDR" :events (:rr-screen-change-notify :rr-crtc-change-notify :rr-output-change-notify :rr-output-property-notify) :errors (output crtc mode)) (defun randr-opcode (display) (extension-opcode display "RANDR")) (defconstant +rr-major+ 1) (defconstant +rr-minor+ 4) (defconstant +rr-QueryVersion+ 0) ;; we skip 1 to make old clients fail pretty immediately */ (defconstant +rr-SetScreenConfig+ 2) (defconstant +rr-OldScreenChangeSelectInput+ 3) ;; 3 used to be ScreenChangeSelectInput; deprecated */ (defconstant +rr-SelectInput+ 4) (defconstant +rr-GetScreenInfo+ 5) ;; * V1.2 additions */ (defconstant +rr-GetScreenSizeRange+ 6) (defconstant +rr-SetScreenSize+ 7) (defconstant +rr-GetScreenResources+ 8) (defconstant +rr-GetOutputInfo+ 9) (defconstant +rr-ListOutputProperties+ 10) (defconstant +rr-QueryOutputProperty+ 11) (defconstant +rr-ConfigureOutputProperty+ 12) (defconstant +rr-ChangeOutputProperty+ 13) (defconstant +rr-DeleteOutputProperty+ 14) (defconstant +rr-GetOutputProperty+ 15) (defconstant +rr-CreateMode+ 16) (defconstant +rr-DestroyMode+ 17) (defconstant +rr-AddOutputMode+ 18) (defconstant +rr-DeleteOutputMode+ 19) (defconstant +rr-GetCrtcInfo+ 20) (defconstant +rr-SetCrtcConfig+ 21) (defconstant +rr-GetCrtcGammaSize+ 22) (defconstant +rr-GetCrtcGamma+ 23) (defconstant +rr-SetCrtcGamma+ 24) ;; /* V1.3 additions */ (defconstant +rr-GetScreenResourcesCurrent+ 25) (defconstant +rr-SetCrtcTransform+ 26) (defconstant +rr-GetCrtcTransform+ 27) (defconstant +rr-GetPanning+ 28) (defconstant +rr-SetPanning+ 29) (defconstant +rr-SetOutputPrimary+ 30) (defconstant +rr-GetOutputPrimary+ 31) ;; 1.4 additions (defconstant +rr-GetProviders+ 32) (defconstant +rr-GetProviderInfo+ 33) (defconstant +rr-SetProviderOffloadSink+ 34) (defconstant +rr-SetProviderOutputSource+ 35) (defconstant +rr-ListProviderProperties+ 36) (defconstant +rr-QueryProviderProperty+ 37) (defconstant +rr-ConfigureProviderProperty+ 38) (defconstant +rr-ChangeProviderProperty+ 39) (defconstant +rr-DeleteProviderProperty+ 40) (defconstant +rr-GetProviderProperty+ 41) ;;; status returns (defconstant +rr-config-status+ '#(:success :invalid-config-time :invalid-time :failed)) (defconstant +rr-connection+ '#(:connected :disconnected :unknown-connection)) ;;; mask-vectors and types ;; Rotation (defconstant +rotation-mask-vector+ '#(:rotate-0 :rotate-90 :rotate-180 :rotate-270 :reflect-x :reflect-y)) (deftype rotation-mask-class () '(member :rotate-0 :rotate-90 :rotate-180 :rotate-270 :reflect-x :reflect-y)) (deftype rotation-mask () '(or mask16 (clx-list event-mask-class))) ;; Select (defconstant +rr-select-mask-vector+ '#(:screen-change-notify-mask :crtc-change-notify-mask :output-change-notify-mask :output-property-notify-mask)) (deftype rr-select-mask-class () '(member :screen-change-notify-mask :crtc-change-notify-mask :output-change-notify-mask :output-property-notify-mask)) (deftype rr-select-mask () '(or mask8 (clx-list rr-select-mask-class))) ;; Mode-flag (defconstant +mode-flag-mask-vector+ '#(:hsync-positive :hsync-negative :vsync-positive :vsync-negative :interlace :double-scan :csync :csync-positive :csync-negative :hskew-present :b-cast :pixel-multiplex :double-clock :clock-divide-by-2)) (deftype mode-flag-mask-class () '(member :hsync-positive :hsync-negative :vsync-positive :vsync-negative :interlace :double-scan :csync :csync-positive :csync-negative :hskew-present :b-cast :pixel-multiplex :double-clock :clock-divide-by-2)) (deftype mode-flag-mask () '(or mask32 (clx-list mode-flag-mask-class))) ;; temporarily here since not in xrender.lisp (defconstant +render-subpixel-order+ '#(:unknown :horizontal-RGB :horizontal-BGR :vertical-RGB :vertical-BGR :none)) ;; mask encode-decode functions ;; (defun make-mode-flag-mask (key-list) ;; (encode-mask +mode-flag-mask-vector+ key-list 'mode-flag-mask)) ;; (defun make-mode-flag-keys (mode-flag-mask) ;; (declare (type mask32 mode-flag-mask)) ;; (declare (clx-values (clx-list mode-flag-mask))) ;; (decode-mask +mode-flag-mask-vector+ mode-flag-mask)) ;; (defun make-rotation-mask (key-list) ;; (encode-mask +rotation-mask-vector+ key-list )) (defmacro define-mask-fns (name mask-size mask-vector mask-type) (let ((encode-fn (xintern 'make- name '-mask)) (decode-fn (xintern 'make- name '-keys))) `(progn (defun ,encode-fn (key-list) (encode-mask ,mask-vector key-list ',mask-type)) (defun ,decode-fn (bit-mask) (declare (type ,mask-size bit-mask)) (declare (clx-values (clx-list ,mask-type))) (decode-mask ,mask-vector bit-mask)) ))) (define-mask-fns mode-flag card32 +mode-flag-mask-vector+ mode-flag-mask) (define-mask-fns rr-select card8 +rr-select-mask-vector+ rr-select-mask) (define-mask-fns rotation card16 +rotation-mask-vector+ rotation-mask) ;; (defconstant +RRTransformUnit (1L+ << 0)) ;; (defconstant +RRTransformScaleUp (1L+ << 1)) ;; (defconstant +RRTransformScaleDown (1L+ << 2)) ;; (defconstant +RRTransformProjective (1L+ << 3)) ;; types (deftype size-id () 'card16) (deftype rr-mode () '(or null resource-id)) (deftype output () 'resource-id) (deftype connection () '(or +connected+ +disconnected+ +unknown-connection+)) ;; structs (def-clx-class (screen-size (:constructor make-screen-size (width-in-pixels height-in-pixels width-in-mm height-in-mm))) (width-in-pixels 0 :type card16) (height-in-pixels 0 :type card16) (width-in-mm 0 :type card16) (height-in-mm 0 :type card16)) (def-clx-class (rr-mode-info (:constructor make-rr-mode-info (id width height dot-clock h-sync-start h-sync-end h-sync-total h-sync-skew v-sync-start v-sync-end v-total name-length mode-flags))) (id 0 :type card32) (width 0 :type card16) (height 0 :type card16) (dot-clock 0 :type card32) (h-sync-start 0 :type card16) (h-sync-end 0 :type card16) (h-sync-total 0 :type card16) (h-sync-skew 0 :type card16) (v-sync-start 0 :type card16) (v-sync-end 0 :type card16) (v-total 0 :type card16) (name-length 0 :type card16) (mode-flags 0 :type mode-flag-mask)) (def-clx-class (rr-panning) (left 0 :type card16) (top 0 :type card16) (width 0 :type card16) (height 0 :type card16) (track-left 0 :type card16) (track-top 0 :type card16) (track-width 0 :type card16) (track-height 0 :type card16) (border-left 0 :type int16) (border-top 0 :type int16) (border-right 0 :type int16) (border-bottom 0 :type int16)) (def-clx-class (rr-transform ( :type vector) :named ) (x 0 :type card32) (y 0 :type card32) (z 0 :type card32) (i 0 :type card32) (j 0 :type card32) (k 0 :type card32) (d 0 :type card32) (e 0 :type card32) (f 0 :type card32)) ;; accessors ;; fricken macroexpansions !!! figure it out!! (define-accessor rr-transform (36) ((index) `(make-rr-transform :x (card32-get (index+ ,index 0)) :y (card32-get (index+ ,index 4)) :z (card32-get (index+ ,index 8)) :i (card32-get (index+ ,index 12)) :j (card32-get (index+ ,index 16)) :k (card32-get (index+ ,index 20)) :d (card32-get (index+ ,index 24)) :e (card32-get (index+ ,index 28)) :f (card32-get (index+ ,index 32)) )) ((index thing) `(sequence-put ,index ,thing :start 1))) ;; (define-accessor rr-panning (24) ;; ((index) `(make-rr-panning :left (card16-get ,index) ;; :top (card16-get (index+ ,index 2)) ;; :width (card16-get (index+ ,index 4)) ;; :height (card16-get (index+ ,index 6)) ;; :track-left (card16-get (index+ ,index 8)) ;; :track-top (card16-get (index+ ,index 10)) ;; :track-width (card16-get (index+ ,index 12)) ;; :track-height (card16-get (index+ ,index 14)) ;; :border-left (int16-get (index+ ,index 16)) ;; :border-top (int16-get (index+ ,index 18)) ;; :border-right (int16-get (index+ ,index 20)) ;; :border-bottom (int16-get (index+ ,index 22)))) ;; ;; put doesn't work ;; ((index thing) `(progn ,`(write-card16 (index+ ,index 0)(rr-panning-left ,thing)) ;; , `(write-card16 (index+ ,index 2)(rr-panning-top ,thing)) ;; , `(write-card16 (index+ ,index 4)(rr-panning-width ,thing)) ;; , `(write-card16 (index+ ,index 6)(rr-panning-height ,thing)) ;; , `(write-card16 (index+ ,index 8)(rr-panning-track-left ,thing)) ;; , `(write-card16 (index+ ,index 10)(rr-panning-track-top ,thing)) ;; , `(write-card16 (index+ ,index 12)(rr-panning-track-width ,thing)) ;; , `(write-card16 (index+ ,index 14)(rr-panning-track-height ,thing)) ;; , `(write-int16 (index+ ,index 16)(rr-panning-border-left ,thing)) ;; , `(write-int16 (index+ ,index 18)(rr-panning-border-top ,thing)) ;; , `(write-int16 (index+ ,index 20)(rr-panning-border-right ,thing)) ;; , `(write-int16(index+ ,index 22)(rr-panning-border-bottom ,thing))) ;; )) ;; (defmacro pan-put ()) (define-accessor rr-mode-info (32) ((index) `(make-rr-mode-info (card32-get ,index) (card16-get (+ ,index 4)) (card16-get (+ ,index 6)) (card32-get (+ ,index 8)) (card16-get (+ ,index 12)) (card16-get (+ ,index 14)) (card16-get (+ ,index 16)) (card16-get (+ ,index 18)) (card16-get (+ ,index 20)) (card16-get (+ ,index 22)) (card16-get (+ ,index 24)) (card16-get (+ ,index 26)) (card32-get (+ ,index 28)))) ((index thing) `(progn (card32-put ,index (rr-mode-info-id ,thing)) (card16-put (index+ ,index 4) (rr-mode-info-width ,thing)) (card16-put (index+ ,index 6) (rr-mode-info-height ,thing)) (card32-put (index+ ,index 8) (rr-mode-info-dot-clock ,thing)) (card16-put (index+ ,index 12) (rr-mode-info-h-sync-start ,thing)) (card16-put (index+ ,index 14) (rr-mode-info-h-sync-end ,thing)) (card16-put (index+ ,index 16) (rr-mode-info-h-sync-total ,thing)) (card16-put (index+ ,index 18) (rr-mode-info-h-sync-skew ,thing)) (card16-put (index+ ,index 20) (rr-mode-info-v-sync-start ,thing)) (card16-put (index+ ,index 22) (rr-mode-info-v-sync-end ,thing)) (card16-put (index+ ,index 24) (rr-mode-info-v-total ,thing)) (card16-put (index+ ,index 26) (rr-mode-info-name-length ,thing)) (card32-put (index+ ,index 28) (rr-mode-info-mode-flags ,thing)) ))) ;; x-events ;; test!! (declare-event :rr-screen-change-notify ((data (member8 +rotation-mask-vector+))) (card16 sequence) (card32 timestamp config-timestamp) ; (card32 config-timestamp) (window root-window request-window) ; (window request-window) (card16 size-id sub-pixel-order width height width-in-mm height-in-mm)) (declare-event :rr-crtc-change-notify ((data (member8 +rotation-mask-vector+))) (card16 sequence) (card32 timestamp) (window request-window) (card32 crtc) (card32 mode) (card16 rotation) (pad16) (int16 x y) (card16 width height)) (declare-event :rr-output-change-notify (card16 sequence) (card32 timestamp config-timestamp) (window request-window) (card32 output crtc mode) (card16 rotation) (card8 connection) (card8 sub-pixel-order)) (declare-event :rr-output-property-notify (card16 sequence) (window window) (card32 output atom timestamp) (boolean state) ) ;; x-requests (defun rr-query-version (display) "Returns version MAJOR and MINOR from server." (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (32)) ((data +rr-QueryVersion+) (card32 +rr-major+) (card32 +rr-minor+)) (values (card32-get 8) (card32-get 12)))) (defun rr-set-screen-config (window timestamp conf-timestamp size-id rotation refresh) "Sets the current screen to which the given window belongs. Timestamps are obtained from rr-get-screen-info. Rotation can be a list of rotation keys or a rotation mask. Returns timestamp, config timestamp, the root window of the screen and sub-pixel order." (let ((display (window-display window)) (rot-mask (if (consp rotation) (make-rotation-mask rotation) rotation))) (declare (type display display) (type window window) (type card16 size-id rot-mask refresh) (type card32 timestamp conf-timestamp)) (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (16 32)) ((data +rr-SetScreenConfig+) (window window) (card32 timestamp) (card32 conf-timestamp) (card16 size-id) (card16 rot-mask) (card16 refresh) (pad16)) (values (member8-vector-get 1 +rr-config-status+) (card32-get 8) ;; timestamp (card32-get 12) ;; config timestamp (window-get 16) ;; root window (member16-vector-get 20 +render-subpixel-order+) ;; sub pixel order )))) (defun rr-select-input (window enable) "Enables event reception for given window. Enable may be a select-mask or list of select-keys " (let ((display (window-display window)) (select-mask (if (consp enable) (make-rr-select-mask enable) enable))) (declare (type display display) (type window window) (type card16 select-mask)) (with-buffer-request (display (randr-opcode display)) (data +rr-selectinput+) (window window) (card16 select-mask) (pad16)))) (defun rr-get-screen-info (window &optional (result-type 'list)) "Returns rotations, root-window, timestamp, config-timestamp, current-size-id, current rotation, current rate, a list of screen-size structures, and last a sequence of refresh-rates" (let ((display (window-display window))) (declare (type display display) (type window window)) (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32)) ((data +rr-GetScreenInfo+ ) (window window)) (let ((num-screens (card16-get 20)) (num-rates (card16-get 28)) (rates-location 0)) (declare (type fixnum rates-location num-rates)) (values (make-rotation-keys (card16-get 1)) ; possible rotations, using card16, not card8 from spec. (window-get 8) ;root window (card32-get 12) ;timestamp (card32-get 16) ;config-timestamp (card16-get 22) ;size-id (make-rotation-keys (card16-get 24)) ;current rotation (card16-get 26) ; current rate (loop :for x fixnum :from 1 :to num-screens :for offset fixnum := 32 :then (+ offset 8) :collect (make-screen-size (card16-get offset) (card16-get (index+ offset 2)) (card16-get (index+ offset 4)) (card16-get (index+ offset 6))) :finally (setf rates-location (+ offset 8 2))) (sequence-get :format card16 :length num-rates :index rates-location :result-type result-type)))))) ;; Version 1.2 (defun rr-get-screen-size-range (window &optional (result-type 'list)) "Returns a sequence of minimum width, minimum height, max width, max height." (let ((display (window-display window))) (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (16)) ((data +rr-getscreensizerange+) (window window)) (values (sequence-get :format card16 :length 4 :index 8 :result-type result-type))))) ;; doesn't work, asynchronous match error. set screen config works fine. (defun rr-set-screen-size (window width height width-mm height-mm) "" (let ((display (window-display window))) (declare (type display display) (type window window) (type card16 width height) (type card32 width-mm height-mm)) (with-buffer-request (display (randr-opcode display)) (data +rr-setscreensize+) (window window) (card16 width) (card16 height) (card32 width-mm) (card32 height-mm)))) (defun rr-get-screen-resources (window &optional (result-type 'list)) "" (let ((display (window-display window))) (declare (type display display) (type window window)) (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32)) ((data +rr-getscreenresources+) (window window)) (let* ((num-crtcs (card16-get 16)) (num-outputs (card16-get 18)) (output-start (index+ +replysize+ (index* num-crtcs 4))) (num-modeinfos (card16-get 20)) (name-bytes (card16-get 22)) (mode-start (index+ output-start (index* num-outputs 4))) (name-start (index+ mode-start (index* num-modeinfos 32)))) (values (card32-get 8) ; timestamp (card32-get 12) ; config-timestamp (sequence-get :format card32 :result-type result-type :index 32 :length num-crtcs) (sequence-get :format card32 :result-type result-type :index output-start :length num-outputs) (loop :for i fixnum :from 1 :to num-modeinfos :for offset fixnum := mode-start :then (+ offset 32) :collect (rr-mode-info-get offset)) (string-get name-bytes name-start)) )))) (defun rr-get-output-info (display output config-timestamp &optional (result-type 'list)) "FIXME: indexes might be off, name not decoded properly" (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32)) ((data +rr-getoutputinfo+) (card32 output) (card32 config-timestamp)) (let* ((num-crtcs (card16-get 26)) (num-modes (card16-get 28)) (num-clones (card16-get 32)) (name-length (card16-get 34)) (crtc-start 26) (mode-start (index+ crtc-start (index* num-crtcs 4))) (clone-start (index+ mode-start (index* num-modes 4))) (name-start (index+ clone-start (index* num-clones 4)))) (values (member8-vector-get 1 +rr-config-status+) (card32-get 8) ; timestamp (card32-get 12) ; current connected crtc (card32-get 16) ; width in mm (card32-get 20) ; height in mm (member8-vector-get 24 +rr-connection+) (member8-vector-get 25 +render-subpixel-order+) ; sub-pixel-order (sequence-get :result-type result-type :length num-crtcs :index 26) (card16-get 30) (sequence-get :result-type result-type :length num-modes :index mode-start) (sequence-get :result-type result-type :length num-clones :index clone-start) ;(string-get name-length name-start ) (sequence-get :result-type 'string :format card16 :length name-length :index name-start :transform #'code-char)) ))) (defun rr-list-output-properties (display output &optional (result-type 'list)) "Returns a list of atom properties for given display. ?keep it simple and return id's or atom-names?" (declare (type display display) (type card32 output)) (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32)) ((data +rr-listoutputproperties+) (card32 output)) (let ((num-atoms (card16-get 8))) (values (sequence-get :format card32 :result-type result-type :length num-atoms :index +replysize+ :transform #'(lambda (id) (atom-name display id))))))) (defun rr-query-output-property (display output atom &optional (result-type 'list)) "Querys the current properties of an atom. Atom may be referenced by either id or keyword" (let ((atom (if (typep atom 'keyword) (find-atom display atom) atom))) (declare (type display display) (type card32 atom)) (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32)) ((data +rr-queryoutputproperty+) (card32 output) (card32 atom)) (values (boolean-get 8) ; pending (boolean-get 9) ; range (boolean-get 10) ; immutable (sequence-get :result-type result-type :index +replysize+ :length (card32-get 4)))))) (defun rr-configure-output-property (display output atom value-list &optional (pending nil) (range nil)) "Atom can be specified by either id or keyword" (let ((atom (if (typep atom 'keyword) (find-atom display atom) atom)) (seq (coerce value-list 'vector))) (declare (type display display) (type card32 output value-list) (type boolean pending range)) (with-buffer-request (display (randr-opcode display)) (data +rr-configureoutputproperty+) (card32 output) (card32 atom) (boolean pending range) ((sequence :format card32) seq)))) ;; Spec says type is not interpreted, what use? shit, are certain property types tied to certain formats? change if necessary after get-output-property ;; FIXME asynchronous match error (defun rr-change-output-property (display output atom mode data &optional (atom-type 0) ) "Mode may be 0-replace 1-prepend 2-append. atom-type is obtained by calling rr-get-output-property " (let ((atom (if (typep atom 'keyword) (find-atom display atom) atom)) (data-length (length data)) (seq (coerce data 'vector)) ) (with-buffer-request (display (randr-opcode display)) (data +rr-changeoutputproperty+) (card32 output) (card32 atom) (card32 atom-type) (card8 32) ; should we be concerned about extra bytes for small values? (card8 mode) (pad16) (card32 data-length) ((sequence :format card32) seq)))) (defun rr-delete-output-property (display output property) "" (let ((atom (if (typep property 'keyword) (find-atom display property) property))) (with-buffer-request (display (randr-opcode display)) (data +rr-deleteoutputproperty+) (card32 output) (card32 atom)))) (defun rr-get-output-property (display output property &optional (type 0) (delete 0) (pending 0) (result-type 'list)) "" (let ((atom (if (typep property 'keyword) (find-atom display property) property))) (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32)) ((data +rr-getoutputproperty+) (card32 output) (card32 atom) (card32 type) (card32 0) ; long-offset (card32 0) ; long-length (card8 delete) (card8 pending) (pad16)) (let* ((bytes-after (card32-get 12)) (value-length (card32-get 16)) (byte-format (unless (eql value-length 0) (if (eql bytes-after value-length) 'card8 (if (eql 2 (/ bytes-after value-length)) 'card16 'card32))))) (values (card32-get 8) ; type value-length (when (not (eql value-length 0)) (case byte-format ('card8 ( sequence-get :format card8 :index +replysize+ :length value-length :result-type result-type)) ('card16 ( sequence-get :format card16 :index +replysize+ :length value-length :result-type result-type)) ('card32 ( sequence-get :format card32 :index +replysize+ :length value-length :result-type result-type)))) ) )))) (defun rr-create-mode (window mode-info name) "FIXME" (let ((display (window-display window))) (declare (type display display) (type window window) (type rr-mode-info mode-info) (type string name)) (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32)) ((data +rr-createmode+) (window window) (progn (rr-mode-info-put 8 mode-info) (string-put 40 name))) (values (card32-get 8) ; mode )))) (defun rr-destroy-mode (display mode) "" (with-buffer-request (display (randr-opcode display)) (data +rr-destroymode+) (card32 mode))) (defun rr-add-output-mode (display output mode) "" (with-buffer-request (display (randr-opcode display)) (data +rr-addoutputmode+) (card32 output) (card32 mode))) (defun rr-delete-output-mode (display output mode) "" (with-buffer-request (display (randr-opcode display)) (data +rr-deleteoutputmode+) (card32 output) (card32 mode))) (defun rr-get-crtc-info (display crtc config-timestamp &optional (result-type 'list)) "" (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32)) ((data +rr-getcrtcinfo+) (card32 crtc) (card32 config-timestamp)) (let* ((num-outputs (card16-get 28)) (pos-outputs (card16-get 30)) (pos-start (index+ +replysize+ (index* num-outputs 4)))) (values (member8-vector-get 1 +rr-config-status+) (card32-get 8) ; timestamp (int16-get 12) ; x (int16-get 14) ; y (card16-get 16) ; width (card16-get 18) ; height (card32-get 20) ; mode (make-rotation-keys (card16-get 24) ) ; current (make-rotation-keys (card16-get 26)) ; possible (sequence-get :result-type result-type :index +replysize+ :length num-outputs) (sequence-get :result-type result-type :index pos-start :length pos-outputs))))) (defun rr-set-crtc-config (display crtc timestamp config-timestamp x y mode rotation output-list) "Rotation can be a rotation mask or list of rotation keys." (let ((rot-mask (if (consp rotation) (make-rotation-mask rotation) rotation)) (seq (coerce output-list 'vector))) (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32)) ((data +rr-setcrtcconfig+) (card32 crtc) (card32 timestamp) (card32 config-timestamp) (card16 x) (card16 y) (card32 mode) (card16 rot-mask) (pad16) ((sequence :format card32) seq)) (values (member8-vector-get 1 +rr-config-status+) (card32-get 8) ; new timestamp )))) (defun rr-get-crtc-gamma-size (display crtc) "Used to determine length of gamma ramps to submit in set-crtc-gamma" (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32)) ((data +rr-getcrtcgammasize+) (card32 crtc)) (values (card16-get 8)))) (defun rr-get-crtc-gamma (display crtc &optional (result-type 'list)) "Get current gamma ramps, returns 3 sequences for red, green, blue." (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32)) ((data +rr-getcrtcgamma+) (card32 crtc)) (let* ((size (card16-get 8)) (green-start (index+ +replysize+ (index* 2 size))) (blue-start (index+ green-start (index* 2 size)))) (values (sequence-get :format card16 :length size :index +replysize+ :result-type result-type) (sequence-get :format card16 :length size :index green-start :result-type result-type) (sequence-get :format card16 :length size :index blue-start :result-type result-type))))) (defun rr-set-crtc-gamma (display crtc red green blue) "gamma values must be lists and must be the same length as returned by get-crtc-gamma-size" (declare (type cons red green blue)) (let ((size (length blue)) (seq (coerce (append red green blue) 'vector))) (declare (type vector seq) (type display display) (type card16 size)) (with-buffer-request (display (randr-opcode display)) (data +rr-setcrtcgamma+) (card32 crtc) (card16 size) (pad16) ((sequence :format card16) seq)))) ;; version 1.3 (defun rr-get-screen-resources-current (window &optional (result-type 'list )) "Unlike RRGetScreenResources, this merely returns the current configuration, and does not poll for hardware changes." (let ((display (window-display window))) (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32)) ((data +rr-getscreenresourcescurrent+) (window window)) (let* ((num-crtcs (card16-get 16)) (num-outputs (card16-get 18)) (output-start (index+ +replysize+ (index* num-crtcs 4))) (num-modeinfos (card16-get 20)) (name-bytes (card16-get 22)) (mode-start (index+ output-start (index* num-outputs 4))) (name-start (index+ mode-start (index* num-modeinfos 32)))) (values (card32-get 8) ; timestamp (card32-get 12) ; config-timestamp (sequence-get :format card32 :result-type result-type :index 32 :length num-crtcs) (sequence-get :format card32 :result-type result-type :index output-start :length num-outputs) (loop :for i fixnum :from 1 :to num-modeinfos :for offset fixnum := mode-start :then (+ offset 32) :collect (rr-mode-info-get offset)) (string-get name-bytes name-start)))))) ;; (defun rr-set-crtc-transform (display crtc transform &optional ( filter-name nil) ( filter-parameters nil)) ;; "FIXME:Transfrom may be a list or vector of length 9. ?perhaps allow length 6?" ;; (let ((seq (if filter-parameters (coerce filter-parameters 'vector) nil )) ;; (param-length (length filter-parameters)) ;; (name-length (length filter-name))) ;; (declare ;(type vector seq) ;; (type card16 param-length) ;; (type display display) ;; (type string filter-name)) ;; (with-buffer-request (display (randr-opcode display)) ;; (data +rr-setcrtctransform+) ;; (card32 crtc) ;; (card16 param-length) ;; (pad16) ;; (rr-transform transform) ;; (card16 name-length) ;; (pad16) ;; (string filter-name) ;; ; ((sequence :format card32) seq) ;; ;((sequence :format card32) seq) ;; ))) (defun rr-get-crtc-transform (display crtc &optional (result-type 'list)) "" (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32)) ((data +rr-getcrtctransform+) (card32 crtc)) (let* ((pend-name (card16-get 88)) (pend-num-params (card16-get 90)) (pad-pend (- 4 (mod pend-name 4))) (pad-pend-start (index+ 96 pend-name pad-pend)) (cur-name (card16-get 92)) (cur-num-params (card16-get 94)) (pad-cur (- 4 (mod cur-name 4))) (cur-name-start (index+ pad-pend-start (index* 4 pend-num-params))) (cur-param-start (index+ cur-name-start cur-name pad-cur)) ) (declare (type card16 pend-name cur-name)) (values (rr-transform-get 8) ;(sequence-get :result-type result-type :length 9 :index 8) (card8-get 44) (sequence-get :result-type result-type :length 9 :index 48) (string-get pend-name 96) (sequence-get :result-type result-type :length pend-num-params :index pad-pend-start) (string-get cur-name cur-name-start) (sequence-get :result-type result-type :length cur-num-params :index cur-param-start ) )))) ;; (defun rr-get-panning (display crtc) ;; "" ;; (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32)) ;; ((data +rr-getpanning+) ;; (card32 crtc)) ;; (values ;; (member8-vector-get 1 +rr-config-status+) ;; (card32-get 8) ; timestamp ;; (rr-panning-get 12) ;; ;(sequence-get :length 8 :format card16 :index 12 :result-type result-type) ;; ;(sequence-get :length 4 :format int16 :index 28 :result-type result-type) ;; ))) ;; (defun rr-set-panning (display crtc timestamp rr-panning) ;; "" ;; (declare (type rr-panning rr-panning)) ;; (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32)) ;; ((data +rr-setpanning+) ;; (card32 crtc) ;; (card32 timestamp) ;; ; (progn () ;; (rr-panning rr-panning)) ;; (values ;; (member8-vector-get 1 +rr-config-status+) ;; ; (card32-get 8) ; new timestamp ;; ))) (defun rr-set-output-primary (window output) "" (let ((display (window-display window))) (with-buffer-request (display (randr-opcode display)) (data +rr-setoutputprimary+) (window window) (card32 output)))) (defun rr-get-output-primary (window) "" (let ((display (window-display window))) (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32)) ((data +rr-getoutputprimary+) (window window)) (values (card32-get 8) )))) (defun rr-get-providers (window) "" (let ((display (window-display window))) (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32)) ((data +rr-getproviders+) (window window)) (values (card32-get 8) ; timestamp (card16-get 12) ; num providers ; (string-get 1256 14) ; checking if this is supposed to return anything besides just num ; (sequence-get :index 46 :length (card16-get 12) :format card8 :result-type 'list ) )))) (defun rr-get-provider-info (display provider config-timestamp) "" (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32)) ((data +rr-getproviderinfo+) (card32 provider) (card32 config-timestamp)) (values (card32-get 8) ;timestamp (card32-get 12) ; capabilities (card16-get 16) ; num crtcs (card16-get 18) ; num outputs (card16-get 20) ; num associated providers (string-get (card16-get 22) 56)))) (defun rr-set-provider-output-source (display provider source-provider config-timestamp) (with-buffer-request (display (randr-opcode display)) (data +rr-setprovideroutputsource+) (card32 provider) (card32 source-provider) (card32 config-timestamp))) (defun rr-set-provider-offload-sink (display provider sink-provider config-timestamp) (with-buffer-request (display (randr-opcode display)) (data +rr-setprovideroffloadsink+) (card32 provider) (card32 sink-provider) (card32 config-timestamp))) (defun rr-list-provider-properties (display provider) "" (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32)) ((data +rr-listproviderproperties+) (card32 provider)) (values (card32-get 4) (card16-get 8)))) ;; (defun rr-query-provider-property (display provider atom) ;; "untested" ;; (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32)) ;; ((data +rr-queryproviderproperty+) ;; (card32 provider) ;; (card32 atom)) ;; (values ;; (boolean-get 8) ;; (boolean-get 9) ;; (boolean-get 10)))) ;; (defun (display) ;; "" ;; (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32)) ;; ((data)) ;; (values ;; ()))) ;; (defun (display) ;; "" ;; (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32)) ;; ((data)) ;; (values ;; ()))) cl-clx-sbcl-0.7.4.20160323.orig/extensions/gl.lisp0000644000175000017500000034501312715665272017322 0ustar pdmpdm(defpackage :gl (:use :common-lisp :xlib) (:import-from :glx "*CURRENT-CONTEXT*" "CONTEXT" "CONTEXT-P" "CONTEXT-DISPLAY" "CONTEXT-TAG" "CONTEXT-RBUF" "CONTEXT-INDEX" ) (:import-from :xlib "DATA" "WITH-BUFFER-REQUEST" "WITH-BUFFER-REQUEST-AND-REPLY" "CARD32-GET" "SEQUENCE-GET" "WITH-DISPLAY" "DISPLAY-FORCE-OUTPUT" "INT8" "INT16" "INT32" "INTEGER" "CARD8" "CARD16" "CARD32" "ASET-CARD8" "ASET-CARD16" "ASET-CARD32" "ASET-INT8" "ASET-INT16" "ASET-INT32" "DECLARE-BUFFUN" ;; Types "ARRAY-INDEX" "BUFFER-BYTES" ) (:export "GET-STRING" ;; Rendering commands (alphabetical order) "ACCUM" "ACTIVE-TEXTURE-ARB" "ALPHA-FUNC" "BEGIN" "BIND-TEXTURE" "BLEND-COLOR" "BLEND-EQUOTION" "BLEND-FUNC" "CALL-LIST" "CLEAR" "CLEAR-ACCUM" "CLEAR-COLOR" "CLEAR-DEPTH" "CLEAR-INDEX" "CLEAR-STENCIL" "CLIP-PLANE" "COLOR-3B" "COLOR-3D" "COLOR-3F" "COLOR-3I" "COLOR-3S" "COLOR-3UB" "COLOR-3UI" "COLOR-3US" "COLOR-4B" "COLOR-4D" "COLOR-4F" "COLOR-4I" "COLOR-4S" "COLOR-4UB" "COLOR-4UI" "COLOR-4US" "COLOR-MASK" "COLOR-MATERIAL" "CONVOLUTION-PARAMETER-F" "CONVOLUTION-PARAMETER-I" "COPY-COLOR-SUB-TABLE" "COPY-COLOR-TABLE" "COPY-CONVOLUTION-FILTER-ID" "COPY-CONVOLUTION-FILTER-2D" "COPY-PIXELS" "COPY-TEX-IMAGE-1D" "COPY-TEX-IMAGE-2D" "COPY-TEX-SUB-IMAGE-1D" "COPY-TEX-SUB-IMAGE-2D" "COPY-TEX-SUB-IMAGE-3D" "CULL-FACE" "DEPTH-FUNC" "DEPTH-MASK" "DEPTH-RANGE" "DRAW-BUFFER" "EDGE-FLAG-V" "END" "EVAL-COORD-1D" "EVAL-COORD-1F" "EVAL-COORD-2D" "EVAL-COORD-2F" "EVAL-MESH-1" "EVAL-MESH-2" "EVAL-POINT-1" "EVAL-POINT-2" "FOG-F" "FOG-I" "FRONT-FACE" "FRUSTUM" "HINT" "HISTOGRAM" "INDEX-MASK" "INDEX-D" "INDEX-F" "INDEX-I" "INDEX-S" "INDEX-UB" "INIT-NAMES" "LIGHT-MODEL-F" "LIGHT-MODEL-I" "LIGHT-F" "LIGHT-FV" "LIGHT-I" "LIGHT-IV" "LINE-STIPPLE" "LINE-WIDTH" "LIST-BASE" "LOAD-IDENTITY" "LOAD-NAME" "LOGIC-OP" "MAP-GRID-1D" "MAP-GRID-1F" "MAP-GRID-2D" "MAP-GRID-2F" "MATERIAL-F" "MATERIAL-FV" "MATERIAL-I" "MATERIAL-IV" "MATRIX-MODE" "MINMAX" "MULTI-TEX-COORD-1D-ARB" "MULTI-TEX-COORD-1F-ARB" "MULTI-TEX-COORD-1I-ARB" "MULTI-TEX-COORD-1S-ARB" "MULTI-TEX-COORD-2D-ARB" "MULTI-TEX-COORD-2F-ARB" "MULTI-TEX-COORD-2I-ARB" "MULTI-TEX-COORD-2S-ARB" "MULTI-TEX-COORD-3D-ARB" "MULTI-TEX-COORD-3F-ARB" "MULTI-TEX-COORD-3I-ARB" "MULTI-TEX-COORD-3S-ARB" "MULTI-TEX-COORD-4D-ARB" "MULTI-TEX-COORD-4F-ARB" "MULTI-TEX-COORD-4I-ARB" "MULTI-TEX-COORD-4S-ARB" "NORMAL-3B" "NORMAL-3D" "NORMAL-3F" "NORMAL-3I" "NORMAL-3S" "ORTHO" "PASS-THROUGH" "PIXEL-TRANSFER-F" "PIXEL-TRANSFER-I" "PIXEL-ZOOM" "POINT-SIZE" "POLYGON-MODE" "POLYGON-OFFSET" "POP-ATTRIB" "POP-MATRIX" "POP-NAME" "PUSH-ATTRIB" "PUSH-MATRIX" "PUSH-NAME" "RASTER-POS-2D" "RASTER-POS-2F" "RASTER-POS-2I" "RASTER-POS-2S" "RASTER-POS-3D" "RASTER-POS-3F" "RASTER-POS-3I" "RASTER-POS-3S" "RASTER-POS-4D" "RASTER-POS-4F" "RASTER-POS-4I" "RASTER-POS-4S" "READ-BUFFER" "RECT-D" "RECT-F" "RECT-I" "RECT-S" "RESET-HISTOGRAM" "RESET-MINMAX" "ROTATE-D" "ROTATE-F" "SCALE-D" "SCALE-F" "SCISSOR" "SHADE-MODEL" "STENCIL-FUNC" "STENCIL-MASK" "STENCIL-OP" "TEX-ENV-F" "TEX-ENV-I" "TEX-GEN-D" "TEX-GEN-F" "TEX-GEN-I" "TEX-PARAMETER-F" "TEX-PARAMETER-I" "TRANSLATE-D" "TRANSLATE-F" "VERTEX-2D" "VERTEX-2F" "VERTEX-2I" "VERTEX-2S" "VERTEX-3D" "VERTEX-3F" "VERTEX-3I" "VERTEX-3S" "VERTEX-4D" "VERTEX-4F" "VERTEX-4I" "VERTEX-4S" "VIEWPORT" ;; * Where did this come from? ;;"NO-FLOATS" ;; Non-rendering commands "NEW-LIST" "END-LIST" "GEN-LISTS" "ENABLE" "DISABLE" "FLUSH" "FINISH" ;; Constants ;; Boolean "+FALSE+" "+TRUE+" ;; Types "+BYTE+" "+UNSIGNED-BYTE+" "+SHORT+" "+UNSIGNED-SHORT+" "+INT+" "+UNSIGNED-INT+" "+FLOAT+" "+DOUBLE+" "+2-BYTES+" "+3-BYTES+" "+4-BYTES+" ;; Primitives "+POINTS+" "+LINES+" "+LINE-LOOP+" "+LINE-STRIP+" "+TRIANGLES+" "+TRIANGLE-STRIP+" "+triangle-fan+" "+QUADS+" "+QUAD-STRIP+" "+POLYGON+" ;; Arrays "+VERTEX-ARRAY+" "+NORMAL-ARRAY+" "+COLOR-ARRAY+" "+INDEX-ARRAY+" "+TEXTURE-COORD-ARRAY+" "+EDGE-FLAG-ARRAY+" "+VERTEX-ARRAY-SIZE+" "+VERTEX-ARRAY-TYPE+" "+VERTEX-ARRAY-STRIDE+" "+NORMAL-ARRAY-TYPE+" "+NORMAL-ARRAY-STRIDE+" "+COLOR-ARRAY-SIZE+" "+COLOR-ARRAY-TYPE+" "+COLOR-ARRAY-STRIDE+" "+INDEX-ARRAY-TYPE+" "+INDEX-ARRAY-STRIDE+" "+TEXTURE-COORD-ARRAY-SIZE+" "+TEXTURE-COORD-ARRAY-TYPE+" "+TEXTURE-COORD-ARRAY-STRIDE+" "+EDGE-FLAG-ARRAY-STRIDE+" "+VERTEX-ARRAY-POINTER+" "+NORMAL-ARRAY-POINTER+" "+COLOR-ARRAY-POINTER+" "+INDEX-ARRAY-POINTER+" "+TEXTURE-COORD-ARRAY-POINTER+" "+EDGE-FLAG-ARRAY-POINTER+" ;; Array formats "+V2F+" "+V3F+" "+C4UB-V2F+" "+C4UB-V3F+" "+C3F-V3F+" "+N3F-V3F+" "+C4F-N3F-V3F+" "+T2F-V3F+" "+T4F-V4F+" "+T2F-C4UB-V3F+" "+T2F-C3F-V3F+" "+T2F-N3F-V3F+" "+T2F-C4F-N3F-V3F+" "+T4F-C4F-N3F-V4F+" ;; Matrices "+MATRIX-MODE+" "+MODELVIEW+" "+PROJECTION+" "+TEXTURE+" ;; Points "+POINT-SMOOTH+" "+POINT-SIZE+" "+POINT-SIZE-GRANULARITY+" "+POINT-SIZE-RANGE+" ;; Lines "+LINE-SMOOTH+" "+LINE-STIPPLE+" "+LINE-STIPPLE-PATTERN+" "+LINE-STIPPLE-REPEAT+" "+LINE-WIDTH+" "+LINE-WIDTH-GRANULARITY+" "+LINE-WIDTH-RANGE+" ;; Polygons "+POINT+" "+LINE+" "+FILL+" "+CW+" "+CCW+" "+FRONT+" "+BACK+" "+POLYGON-MODE+" "+POLYGON-SMOOTH+" "+POLYGON-STIPPLE+" "+EDGE-FLAG+" "+CULL-FACE+" "+CULL-FACE-MODE+" "+FRONT-FACE+" "+POLYGON-OFFSET-FACTOR+" "+POLYGON-OFFSET-UNITS+" "+POLYGON-OFFSET-POINT+" "+POLYGON-OFFSET-LINE+" "+POLYGON-OFFSET-FILL+" ;; Display Lists "+COMPILE+" "+COMPILE-AND-EXECUTE+" "+LIST-BASE+" "+LIST-INDEX+" "+LIST-MODE+" ;; Depth Buffer "+NEVER+" "+LESS+" "+EQUAL+" "+LEQUAL+" "+GREATER+" "+NOTEQUAL+" "+GEQUAL+" "+ALWAYS+" "+DEPTH-TEST+" "+DEPTH-BITS+" "+DEPTH-CLEAR-VALUE+" "+DEPTH-FUNC+" "+DEPTH-RANGE+" "+DEPTH-WRITEMASK+" "+DEPTH-COMPONENT+" ;; Lighting "+LIGHTING+" "+LIGHT0+" "+LIGHT1+" "+LIGHT2+" "+LIGHT3+" "+LIGHT4+" "+LIGHT5+" "+LIGHT6+" "+LIGHT7+" "+SPOT-EXPONENT+" "+SPOT-CUTOFF+" "+CONSTANT-ATTENUATION+" "+LINEAR-ATTENUATION+" "+QUADRATIC-ATTENUATION+" "+AMBIENT+" "+DIFFUSE+" "+SPECULAR+" "+SHININESS+" "+EMISSION+" "+POSITION+" "+SPOT-DIRECTION+" "+AMBIENT-AND-DIFFUSE+" "+COLOR-INDEXES+" "+LIGHT-MODEL-TWO-SIDE+" "+LIGHT-MODEL-LOCAL-VIEWER+" "+LIGHT-MODEL-AMBIENT+" "+FRONT-AND-BACK+" "+SHADE-MODEL+" "+FLAT+" "+SMOOTH+" "+COLOR-MATERIAL+" "+COLOR-MATERIAL-FACE+" "+COLOR-MATERIAL-PARAMETER+" "+NORMALIZE+" ;; Clipping planes "+CLIP-PLANE0+" "+CLIP-PLANE1+" "+CLIP-PLANE2+" "+CLIP-PLANE3+" "+CLIP-PLANE4+" "+CLIP-PLANE5+" ;; Accumulation buffer "+ACCUM-RED-BITS+" "+ACCUM-GREEN-BITS+" "+ACCUM-BLUE-BITS+" "+ACCUM-ALPHA-BITS+" "+ACCUM-CLEAR-VALUE+" "+ACCUM+" "+ADD+" "+LOAD+" "+MULT+" "+RETURN+" ;; Alpha Testing "+ALPHA-TEST+" "+ALPHA-TEST-REF+" "+ALPHA-TEST-FUNC+" ;; Blending "+BLEND+" "+BLEND-SRC+" "+BLEND-DST+" "+ZERO+" "+ONE+" "+SRC-COLOR+" "+ONE-MINUS-SRC-COLOR+" "+DST-COLOR+" "+ONE-MINUS-DST-COLOR+" "+SRC-ALPHA+" "+ONE-MINUS-SRC-ALPHA+" "+DST-ALPHA+" "+ONE-MINUS-DST-ALPHA+" "+SRC-ALPHA-SATURATE+" "+CONSTANT-COLOR+" "+ONE-MINUS-CONSTANT-COLOR+" "+CONSTANT-ALPHA+" "+ONE-MINUS-CONSTANT-ALPHA+" ;; Render mode "+FEEDBACK+" "+RENDER+" "+SELECT+" ;; Feedback "+2D+" "+3D+" "+3D-COLOR+" "+3D-COLOR-TEXTURE+" "+4D-COLOR-TEXTURE+" "+POINT-TOKEN+" "+LINE-TOKEN+" "+LINE-RESET-TOKEN+" "+POLYGON-TOKEN+" "+BITMAP-TOKEN+" "+DRAW-PIXEL-TOKEN+" "+COPY-PIXEL-TOKEN+" "+PASS-THROUGH-TOKEN+" "+FEEDBACK-BUFFER-POINTER+" "+FEEDBACK-BUFFER-SIZE+" "+FEEDBACK-BUFFER-TYPE+" ;; Selection "+SELECTION-BUFFER-POINTER+" "+SELECTION-BUFFER-SIZE+" ;; Fog "+FOG+" "+FOG-MODE+" "+FOG-DENSITY+" "+FOG-COLOR+" "+FOG-INDEX+" "+FOG-START+" "+FOG-END+" "+LINEAR+" "+EXP+" "+EXP2+" ;; Logic operations "+LOGIC-OP+" "+INDEX-LOGIC-OP+" "+COLOR-LOGIC-OP+" "+LOGIC-OP-MODE+" "+CLEAR+" "+SET+" "+COPY+" "+COPY-INVERTED+" "+NOOP+" "+INVERT+" "+AND+" "+NAND+" "+OR+" "+NOR+" "+XOR+" "+EQUIV+" "+AND-REVERSE+" "+AND-INVERTED+" "+OR-REVERSE+" "+OR-INVERTED+" ;; Stencil "+STENCIL-TEST+" "+STENCIL-WRITEMASK+" "+STENCIL-BITS+" "+STENCIL-FUNC+" "+STENCIL-VALUE-MASK+" "+STENCIL-REF+" "+STENCIL-FAIL+" "+STENCIL-PASS-DEPTH-PASS+" "+STENCIL-PASS-DEPTH-FAIL+" "+STENCIL-CLEAR-VALUE+" "+STENCIL-INDEX+" "+KEEP+" "+REPLACE+" "+INCR+" "+DECR+" ;; Buffers, Pixel Drawing/Reading "+NONE+" "+LEFT+" "+RIGHT+" "+FRONT-LEFT+" "+FRONT-RIGHT+" "+BACK-LEFT+" "+BACK-RIGHT+" "+AUX0+" "+AUX1+" "+AUX2+" "+AUX3+" "+COLOR-INDEX+" "+RED+" "+GREEN+" "+BLUE+" "+ALPHA+" "+LUMINANCE+" "+LUMINANCE-ALPHA+" "+ALPHA-BITS+" "+RED-BITS+" "+GREEN-BITS+" "+BLUE-BITS+" "+INDEX-BITS+" "+SUBPIXEL-BITS+" "+AUX-BUFFERS+" "+READ-BUFFER+" "+DRAW-BUFFER+" "+DOUBLEBUFFER+" "+STEREO+" "+BITMAP+" "+COLOR+" "+DEPTH+" "+STENCIL+" "+DITHER+" "+RGB+" "+RGBA+" ;; Implementation Limits "+MAX-LIST-NESTING+" "+MAX-ATTRIB-STACK-DEPTH+" "+MAX-MODELVIEW-STACK-DEPTH+" "+MAX-NAME-STACK-DEPTH+" "+MAX-PROJECTION-STACK-DEPTH+" "+MAX-TEXTURE-STACK-DEPTH+" "+MAX-EVAL-ORDER+" "+MAX-LIGHTS+" "+MAX-CLIP-PLANES+" "+MAX-TEXTURE-SIZE+" "+MAX-PIXEL-MAP-TABLE+" "+MAX-VIEWPORT-DIMS+" "+MAX-CLIENT-ATTRIB-STACK-DEPTH+" ;; Gets "+ATTRIB-STACK-DEPTH+" "+CLIENT-ATTRIB-STACK-DEPTH+" "+COLOR-CLEAR-VALUE+" "+COLOR-WRITEMASK+" "+CURRENT-INDEX+" "+CURRENT-COLOR+" "+CURRENT-NORMAL+" "+CURRENT-RASTER-COLOR+" "+CURRENT-RASTER-DISTANCE+" "+current-raster-index+" "+CURRENT-RASTER-POSITION+" "+CURRENT-RASTER-TEXTURE-COORDS+" "+CURRENT-RASTER-POSITION-VALID+" "+CURRENT-TEXTURE-COORDS+" "+INDEX-CLEAR-VALUE+" "+INDEX-MODE+" "+INDEX-WRITEMASK+" "+MODELVIEW-MATRIX+" "+MODELVIEW-STACK-DEPTH+" "+NAME-STACK-DEPTH+" "+PROJECTION-MATRIX+" "+PROJECTION-STACK-DEPTH+" "+RENDER-MODE+" "+RGBA-MODE+" "+TEXTURE-MATRIX+" "+TEXTURE-STACK-DEPTH+" "+VIEWPORT+" ;; GL Evaluators "+AUTO-NORMAL+" "+MAP1-COLOR-4+" "+MAP1-GRID-DOMAIN+" "+MAP1-GRID-SEGMENTS+" "+MAP1-INDEX+" "+MAP1-NORMAL+" "+MAP1-TEXTURE-COORD-1+" "+MAP1-TEXTURE-COORD-2+" "+MAP1-TEXTURE-COORD-3+" "+MAP1-TEXTURE-COORD-4+" "+MAP1-VERTEX-3+" "+MAP1-VERTEX-4+" "+MAP2-COLOR-4+" "+MAP2-GRID-DOMAIN+" "+MAP2-GRID-SEGMENTS+" "+MAP2-INDEX+" "+MAP2-NORMAL+" "+MAP2-TEXTURE-COORD-1+" "+MAP2-TEXTURE-COORD-2+" "+MAP2-TEXTURE-COORD-3+" "+MAP2-TEXTURE-COORD-4+" "+MAP2-VERTEX-3+" "+MAP2-VERTEX-4+" "+COEFF+" "+DOMAIN+" "+ORDER+" ;; Hints "+FOG-HINT+" "+LINE-SMOOTH-HINT+" "+PERSPECTIVE-CORRECTION-HINT+" "+POINT-SMOOTH-HINT+" "+POLYGON-SMOOTH-HINT+" "+DONT-CARE+" "+FASTEST+" "+NICEST+" ;; Scissor box "+SCISSOR-TEST+" "+SCISSOR-BOX+" ;; Pixel Mode / Transfer "+MAP-COLOR+" "+MAP-STENCIL+" "+INDEX-SHIFT+" "+INDEX-OFFSET+" "+RED-SCALE+" "+RED-BIAS+" "+GREEN-SCALE+" "+GREEN-BIAS+" "+BLUE-SCALE+" "+BLUE-BIAS+" "+ALPHA-SCALE+" "+ALPHA-BIAS+" "+DEPTH-SCALE+" "+DEPTH-BIAS+" "+PIXEL-MAP-S-TO-S-SIZE+" "+PIXEL-MAP-I-TO-I-SIZE+" "+PIXEL-MAP-I-TO-R-SIZE+" "+PIXEL-MAP-I-TO-G-SIZE+" "+PIXEL-MAP-I-TO-B-SIZE+" "+PIXEL-MAP-I-TO-A-SIZE+" "+PIXEL-MAP-R-TO-R-SIZE+" "+PIXEL-MAP-G-TO-G-SIZE+" "+PIXEL-MAP-B-TO-B-SIZE+" "+PIXEL-MAP-A-TO-A-SIZE+" "+PIXEL-MAP-S-TO-S+" "+PIXEL-MAP-I-TO-I+" "+PIXEL-MAP-I-TO-R+" "+PIXEL-MAP-I-TO-G+" "+PIXEL-MAP-I-TO-B+" "+PIXEL-MAP-I-TO-A+" "+PIXEL-MAP-R-TO-R+" "+PIXEL-MAP-G-TO-G+" "+PIXEL-MAP-B-TO-B+" "+PIXEL-MAP-A-TO-A+" "+PACK-ALIGNMENT+" "+PACK-LSB-FIRST+" "+PACK-ROW-LENGTH+" "+PACK-SKIP-PIXELS+" "+PACK-SKIP-ROWS+" "+PACK-SWAP-BYTES+" "+UNPACK-ALIGNMENT+" "+UNPACK-LSB-FIRST+" "+UNPACK-ROW-LENGTH+" "+UNPACK-SKIP-PIXELS+" "+UNPACK-SKIP-ROWS+" "+UNPACK-SWAP-BYTES+" "+ZOOM-X+" "+ZOOM-Y+" ;; Texture Mapping "+TEXTURE-ENV+" "+TEXTURE-ENV-MODE+" "+TEXTURE-1D+" "+TEXTURE-2D+" "+TEXTURE-WRAP-S+" "+TEXTURE-WRAP-T+" "+TEXTURE-MAG-FILTER+" "+TEXTURE-MIN-FILTER+" "+TEXTURE-ENV-COLOR+" "+TEXTURE-GEN-S+" "+TEXTURE-GEN-T+" "+TEXTURE-GEN-MODE+" "+TEXTURE-BORDER-COLOR+" "+TEXTURE-WIDTH+" "+TEXTURE-HEIGHT+" "+TEXTURE-BORDER+" "+TEXTURE-COMPONENTS+" "+TEXTURE-RED-SIZE+" "+TEXTURE-GREEN-SIZE+" "+TEXTURE-BLUE-SIZE+" "+TEXTURE-ALPHA-SIZE+" "+TEXTURE-LUMINANCE-SIZE+" "+TEXTURE-INTENSITY-SIZE+" "+NEAREST-MIPMAP-NEAREST+" "+NEAREST-MIPMAP-LINEAR+" "+LINEAR-MIPMAP-NEAREST+" "+LINEAR-MIPMAP-LINEAR+" "+OBJECT-LINEAR+" "+OBJECT-PLANE+" "+EYE-LINEAR+" "+EYE-PLANE+" "+SPHERE-MAP+" "+DECAL+" "+MODULATE+" "+NEAREST+" "+REPEAT+" "+CLAMP+" "+S+" "+T+" "+R+" "+Q+" "+TEXTURE-GEN-R+" "+TEXTURE-GEN-Q+" ;; GL 1.1 Texturing "+PROXY-TEXTURE-1D+" "+PROXY-TEXTURE-2D+" "+TEXTURE-PRIORITY+" "+TEXTURE-RESIDENT+" "+TEXTURE-BINDING-1D+" "+TEXTURE-BINDING-2D+" "+TEXTURE-INTERNAL-FORMAT+" "+PACK-SKIP-IMAGES+" "+PACK-IMAGE-HEIGHT+" "+UNPACK-SKIP-IMAGES+" "+UNPACK-IMAGE-HEIGHT+" "+TEXTURE-3D+" "+PROXY-TEXTURE-3D+" "+TEXTURE-DEPTH+" "+TEXTURE-WRAP-R+" "+MAX-3D-TEXTURE-SIZE+" "+TEXTURE-BINDING-3D+" ;; Internal texture formats (GL 1.1) "+ALPHA4+" "+ALPHA8+" "+ALPHA12+" "+ALPHA16+" "+LUMINANCE4+" "+LUMINANCE8+" "+LUMINANCE12+" "+LUMINANCE16+" "+LUMINANCE4-ALPHA4+" "+LUMINANCE6-ALPHA2+" "+LUMINANCE8-ALPHA8+" "+LUMINANCE12-ALPHA4+" "+LUMINANCE12-ALPHA12+" "+LUMINANCE16-ALPHA16+" "+INTENSITY+" "+INTENSITY4+" "+INTENSITY8+" "+INTENSITY12+" "+INTENSITY16+" "+R3-G3-B2+" "+RGB4+" "+RGB5+" "+RGB8+" "+RGB10+" "+RGB12+" "+RGB16+" "+RGBA2+" "+RGBA4+" "+RGB5-A1+" "+RGBA8+" "+rgb10-a2+" "+RGBA12+" "+RGBA16+" ;; Utility "+VENDOR+" "+RENDERER+" "+VERSION+" "+EXTENSIONS+" ;; Errors "+NO-ERROR+" "+INVALID-VALUE+" "+INVALID-ENUM+" "+INVALID-OPERATION+" "+STACK-OVERFLOW+" "+STACK-UNDERFLOW+" "+OUT-OF-MEMORY+" ;; OpenGL 1.2 "+RESCALE-NORMAL+" "+CLAMP-TO-EDGE+" "+MAX-ELEMENTS-VERTICES+" "+MAX-ELEMENTS-INDICES+" "+BGR+" "+BGRA+" "+UNSIGNED-BYTE-3-3-2+" "+UNSIGNED-BYTE-2-3-3-REV+" "+UNSIGNED-SHORT-5-6-5+" "+UNSIGNED-SHORT-5-6-5-REV+" "+UNSIGNED-SHORT-4-4-4-4+" "+UNSIGNED-SHORT-4-4-4-4-REV+" "+UNSIGNED-SHORT-5-5-5-1+" "+UNSIGNED-SHORT-1-5-5-5-REV+" "+UNSIGNED-INT-8-8-8-8+" "+UNSIGNED-INT-8-8-8-8-REV+" "+UNSIGNED-INT-10-10-10-2+" "+UNSIGNED-INT-2-10-10-10-REV+" "+LIGHT-MODEL-COLOR-CONTROL+" "+SINGLE-COLOR+" "+SEPARATE-SPECULAR-COLOR+" "+TEXTURE-MIN-LOD+" "+TEXTURE-MAX-LOD+" "+TEXTURE-BASE-LEVEL+" "+TEXTURE-MAX-LEVEL+" "+SMOOTH-POINT-SIZE-RANGE+" "+SMOOTH-POINT-SIZE-GRANULARITY+" "+SMOOTH-LINE-WIDTH-RANGE+" "+SMOOTH-LINE-WIDTH-GRANULARITY+" "+ALIASED-POINT-SIZE-RANGE+" "+ALIASED-LINE-WIDTH-RANGE+" ;; OpenGL 1.2 Imaging subset ;; GL_EXT_color_table "+COLOR-TABLE+" "+POST-CONVOLUTION-COLOR-TABLE+" "+POST-COLOR-MATRIX-COLOR-TABLE+" "+PROXY-COLOR-TABLE+" "+PROXY-POST-CONVOLUTION-COLOR-TABLE+" "+PROXY-POST-COLOR-MATRIX-COLOR-TABLE+" "+COLOR-TABLE-SCALE+" "+COLOR-TABLE-BIAS+" "+COLOR-TABLE-FORMAT+" "+COLOR-TABLE-WIDTH+" "+COLOR-TABLE-RED-SIZE+" "+COLOR-TABLE-GREEN-SIZE+" "+COLOR-TABLE-BLUE-SIZE+" "+COLOR-TABLE-ALPHA-SIZE+" "+COLOR-TABLE-LUMINANCE-SIZE+" "+COLOR-TABLE-INTENSITY-SIZE+" ;; GL_EXT_convolution and GL_HP_convolution "+CONVOLUTION-1D+" "+CONVOLUTION-2D+" "+SEPARABLE-2D+" "+CONVOLUTION-BORDER-MODE+" "+CONVOLUTION-FILTER-SCALE+" "+CONVOLUTION-FILTER-BIAS+" "+REDUCE+" "+CONVOLUTION-FORMAT+" "+CONVOLUTION-WIDTH+" "+CONVOLUTION-HEIGHT+" "+MAX-CONVOLUTION-WIDTH+" "+MAX-CONVOLUTION-HEIGHT+" "+POST-CONVOLUTION-RED-SCALE+" "+POST-CONVOLUTION-GREEN-SCALE+" "+POST-CONVOLUTION-BLUE-SCALE+" "+POST-CONVOLUTION-ALPHA-SCALE+" "+POST-CONVOLUTION-RED-BIAS+" "+POST-CONVOLUTION-GREEN-BIAS+" "+POST-CONVOLUTION-BLUE-BIAS+" "+POST-CONVOLUTION-ALPHA-BIAS+" "+CONSTANT-BORDER+" "+REPLICATE-BORDER+" "+CONVOLUTION-BORDER-COLOR+" ;; GL_SGI_color_matrix "+COLOR-MATRIX+" "+COLOR-MATRIX-STACK-DEPTH+" "+MAX-COLOR-MATRIX-STACK-DEPTH+" "+POST-COLOR-MATRIX-RED-SCALE+" "+POST-COLOR-MATRIX-GREEN-SCALE+" "+POST-COLOR-MATRIX-BLUE-SCALE+" "+POST-COLOR-MATRIX-ALPHA-SCALE+" "+POST-COLOR-MATRIX-RED-BIAS+" "+POST-COLOR-MATRIX-GREEN-BIAS+" "+POST-COLOR-MATRIX-BLUE-BIAS+" "+POST-COLOR-MATRIX-ALPHA-BIAS+" ;; GL_EXT_histogram "+HISTOGRAM+" "+PROXY-HISTOGRAM+" "+HISTOGRAM-WIDTH+" "+HISTOGRAM-FORMAT+" "+HISTOGRAM-RED-SIZE+" "+HISTOGRAM-GREEN-SIZE+" "+HISTOGRAM-BLUE-SIZE+" "+HISTOGRAM-ALPHA-SIZE+" "+HISTOGRAM-LUMINANCE-SIZE+" "+HISTOGRAM-SINK+" "+MINMAX+" "+MINMAX-FORMAT+" "+MINMAX-SINK+" "+TABLE-TOO-LARGE+" ;; GL_EXT_blend_color, GL_EXT_blend_minmax "+BLEND-EQUATION+" "+MIN+" "+MAX+" "+FUNC-ADD+" "+FUNC-SUBTRACT+" "+FUNC-REVERSE-SUBTRACT+" ;; glPush/PopAttrib bits "+CURRENT-BIT+" "+POINT-BIT+" "+LINE-BIT+" "+POLYGON-BIT+" "+POLYGON-STIPPLE-BIT+" "+PIXEL-MODE-BIT+" "+LIGHTING-BIT+" "+FOG-BIT+" "+DEPTH-BUFFER-BIT+" "+ACCUM-BUFFER-BIT+" "+STENCIL-BUFFER-BIT+" "+VIEWPORT-BIT+" "+TRANSFORM-BIT+" "+ENABLE-BIT+" "+COLOR-BUFFER-BIT+" "+HINT-BIT+" "+EVAL-BIT+" "+LIST-BIT+" "+TEXTURE-BIT+" "+SCISSOR-BIT+" "+ALL-ATTRIB-BITS+" "+CLIENT-PIXEL-STORE-BIT+" "+CLIENT-VERTEX-ARRAY-BIT+" "+CLIENT-ALL-ATTRIB-BITS+" ;; ARB Multitexturing extension "+ARB-MULTITEXTURE+" "+TEXTURE0-ARB+" "+TEXTURE1-ARB+" "+TEXTURE2-ARB+" "+TEXTURE3-ARB+" "+TEXTURE4-ARB+" "+TEXTURE5-ARB+" "+TEXTURE6-ARB+" "+TEXTURE7-ARB+" "+TEXTURE8-ARB+" "+TEXTURE9-ARB+" "+TEXTURE10-ARB+" "+TEXTURE11-ARB+" "+TEXTURE12-ARB+" "+TEXTURE13-ARB+" "+TEXTURE14-ARB+" "+TEXTURE15-ARB+" "+TEXTURE16-ARB+" "+TEXTURE17-ARB+" "+TEXTURE18-ARB+" "+TEXTURE19-ARB+" "+TEXTURE20-ARB+" "+TEXTURE21-ARB+" "+TEXTURE22-ARB+" "+TEXTURE23-ARB+" "+TEXTURE24-ARB+" "+TEXTURE25-ARB+" "+TEXTURE26-ARB+" "+TEXTURE27-ARB+" "+TEXTURE28-ARB+" "+TEXTURE29-ARB+" "+TEXTURE30-ARB+" "+TEXTURE31-ARB+" "+ACTIVE-TEXTURE-ARB+" "+CLIENT-ACTIVE-TEXTURE-ARB+" "+MAX-TEXTURE-UNITS-ARB+" ;;; Misc extensions "+EXT-ABGR+" "+ABGR-EXT+" "+EXT-BLEND-COLOR+" "+CONSTANT-COLOR-EXT+" "+ONE-MINUS-CONSTANT-COLOR-EXT+" "+CONSTANT-ALPHA-EXT+" "+ONE-MINUS-CONSTANT-ALPHA-EXT+" "+blend-color-ext+" "+EXT-POLYGON-OFFSET+" "+POLYGON-OFFSET-EXT+" "+POLYGON-OFFSET-FACTOR-EXT+" "+POLYGON-OFFSET-BIAS-EXT+" "+EXT-TEXTURE3D+" "+PACK-SKIP-IMAGES-EXT+" "+PACK-IMAGE-HEIGHT-EXT+" "+UNPACK-SKIP-IMAGES-EXT+" "+UNPACK-IMAGE-HEIGHT-EXT+" "+TEXTURE-3D-EXT+" "+PROXY-TEXTURE-3D-EXT+" "+TEXTURE-DEPTH-EXT+" "+TEXTURE-WRAP-R-EXT+" "+MAX-3D-TEXTURE-SIZE-EXT+" "+TEXTURE-3D-BINDING-EXT+" "+EXT-TEXTURE-OBJECT+" "+TEXTURE-PRIORITY-EXT+" "+TEXTURE-RESIDENT-EXT+" "+TEXTURE-1D-BINDING-EXT+" "+TEXTURE-2D-BINDING-EXT+" "+EXT-RESCALE-NORMAL+" "+RESCALE-NORMAL-EXT+" "+EXT-VERTEX-ARRAY+" "+VERTEX-ARRAY-EXT+" "+NORMAL-ARRAY-EXT+" "+COLOR-ARRAY-EXT+" "+INDEX-ARRAY-EXT+" "+TEXTURE-COORD-ARRAY-EXT+" "+EDGE-FLAG-ARRAY-EXT+" "+VERTEX-ARRAY-SIZE-EXT+" "+VERTEX-ARRAY-TYPE-EXT+" "+VERTEX-ARRAY-STRIDE-EXT+" "+VERTEX-ARRAY-COUNT-EXT+" "+NORMAL-ARRAY-TYPE-EXT+" "+NORMAL-ARRAY-STRIDE-EXT+" "+NORMAL-ARRAY-COUNT-EXT+" "+COLOR-ARRAY-SIZE-EXT+" "+COLOR-ARRAY-TYPE-EXT+" "+COLOR-ARRAY-STRIDE-EXT+" "+COLOR-ARRAY-COUNT-EXT+" "+INDEX-ARRAY-TYPE-EXT+" "+INDEX-ARRAY-STRIDE-EXT+" "+INDEX-ARRAY-COUNT-EXT+" "+TEXTURE-COORD-ARRAY-SIZE-EXT+" "+TEXTURE-COORD-ARRAY-TYPE-EXT+" "+TEXTURE-COORD-ARRAY-STRIDE-EXT+" "+TEXTURE-COORD-ARRAY-COUNT-EXT+" "+EDGE-FLAG-ARRAY-STRIDE-EXT+" "+EDGE-FLAG-ARRAY-COUNT-EXT+" "+VERTEX-ARRAY-POINTER-EXT+" "+NORMAL-ARRAY-POINTER-EXT+" "+COLOR-ARRAY-POINTER-EXT+" "+INDEX-ARRAY-POINTER-EXT+" "+TEXTURE-COORD-ARRAY-POINTER-EXT+" "+EDGE-FLAG-ARRAY-POINTER-EXT+" "+SGIS-TEXTURE-EDGE-CLAMP+" "+CLAMP-TO-EDGE-SGIS+" "+EXT-BLEND-MINMAX+" "+FUNC-ADD-EXT+" "+MIN-EXT+" "+MAX-EXT+" "+BLEND-EQUATION-EXT+" "+EXT-BLEND-SUBTRACT+" "+FUNC-SUBTRACT-EXT+" "+FUNC-REVERSE-SUBTRACT-EXT+" "+EXT-BLEND-LOGIC-OP+" "+EXT-POINT-PARAMETERS+" "+POINT-SIZE-MIN-EXT+" "+POINT-SIZE-MAX-EXT+" "+POINT-FADE-THRESHOLD-SIZE-EXT+" "+DISTANCE-ATTENUATION-EXT+" "+EXT-PALETTED-TEXTURE+" "+TABLE-TOO-LARGE-EXT+" "+COLOR-TABLE-FORMAT-EXT+" "+COLOR-TABLE-WIDTH-EXT+" "+COLOR-TABLE-RED-SIZE-EXT+" "+COLOR-TABLE-GREEN-SIZE-EXT+" "+COLOR-TABLE-BLUE-SIZE-EXT+" "+COLOR-TABLE-ALPHA-SIZE-EXT+" "+COLOR-TABLE-LUMINANCE-SIZE-EXT+" "+COLOR-TABLE-INTENSITY-SIZE-EXT+" "+TEXTURE-INDEX-SIZE-EXT+" "+COLOR-INDEX1-EXT+" "+COLOR-INDEX2-EXT+" "+COLOR-INDEX4-EXT+" "+COLOR-INDEX8-EXT+" "+COLOR-INDEX12-EXT+" "+COLOR-INDEX16-EXT+" "+EXT-CLIP-VOLUME-HINT+" "+CLIP-VOLUME-CLIPPING-HINT-EXT+" "+EXT-COMPILED-VERTEX-ARRAY+" "+ARRAY-ELEMENT-LOCK-FIRST-EXT+" "+ARRAY-ELEMENT-LOCK-COUNT-EXT+" "+HP-OCCLUSION-TEST+" "+OCCLUSION-TEST-HP+" "+OCCLUSION-TEST-RESULT-HP+" "+EXT-SHARED-TEXTURE-PALETTE+" "+SHARED-TEXTURE-PALETTE-EXT+" "+EXT-STENCIL-WRAP+" "+INCR-WRAP-EXT+" "+DECR-WRAP-EXT+" "+NV-TEXGEN-REFLECTION+" "+NORMAL-MAP-NV+" "+REFLECTION-MAP-NV+" "+EXT-TEXTURE-ENV-ADD+" "+MESA-WINDOW-POS+" "+MESA-RESIZE-BUFFERS+" )) (in-package :gl) ;;; Opcodes. (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +get-string+ 129) (defconstant +new-list+ 101) (defconstant +end-list+ 102) (defconstant +gen-lists+ 104) (defconstant +finish+ 108) (defconstant +disable+ 138) (defconstant +enable+ 139) (defconstant +flush+ 142) ;;; Constants. ;;; Shamelessly taken from CL-SDL. ;; Boolean (defconstant +false+ #x0) (defconstant +true+ #x1) ;; Types (defconstant +byte+ #x1400) (defconstant +unsigned-byte+ #x1401) (defconstant +short+ #x1402) (defconstant +unsigned-short+ #x1403) (defconstant +int+ #x1404) (defconstant +unsigned-int+ #x1405) (defconstant +float+ #x1406) (defconstant +double+ #x140a) (defconstant +2-bytes+ #x1407) (defconstant +3-bytes+ #x1408) (defconstant +4-bytes+ #x1409) ;; Primitives (defconstant +points+ #x0000) (defconstant +lines+ #x0001) (defconstant +line-loop+ #x0002) (defconstant +line-strip+ #x0003) (defconstant +triangles+ #x0004) (defconstant +triangle-strip+ #x0005) (defconstant +triangle-fan+ #x0006) (defconstant +quads+ #x0007) (defconstant +quad-strip+ #x0008) (defconstant +polygon+ #x0009) ;; Arrays (defconstant +vertex-array+ #x8074) (defconstant +normal-array+ #x8075) (defconstant +color-array+ #x8076) (defconstant +index-array+ #x8077) (defconstant +texture-coord-array+ #x8078) (defconstant +edge-flag-array+ #x8079) (defconstant +vertex-array-size+ #x807a) (defconstant +vertex-array-type+ #x807b) (defconstant +vertex-array-stride+ #x807c) (defconstant +normal-array-type+ #x807e) (defconstant +normal-array-stride+ #x807f) (defconstant +color-array-size+ #x8081) (defconstant +color-array-type+ #x8082) (defconstant +color-array-stride+ #x8083) (defconstant +index-array-type+ #x8085) (defconstant +index-array-stride+ #x8086) (defconstant +texture-coord-array-size+ #x8088) (defconstant +texture-coord-array-type+ #x8089) (defconstant +texture-coord-array-stride+ #x808a) (defconstant +edge-flag-array-stride+ #x808c) (defconstant +vertex-array-pointer+ #x808e) (defconstant +normal-array-pointer+ #x808f) (defconstant +color-array-pointer+ #x8090) (defconstant +index-array-pointer+ #x8091) (defconstant +texture-coord-array-pointer+ #x8092) (defconstant +edge-flag-array-pointer+ #x8093) ;; Array formats (defconstant +v2f+ #x2a20) (defconstant +v3f+ #x2a21) (defconstant +c4ub-v2f+ #x2a22) (defconstant +c4ub-v3f+ #x2a23) (defconstant +c3f-v3f+ #x2a24) (defconstant +n3f-v3f+ #x2a25) (defconstant +c4f-n3f-v3f+ #x2a26) (defconstant +t2f-v3f+ #x2a27) (defconstant +t4f-v4f+ #x2a28) (defconstant +t2f-c4ub-v3f+ #x2a29) (defconstant +t2f-c3f-v3f+ #x2a2a) (defconstant +t2f-n3f-v3f+ #x2a2b) (defconstant +t2f-c4f-n3f-v3f+ #x2a2c) (defconstant +t4f-c4f-n3f-v4f+ #x2a2d) ;; Matrices (defconstant +matrix-mode+ #x0ba0) (defconstant +modelview+ #x1700) (defconstant +projection+ #x1701) (defconstant +texture+ #x1702) ;; Points (defconstant +point-smooth+ #x0b10) (defconstant +point-size+ #x0b11) (defconstant +point-size-granularity+ #x0b13) (defconstant +point-size-range+ #x0b12) ;; Lines (defconstant +line-smooth+ #x0b20) (defconstant +line-stipple+ #x0b24) (defconstant +line-stipple-pattern+ #x0b25) (defconstant +line-stipple-repeat+ #x0b26) (defconstant +line-width+ #x0b21) (defconstant +line-width-granularity+ #x0b23) (defconstant +line-width-range+ #x0b22) ;; Polygons (defconstant +point+ #x1b00) (defconstant +line+ #x1b01) (defconstant +fill+ #x1b02) (defconstant +cw+ #x0900) (defconstant +ccw+ #x0901) (defconstant +front+ #x0404) (defconstant +back+ #x0405) (defconstant +polygon-mode+ #x0b40) (defconstant +polygon-smooth+ #x0b41) (defconstant +polygon-stipple+ #x0b42) (defconstant +edge-flag+ #x0b43) (defconstant +cull-face+ #x0b44) (defconstant +cull-face-mode+ #x0b45) (defconstant +front-face+ #x0b46) (defconstant +polygon-offset-factor+ #x8038) (defconstant +polygon-offset-units+ #x2a00) (defconstant +polygon-offset-point+ #x2a01) (defconstant +polygon-offset-line+ #x2a02) (defconstant +polygon-offset-fill+ #x8037) ;; Display Lists (defconstant +compile+ #x1300) (defconstant +compile-and-execute+ #x1301) (defconstant +list-base+ #x0b32) (defconstant +list-index+ #x0b33) (defconstant +list-mode+ #x0b30) ;; Depth Buffer (defconstant +never+ #x0200) (defconstant +less+ #x0201) (defconstant +equal+ #x0202) (defconstant +lequal+ #x0203) (defconstant +greater+ #x0204) (defconstant +notequal+ #x0205) (defconstant +gequal+ #x0206) (defconstant +always+ #x0207) (defconstant +depth-test+ #x0b71) (defconstant +depth-bits+ #x0d56) (defconstant +depth-clear-value+ #x0b73) (defconstant +depth-func+ #x0b74) (defconstant +depth-range+ #x0b70) (defconstant +depth-writemask+ #x0b72) (defconstant +depth-component+ #x1902) ;; Lighting (defconstant +lighting+ #x0b50) (defconstant +light0+ #x4000) (defconstant +light1+ #x4001) (defconstant +light2+ #x4002) (defconstant +light3+ #x4003) (defconstant +light4+ #x4004) (defconstant +light5+ #x4005) (defconstant +light6+ #x4006) (defconstant +light7+ #x4007) (defconstant +spot-exponent+ #x1205) (defconstant +spot-cutoff+ #x1206) (defconstant +constant-attenuation+ #x1207) (defconstant +linear-attenuation+ #x1208) (defconstant +quadratic-attenuation+ #x1209) (defconstant +ambient+ #x1200) (defconstant +diffuse+ #x1201) (defconstant +specular+ #x1202) (defconstant +shininess+ #x1601) (defconstant +emission+ #x1600) (defconstant +position+ #x1203) (defconstant +spot-direction+ #x1204) (defconstant +ambient-and-diffuse+ #x1602) (defconstant +color-indexes+ #x1603) (defconstant +light-model-two-side+ #x0b52) (defconstant +light-model-local-viewer+ #x0b51) (defconstant +light-model-ambient+ #x0b53) (defconstant +front-and-back+ #x0408) (defconstant +shade-model+ #x0b54) (defconstant +flat+ #x1d00) (defconstant +smooth+ #x1d01) (defconstant +color-material+ #x0b57) (defconstant +color-material-face+ #x0b55) (defconstant +color-material-parameter+ #x0b56) (defconstant +normalize+ #x0ba1) ;; Clipping planes (defconstant +clip-plane0+ #x3000) (defconstant +clip-plane1+ #x3001) (defconstant +clip-plane2+ #x3002) (defconstant +clip-plane3+ #x3003) (defconstant +clip-plane4+ #x3004) (defconstant +clip-plane5+ #x3005) ;; Accumulation buffer (defconstant +accum-red-bits+ #x0d58) (defconstant +accum-green-bits+ #x0d59) (defconstant +accum-blue-bits+ #x0d5a) (defconstant +accum-alpha-bits+ #x0d5b) (defconstant +accum-clear-value+ #x0b80) (defconstant +accum+ #x0100) (defconstant +add+ #x0104) (defconstant +load+ #x0101) (defconstant +mult+ #x0103) (defconstant +return+ #x0102) ;; Alpha Testing (defconstant +alpha-test+ #x0bc0) (defconstant +alpha-test-ref+ #x0bc2) (defconstant +alpha-test-func+ #x0bc1) ;; Blending (defconstant +blend+ #x0be2) (defconstant +blend-src+ #x0be1) (defconstant +blend-dst+ #x0be0) (defconstant +zero+ #x0) (defconstant +one+ #x1) (defconstant +src-color+ #x0300) (defconstant +one-minus-src-color+ #x0301) (defconstant +dst-color+ #x0306) (defconstant +one-minus-dst-color+ #x0307) (defconstant +src-alpha+ #x0302) (defconstant +one-minus-src-alpha+ #x0303) (defconstant +dst-alpha+ #x0304) (defconstant +one-minus-dst-alpha+ #x0305) (defconstant +src-alpha-saturate+ #x0308) (defconstant +constant-color+ #x8001) (defconstant +one-minus-constant-color+ #x8002) (defconstant +constant-alpha+ #x8003) (defconstant +one-minus-constant-alpha+ #x8004) ;; Render mode (defconstant +feedback+ #x1c01) (defconstant +render+ #x1c00) (defconstant +select+ #x1c02) ;; Feedback (defconstant +2d+ #x0600) (defconstant +3d+ #x0601) (defconstant +3d-color+ #x0602) (defconstant +3d-color-texture+ #x0603) (defconstant +4d-color-texture+ #x0604) (defconstant +point-token+ #x0701) (defconstant +line-token+ #x0702) (defconstant +line-reset-token+ #x0707) (defconstant +polygon-token+ #x0703) (defconstant +bitmap-token+ #x0704) (defconstant +draw-pixel-token+ #x0705) (defconstant +copy-pixel-token+ #x0706) (defconstant +pass-through-token+ #x0700) (defconstant +feedback-buffer-pointer+ #x0df0) (defconstant +feedback-buffer-size+ #x0df1) (defconstant +feedback-buffer-type+ #x0df2) ;; Selection (defconstant +selection-buffer-pointer+ #x0df3) (defconstant +selection-buffer-size+ #x0df4) ;; Fog (defconstant +fog+ #x0b60) (defconstant +fog-mode+ #x0b65) (defconstant +fog-density+ #x0b62) (defconstant +fog-color+ #x0b66) (defconstant +fog-index+ #x0b61) (defconstant +fog-start+ #x0b63) (defconstant +fog-end+ #x0b64) (defconstant +linear+ #x2601) (defconstant +exp+ #x0800) (defconstant +exp2+ #x0801) ;; Logic operations (defconstant +logic-op+ #x0bf1) (defconstant +index-logic-op+ #x0bf1) (defconstant +color-logic-op+ #x0bf2) (defconstant +logic-op-mode+ #x0bf0) (defconstant +clear+ #x1500) (defconstant +set+ #x150f) (defconstant +copy+ #x1503) (defconstant +copy-inverted+ #x150c) (defconstant +noop+ #x1505) (defconstant +invert+ #x150a) (defconstant +and+ #x1501) (defconstant +nand+ #x150e) (defconstant +or+ #x1507) (defconstant +nor+ #x1508) (defconstant +xor+ #x1506) (defconstant +equiv+ #x1509) (defconstant +and-reverse+ #x1502) (defconstant +and-inverted+ #x1504) (defconstant +or-reverse+ #x150b) (defconstant +or-inverted+ #x150d) ;; Stencil (defconstant +stencil-test+ #x0b90) (defconstant +stencil-writemask+ #x0b98) (defconstant +stencil-bits+ #x0d57) (defconstant +stencil-func+ #x0b92) (defconstant +stencil-value-mask+ #x0b93) (defconstant +stencil-ref+ #x0b97) (defconstant +stencil-fail+ #x0b94) (defconstant +stencil-pass-depth-pass+ #x0b96) (defconstant +stencil-pass-depth-fail+ #x0b95) (defconstant +stencil-clear-value+ #x0b91) (defconstant +stencil-index+ #x1901) (defconstant +keep+ #x1e00) (defconstant +replace+ #x1e01) (defconstant +incr+ #x1e02) (defconstant +decr+ #x1e03) ;; Buffers, Pixel Drawing/Reading (defconstant +none+ #x0) (defconstant +left+ #x0406) (defconstant +right+ #x0407) (defconstant +front-left+ #x0400) (defconstant +front-right+ #x0401) (defconstant +back-left+ #x0402) (defconstant +back-right+ #x0403) (defconstant +aux0+ #x0409) (defconstant +aux1+ #x040a) (defconstant +aux2+ #x040b) (defconstant +aux3+ #x040c) (defconstant +color-index+ #x1900) (defconstant +red+ #x1903) (defconstant +green+ #x1904) (defconstant +blue+ #x1905) (defconstant +alpha+ #x1906) (defconstant +luminance+ #x1909) (defconstant +luminance-alpha+ #x190a) (defconstant +alpha-bits+ #x0d55) (defconstant +red-bits+ #x0d52) (defconstant +green-bits+ #x0d53) (defconstant +blue-bits+ #x0d54) (defconstant +index-bits+ #x0d51) (defconstant +subpixel-bits+ #x0d50) (defconstant +aux-buffers+ #x0c00) (defconstant +read-buffer+ #x0c02) (defconstant +draw-buffer+ #x0c01) (defconstant +doublebuffer+ #x0c32) (defconstant +stereo+ #x0c33) (defconstant +bitmap+ #x1a00) (defconstant +color+ #x1800) (defconstant +depth+ #x1801) (defconstant +stencil+ #x1802) (defconstant +dither+ #x0bd0) (defconstant +rgb+ #x1907) (defconstant +rgba+ #x1908) ;; Implementation Limits (defconstant +max-list-nesting+ #x0b31) (defconstant +max-attrib-stack-depth+ #x0d35) (defconstant +max-modelview-stack-depth+ #x0d36) (defconstant +max-name-stack-depth+ #x0d37) (defconstant +max-projection-stack-depth+ #x0d38) (defconstant +max-texture-stack-depth+ #x0d39) (defconstant +max-eval-order+ #x0d30) (defconstant +max-lights+ #x0d31) (defconstant +max-clip-planes+ #x0d32) (defconstant +max-texture-size+ #x0d33) (defconstant +max-pixel-map-table+ #x0d34) (defconstant +max-viewport-dims+ #x0d3a) (defconstant +max-client-attrib-stack-depth+ #x0d3b) ;; Gets (defconstant +attrib-stack-depth+ #x0bb0) (defconstant +client-attrib-stack-depth+ #x0bb1) (defconstant +color-clear-value+ #x0c22) (defconstant +color-writemask+ #x0c23) (defconstant +current-index+ #x0b01) (defconstant +current-color+ #x0b00) (defconstant +current-normal+ #x0b02) (defconstant +current-raster-color+ #x0b04) (defconstant +current-raster-distance+ #x0b09) (defconstant +current-raster-index+ #x0b05) (defconstant +current-raster-position+ #x0b07) (defconstant +current-raster-texture-coords+ #x0b06) (defconstant +current-raster-position-valid+ #x0b08) (defconstant +current-texture-coords+ #x0b03) (defconstant +index-clear-value+ #x0c20) (defconstant +index-mode+ #x0c30) (defconstant +index-writemask+ #x0c21) (defconstant +modelview-matrix+ #x0ba6) (defconstant +modelview-stack-depth+ #x0ba3) (defconstant +name-stack-depth+ #x0d70) (defconstant +projection-matrix+ #x0ba7) (defconstant +projection-stack-depth+ #x0ba4) (defconstant +render-mode+ #x0c40) (defconstant +rgba-mode+ #x0c31) (defconstant +texture-matrix+ #x0ba8) (defconstant +texture-stack-depth+ #x0ba5) (defconstant +viewport+ #x0ba2) ;; GL Evaluators (defconstant +auto-normal+ #x0d80) (defconstant +map1-color-4+ #x0d90) (defconstant +map1-grid-domain+ #x0dd0) (defconstant +map1-grid-segments+ #x0dd1) (defconstant +map1-index+ #x0d91) (defconstant +map1-normal+ #x0d92) (defconstant +map1-texture-coord-1+ #x0d93) (defconstant +map1-texture-coord-2+ #x0d94) (defconstant +map1-texture-coord-3+ #x0d95) (defconstant +map1-texture-coord-4+ #x0d96) (defconstant +map1-vertex-3+ #x0d97) (defconstant +map1-vertex-4+ #x0d98) (defconstant +map2-color-4+ #x0db0) (defconstant +map2-grid-domain+ #x0dd2) (defconstant +map2-grid-segments+ #x0dd3) (defconstant +map2-index+ #x0db1) (defconstant +map2-normal+ #x0db2) (defconstant +map2-texture-coord-1+ #x0db3) (defconstant +map2-texture-coord-2+ #x0db4) (defconstant +map2-texture-coord-3+ #x0db5) (defconstant +map2-texture-coord-4+ #x0db6) (defconstant +map2-vertex-3+ #x0db7) (defconstant +map2-vertex-4+ #x0db8) (defconstant +coeff+ #x0a00) (defconstant +domain+ #x0a02) (defconstant +order+ #x0a01) ;; Hints (defconstant +fog-hint+ #x0c54) (defconstant +line-smooth-hint+ #x0c52) (defconstant +perspective-correction-hint+ #x0c50) (defconstant +point-smooth-hint+ #x0c51) (defconstant +polygon-smooth-hint+ #x0c53) (defconstant +dont-care+ #x1100) (defconstant +fastest+ #x1101) (defconstant +nicest+ #x1102) ;; Scissor box (defconstant +scissor-test+ #x0c11) (defconstant +scissor-box+ #x0c10) ;; Pixel Mode / Transfer (defconstant +map-color+ #x0d10) (defconstant +map-stencil+ #x0d11) (defconstant +index-shift+ #x0d12) (defconstant +index-offset+ #x0d13) (defconstant +red-scale+ #x0d14) (defconstant +red-bias+ #x0d15) (defconstant +green-scale+ #x0d18) (defconstant +green-bias+ #x0d19) (defconstant +blue-scale+ #x0d1a) (defconstant +blue-bias+ #x0d1b) (defconstant +alpha-scale+ #x0d1c) (defconstant +alpha-bias+ #x0d1d) (defconstant +depth-scale+ #x0d1e) (defconstant +depth-bias+ #x0d1f) (defconstant +pixel-map-s-to-s-size+ #x0cb1) (defconstant +pixel-map-i-to-i-size+ #x0cb0) (defconstant +pixel-map-i-to-r-size+ #x0cb2) (defconstant +pixel-map-i-to-g-size+ #x0cb3) (defconstant +pixel-map-i-to-b-size+ #x0cb4) (defconstant +pixel-map-i-to-a-size+ #x0cb5) (defconstant +pixel-map-r-to-r-size+ #x0cb6) (defconstant +pixel-map-g-to-g-size+ #x0cb7) (defconstant +pixel-map-b-to-b-size+ #x0cb8) (defconstant +pixel-map-a-to-a-size+ #x0cb9) (defconstant +pixel-map-s-to-s+ #x0c71) (defconstant +pixel-map-i-to-i+ #x0c70) (defconstant +pixel-map-i-to-r+ #x0c72) (defconstant +pixel-map-i-to-g+ #x0c73) (defconstant +pixel-map-i-to-b+ #x0c74) (defconstant +pixel-map-i-to-a+ #x0c75) (defconstant +pixel-map-r-to-r+ #x0c76) (defconstant +pixel-map-g-to-g+ #x0c77) (defconstant +pixel-map-b-to-b+ #x0c78) (defconstant +pixel-map-a-to-a+ #x0c79) (defconstant +pack-alignment+ #x0d05) (defconstant +pack-lsb-first+ #x0d01) (defconstant +pack-row-length+ #x0d02) (defconstant +pack-skip-pixels+ #x0d04) (defconstant +pack-skip-rows+ #x0d03) (defconstant +pack-swap-bytes+ #x0d00) (defconstant +unpack-alignment+ #x0cf5) (defconstant +unpack-lsb-first+ #x0cf1) (defconstant +unpack-row-length+ #x0cf2) (defconstant +unpack-skip-pixels+ #x0cf4) (defconstant +unpack-skip-rows+ #x0cf3) (defconstant +unpack-swap-bytes+ #x0cf0) (defconstant +zoom-x+ #x0d16) (defconstant +zoom-y+ #x0d17) ;; Texture Mapping (defconstant +texture-env+ #x2300) (defconstant +texture-env-mode+ #x2200) (defconstant +texture-1d+ #x0de0) (defconstant +texture-2d+ #x0de1) (defconstant +texture-wrap-s+ #x2802) (defconstant +texture-wrap-t+ #x2803) (defconstant +texture-mag-filter+ #x2800) (defconstant +texture-min-filter+ #x2801) (defconstant +texture-env-color+ #x2201) (defconstant +texture-gen-s+ #x0c60) (defconstant +texture-gen-t+ #x0c61) (defconstant +texture-gen-mode+ #x2500) (defconstant +texture-border-color+ #x1004) (defconstant +texture-width+ #x1000) (defconstant +texture-height+ #x1001) (defconstant +texture-border+ #x1005) (defconstant +texture-components+ #x1003) (defconstant +texture-red-size+ #x805c) (defconstant +texture-green-size+ #x805d) (defconstant +texture-blue-size+ #x805e) (defconstant +texture-alpha-size+ #x805f) (defconstant +texture-luminance-size+ #x8060) (defconstant +texture-intensity-size+ #x8061) (defconstant +nearest-mipmap-nearest+ #x2700) (defconstant +nearest-mipmap-linear+ #x2702) (defconstant +linear-mipmap-nearest+ #x2701) (defconstant +linear-mipmap-linear+ #x2703) (defconstant +object-linear+ #x2401) (defconstant +object-plane+ #x2501) (defconstant +eye-linear+ #x2400) (defconstant +eye-plane+ #x2502) (defconstant +sphere-map+ #x2402) (defconstant +decal+ #x2101) (defconstant +modulate+ #x2100) (defconstant +nearest+ #x2600) (defconstant +repeat+ #x2901) (defconstant +clamp+ #x2900) (defconstant +s+ #x2000) (defconstant +t+ #x2001) (defconstant +r+ #x2002) (defconstant +q+ #x2003) (defconstant +texture-gen-r+ #x0c62) (defconstant +texture-gen-q+ #x0c63) ;; GL 1.1 Texturing (defconstant +proxy-texture-1d+ #x8063) (defconstant +proxy-texture-2d+ #x8064) (defconstant +texture-priority+ #x8066) (defconstant +texture-resident+ #x8067) (defconstant +texture-binding-1d+ #x8068) (defconstant +texture-binding-2d+ #x8069) (defconstant +texture-internal-format+ #x1003) (defconstant +pack-skip-images+ #x806b) (defconstant +pack-image-height+ #x806c) (defconstant +unpack-skip-images+ #x806d) (defconstant +unpack-image-height+ #x806e) (defconstant +texture-3d+ #x806f) (defconstant +proxy-texture-3d+ #x8070) (defconstant +texture-depth+ #x8071) (defconstant +texture-wrap-r+ #x8072) (defconstant +max-3d-texture-size+ #x8073) (defconstant +texture-binding-3d+ #x806a) ;; Internal texture formats (GL 1.1) (defconstant +alpha4+ #x803b) (defconstant +alpha8+ #x803c) (defconstant +alpha12+ #x803d) (defconstant +alpha16+ #x803e) (defconstant +luminance4+ #x803f) (defconstant +luminance8+ #x8040) (defconstant +luminance12+ #x8041) (defconstant +luminance16+ #x8042) (defconstant +luminance4-alpha4+ #x8043) (defconstant +luminance6-alpha2+ #x8044) (defconstant +luminance8-alpha8+ #x8045) (defconstant +luminance12-alpha4+ #x8046) (defconstant +luminance12-alpha12+ #x8047) (defconstant +luminance16-alpha16+ #x8048) (defconstant +intensity+ #x8049) (defconstant +intensity4+ #x804a) (defconstant +intensity8+ #x804b) (defconstant +intensity12+ #x804c) (defconstant +intensity16+ #x804d) (defconstant +r3-g3-b2+ #x2a10) (defconstant +rgb4+ #x804f) (defconstant +rgb5+ #x8050) (defconstant +rgb8+ #x8051) (defconstant +rgb10+ #x8052) (defconstant +rgb12+ #x8053) (defconstant +rgb16+ #x8054) (defconstant +rgba2+ #x8055) (defconstant +rgba4+ #x8056) (defconstant +rgb5-a1+ #x8057) (defconstant +rgba8+ #x8058) (defconstant +rgb10-a2+ #x8059) (defconstant +rgba12+ #x805a) (defconstant +rgba16+ #x805b) ;; Utility (defconstant +vendor+ #x1f00) (defconstant +renderer+ #x1f01) (defconstant +version+ #x1f02) (defconstant +extensions+ #x1f03) ;; Errors (defconstant +no-error+ #x0) (defconstant +invalid-value+ #x0501) (defconstant +invalid-enum+ #x0500) (defconstant +invalid-operation+ #x0502) (defconstant +stack-overflow+ #x0503) (defconstant +stack-underflow+ #x0504) (defconstant +out-of-memory+ #x0505) ;; OpenGL 1.2 (defconstant +rescale-normal+ #x803a) (defconstant +clamp-to-edge+ #x812f) (defconstant +max-elements-vertices+ #x80e8) (defconstant +max-elements-indices+ #x80e9) (defconstant +bgr+ #x80e0) (defconstant +bgra+ #x80e1) (defconstant +unsigned-byte-3-3-2+ #x8032) (defconstant +unsigned-byte-2-3-3-rev+ #x8362) (defconstant +unsigned-short-5-6-5+ #x8363) (defconstant +unsigned-short-5-6-5-rev+ #x8364) (defconstant +unsigned-short-4-4-4-4+ #x8033) (defconstant +unsigned-short-4-4-4-4-rev+ #x8365) (defconstant +unsigned-short-5-5-5-1+ #x8034) (defconstant +unsigned-short-1-5-5-5-rev+ #x8366) (defconstant +unsigned-int-8-8-8-8+ #x8035) (defconstant +unsigned-int-8-8-8-8-rev+ #x8367) (defconstant +unsigned-int-10-10-10-2+ #x8036) (defconstant +unsigned-int-2-10-10-10-rev+ #x8368) (defconstant +light-model-color-control+ #x81f8) (defconstant +single-color+ #x81f9) (defconstant +separate-specular-color+ #x81fa) (defconstant +texture-min-lod+ #x813a) (defconstant +texture-max-lod+ #x813b) (defconstant +texture-base-level+ #x813c) (defconstant +texture-max-level+ #x813d) (defconstant +smooth-point-size-range+ #x0b12) (defconstant +smooth-point-size-granularity+ #x0b13) (defconstant +smooth-line-width-range+ #x0b22) (defconstant +smooth-line-width-granularity+ #x0b23) (defconstant +aliased-point-size-range+ #x846d) (defconstant +aliased-line-width-range+ #x846e) ;; OpenGL 1.2 Imaging subset ;; GL_EXT_color_table (defconstant +color-table+ #x80d0) (defconstant +post-convolution-color-table+ #x80d1) (defconstant +post-color-matrix-color-table+ #x80d2) (defconstant +proxy-color-table+ #x80d3) (defconstant +proxy-post-convolution-color-table+ #x80d4) (defconstant +proxy-post-color-matrix-color-table+ #x80d5) (defconstant +color-table-scale+ #x80d6) (defconstant +color-table-bias+ #x80d7) (defconstant +color-table-format+ #x80d8) (defconstant +color-table-width+ #x80d9) (defconstant +color-table-red-size+ #x80da) (defconstant +color-table-green-size+ #x80db) (defconstant +color-table-blue-size+ #x80dc) (defconstant +color-table-alpha-size+ #x80dd) (defconstant +color-table-luminance-size+ #x80de) (defconstant +color-table-intensity-size+ #x80df) ;; GL_EXT_convolution and GL_HP_convolution (defconstant +convolution-1d+ #x8010) (defconstant +convolution-2d+ #x8011) (defconstant +separable-2d+ #x8012) (defconstant +convolution-border-mode+ #x8013) (defconstant +convolution-filter-scale+ #x8014) (defconstant +convolution-filter-bias+ #x8015) (defconstant +reduce+ #x8016) (defconstant +convolution-format+ #x8017) (defconstant +convolution-width+ #x8018) (defconstant +convolution-height+ #x8019) (defconstant +max-convolution-width+ #x801a) (defconstant +max-convolution-height+ #x801b) (defconstant +post-convolution-red-scale+ #x801c) (defconstant +post-convolution-green-scale+ #x801d) (defconstant +post-convolution-blue-scale+ #x801e) (defconstant +post-convolution-alpha-scale+ #x801f) (defconstant +post-convolution-red-bias+ #x8020) (defconstant +post-convolution-green-bias+ #x8021) (defconstant +post-convolution-blue-bias+ #x8022) (defconstant +post-convolution-alpha-bias+ #x8023) (defconstant +constant-border+ #x8151) (defconstant +replicate-border+ #x8153) (defconstant +convolution-border-color+ #x8154) ;; GL_SGI_color_matrix (defconstant +color-matrix+ #x80b1) (defconstant +color-matrix-stack-depth+ #x80b2) (defconstant +max-color-matrix-stack-depth+ #x80b3) (defconstant +post-color-matrix-red-scale+ #x80b4) (defconstant +post-color-matrix-green-scale+ #x80b5) (defconstant +post-color-matrix-blue-scale+ #x80b6) (defconstant +post-color-matrix-alpha-scale+ #x80b7) (defconstant +post-color-matrix-red-bias+ #x80b8) (defconstant +post-color-matrix-green-bias+ #x80b9) (defconstant +post-color-matrix-blue-bias+ #x80ba) (defconstant +post-color-matrix-alpha-bias+ #x80bb) ;; GL_EXT_histogram (defconstant +histogram+ #x8024) (defconstant +proxy-histogram+ #x8025) (defconstant +histogram-width+ #x8026) (defconstant +histogram-format+ #x8027) (defconstant +histogram-red-size+ #x8028) (defconstant +histogram-green-size+ #x8029) (defconstant +histogram-blue-size+ #x802a) (defconstant +histogram-alpha-size+ #x802b) (defconstant +histogram-luminance-size+ #x802c) (defconstant +histogram-sink+ #x802d) (defconstant +minmax+ #x802e) (defconstant +minmax-format+ #x802f) (defconstant +minmax-sink+ #x8030) (defconstant +table-too-large+ #x8031) ;; GL_EXT_blend_color, GL_EXT_blend_minmax (defconstant +blend-equation+ #x8009) (defconstant +min+ #x8007) (defconstant +max+ #x8008) (defconstant +func-add+ #x8006) (defconstant +func-subtract+ #x800a) (defconstant +func-reverse-subtract+ #x800b) ;; glPush/PopAttrib bits (defconstant +current-bit+ #x00000001) (defconstant +point-bit+ #x00000002) (defconstant +line-bit+ #x00000004) (defconstant +polygon-bit+ #x00000008) (defconstant +polygon-stipple-bit+ #x00000010) (defconstant +pixel-mode-bit+ #x00000020) (defconstant +lighting-bit+ #x00000040) (defconstant +fog-bit+ #x00000080) (defconstant +depth-buffer-bit+ #x00000100) (defconstant +accum-buffer-bit+ #x00000200) (defconstant +stencil-buffer-bit+ #x00000400) (defconstant +viewport-bit+ #x00000800) (defconstant +transform-bit+ #x00001000) (defconstant +enable-bit+ #x00002000) (defconstant +color-buffer-bit+ #x00004000) (defconstant +hint-bit+ #x00008000) (defconstant +eval-bit+ #x00010000) (defconstant +list-bit+ #x00020000) (defconstant +texture-bit+ #x00040000) (defconstant +scissor-bit+ #x00080000) (defconstant +all-attrib-bits+ #x000fffff) (defconstant +client-pixel-store-bit+ #x00000001) (defconstant +client-vertex-array-bit+ #x00000002) (defconstant +client-all-attrib-bits+ #xffffffff) ;; ARB Multitexturing extension (defconstant +arb-multitexture+ 1) (defconstant +texture0-arb+ #x84c0) (defconstant +texture1-arb+ #x84c1) (defconstant +texture2-arb+ #x84c2) (defconstant +texture3-arb+ #x84c3) (defconstant +texture4-arb+ #x84c4) (defconstant +texture5-arb+ #x84c5) (defconstant +texture6-arb+ #x84c6) (defconstant +texture7-arb+ #x84c7) (defconstant +texture8-arb+ #x84c8) (defconstant +texture9-arb+ #x84c9) (defconstant +texture10-arb+ #x84ca) (defconstant +texture11-arb+ #x84cb) (defconstant +texture12-arb+ #x84cc) (defconstant +texture13-arb+ #x84cd) (defconstant +texture14-arb+ #x84ce) (defconstant +texture15-arb+ #x84cf) (defconstant +texture16-arb+ #x84d0) (defconstant +texture17-arb+ #x84d1) (defconstant +texture18-arb+ #x84d2) (defconstant +texture19-arb+ #x84d3) (defconstant +texture20-arb+ #x84d4) (defconstant +texture21-arb+ #x84d5) (defconstant +texture22-arb+ #x84d6) (defconstant +texture23-arb+ #x84d7) (defconstant +texture24-arb+ #x84d8) (defconstant +texture25-arb+ #x84d9) (defconstant +texture26-arb+ #x84da) (defconstant +texture27-arb+ #x84db) (defconstant +texture28-arb+ #x84dc) (defconstant +texture29-arb+ #x84dd) (defconstant +texture30-arb+ #x84de) (defconstant +texture31-arb+ #x84df) (defconstant +active-texture-arb+ #x84e0) (defconstant +client-active-texture-arb+ #x84e1) (defconstant +max-texture-units-arb+ #x84e2) ;;; Misc extensions (defconstant +ext-abgr+ 1) (defconstant +abgr-ext+ #x8000) (defconstant +ext-blend-color+ 1) (defconstant +constant-color-ext+ #x8001) (defconstant +one-minus-constant-color-ext+ #x8002) (defconstant +constant-alpha-ext+ #x8003) (defconstant +one-minus-constant-alpha-ext+ #x8004) (defconstant +blend-color-ext+ #x8005) (defconstant +ext-polygon-offset+ 1) (defconstant +polygon-offset-ext+ #x8037) (defconstant +polygon-offset-factor-ext+ #x8038) (defconstant +polygon-offset-bias-ext+ #x8039) (defconstant +ext-texture3d+ 1) (defconstant +pack-skip-images-ext+ #x806b) (defconstant +pack-image-height-ext+ #x806c) (defconstant +unpack-skip-images-ext+ #x806d) (defconstant +unpack-image-height-ext+ #x806e) (defconstant +texture-3d-ext+ #x806f) (defconstant +proxy-texture-3d-ext+ #x8070) (defconstant +texture-depth-ext+ #x8071) (defconstant +texture-wrap-r-ext+ #x8072) (defconstant +max-3d-texture-size-ext+ #x8073) (defconstant +texture-3d-binding-ext+ #x806a) (defconstant +ext-texture-object+ 1) (defconstant +texture-priority-ext+ #x8066) (defconstant +texture-resident-ext+ #x8067) (defconstant +texture-1d-binding-ext+ #x8068) (defconstant +texture-2d-binding-ext+ #x8069) (defconstant +ext-rescale-normal+ 1) (defconstant +rescale-normal-ext+ #x803a) (defconstant +ext-vertex-array+ 1) (defconstant +vertex-array-ext+ #x8074) (defconstant +normal-array-ext+ #x8075) (defconstant +color-array-ext+ #x8076) (defconstant +index-array-ext+ #x8077) (defconstant +texture-coord-array-ext+ #x8078) (defconstant +edge-flag-array-ext+ #x8079) (defconstant +vertex-array-size-ext+ #x807a) (defconstant +vertex-array-type-ext+ #x807b) (defconstant +vertex-array-stride-ext+ #x807c) (defconstant +vertex-array-count-ext+ #x807d) (defconstant +normal-array-type-ext+ #x807e) (defconstant +normal-array-stride-ext+ #x807f) (defconstant +normal-array-count-ext+ #x8080) (defconstant +color-array-size-ext+ #x8081) (defconstant +color-array-type-ext+ #x8082) (defconstant +color-array-stride-ext+ #x8083) (defconstant +color-array-count-ext+ #x8084) (defconstant +index-array-type-ext+ #x8085) (defconstant +index-array-stride-ext+ #x8086) (defconstant +index-array-count-ext+ #x8087) (defconstant +texture-coord-array-size-ext+ #x8088) (defconstant +texture-coord-array-type-ext+ #x8089) (defconstant +texture-coord-array-stride-ext+ #x808a) (defconstant +texture-coord-array-count-ext+ #x808b) (defconstant +edge-flag-array-stride-ext+ #x808c) (defconstant +edge-flag-array-count-ext+ #x808d) (defconstant +vertex-array-pointer-ext+ #x808e) (defconstant +normal-array-pointer-ext+ #x808f) (defconstant +color-array-pointer-ext+ #x8090) (defconstant +index-array-pointer-ext+ #x8091) (defconstant +texture-coord-array-pointer-ext+ #x8092) (defconstant +edge-flag-array-pointer-ext+ #x8093) (defconstant +sgis-texture-edge-clamp+ 1) (defconstant +clamp-to-edge-sgis+ #x812f) (defconstant +ext-blend-minmax+ 1) (defconstant +func-add-ext+ #x8006) (defconstant +min-ext+ #x8007) (defconstant +max-ext+ #x8008) (defconstant +blend-equation-ext+ #x8009) (defconstant +ext-blend-subtract+ 1) (defconstant +func-subtract-ext+ #x800a) (defconstant +func-reverse-subtract-ext+ #x800b) (defconstant +ext-blend-logic-op+ 1) (defconstant +ext-point-parameters+ 1) (defconstant +point-size-min-ext+ #x8126) (defconstant +point-size-max-ext+ #x8127) (defconstant +point-fade-threshold-size-ext+ #x8128) (defconstant +distance-attenuation-ext+ #x8129) (defconstant +ext-paletted-texture+ 1) (defconstant +table-too-large-ext+ #x8031) (defconstant +color-table-format-ext+ #x80d8) (defconstant +color-table-width-ext+ #x80d9) (defconstant +color-table-red-size-ext+ #x80da) (defconstant +color-table-green-size-ext+ #x80db) (defconstant +color-table-blue-size-ext+ #x80dc) (defconstant +color-table-alpha-size-ext+ #x80dd) (defconstant +color-table-luminance-size-ext+ #x80de) (defconstant +color-table-intensity-size-ext+ #x80df) (defconstant +texture-index-size-ext+ #x80ed) (defconstant +color-index1-ext+ #x80e2) (defconstant +color-index2-ext+ #x80e3) (defconstant +color-index4-ext+ #x80e4) (defconstant +color-index8-ext+ #x80e5) (defconstant +color-index12-ext+ #x80e6) (defconstant +color-index16-ext+ #x80e7) (defconstant +ext-clip-volume-hint+ 1) (defconstant +clip-volume-clipping-hint-ext+ #x80f0) (defconstant +ext-compiled-vertex-array+ 1) (defconstant +array-element-lock-first-ext+ #x81a8) (defconstant +array-element-lock-count-ext+ #x81a9) (defconstant +hp-occlusion-test+ 1) (defconstant +occlusion-test-hp+ #x8165) (defconstant +occlusion-test-result-hp+ #x8166) (defconstant +ext-shared-texture-palette+ 1) (defconstant +shared-texture-palette-ext+ #x81fb) (defconstant +ext-stencil-wrap+ 1) (defconstant +incr-wrap-ext+ #x8507) (defconstant +decr-wrap-ext+ #x8508) (defconstant +nv-texgen-reflection+ 1) (defconstant +normal-map-nv+ #x8511) (defconstant +reflection-map-nv+ #x8512) (defconstant +ext-texture-env-add+ 1) (defconstant +mesa-window-pos+ 1) (defconstant +mesa-resize-buffers+ 1) ) ;;; Utility stuff (deftype bool () 'card8) (deftype float32 () 'single-float) (deftype float64 () 'double-float) (declaim (inline aset-float32 aset-float64)) #+sbcl (defun aset-float32 (value array index) (declare (type single-float value) (type buffer-bytes array) (type array-index index)) #.(declare-buffun) (let ((bits (sb-kernel:single-float-bits value))) (declare (type (unsigned-byte 32) bits)) (aset-card32 bits array index)) value) #+cmu (defun aset-float32 (value array index) (declare (type single-float value) (type buffer-bytes array) (type array-index index)) #.(declare-buffun) (let ((bits (kernel:single-float-bits value))) (declare (type (unsigned-byte 32) bits)) (aset-card32 bits array index)) value) #+openmcl (defun aset-float32 (value array index) (declare (type single-float value) (type buffer-bytes array) (type array-index index)) #.(declare-buffun) (let ((bits (ccl::single-float-bits value))) (declare (type (unsigned-byte 32) bits)) (aset-card32 bits array index)) value) #+lispworks (progn (defun %single-float-bits (x) (declare (type single-float x)) (fli:with-dynamic-foreign-objects ((bits :int32)) (fli:with-coerced-pointer (pointer :type :lisp-single-float) bits (setf (fli:dereference pointer) x)) (fli:dereference bits))) (declaim (notinline aset-float32)) (defun aset-float32 (value array index) (declare (type (or short-float single-float) value) (type buffer-bytes array) (type array-index index)) #.(declare-buffun) (let ((bits (%single-float-bits (coerce value 'single-float)))) (declare (type (unsigned-byte 32) bits)) (aset-card32 bits array index)) value)) #+sbcl (defun aset-float64 (value array index) (declare (type double-float value) (type buffer-bytes array) (type array-index index)) #.(declare-buffun) (let ((low (sb-kernel:double-float-low-bits value)) (high (sb-kernel:double-float-high-bits value))) (declare (type (unsigned-byte 32) low high)) (aset-card32 low array index) (aset-card32 high array (the array-index (+ index 4)))) value) #+cmu (defun aset-float64 (value array index) (declare (type double-float value) (type buffer-bytes array) (type array-index index)) #.(declare-buffun) (let ((low (kernel:double-float-low-bits value)) (high (kernel:double-float-high-bits value))) (declare (type (unsigned-byte 32) low high)) (aset-card32 low array index) (aset-card32 high array (+ index 4))) value) #+openmcl (defun aset-float64 (value array index) (declare (type double-float value) (type buffer-bytes array) (type array-index index)) #.(declare-buffun) (multiple-value-bind (low high) (ccl::double-float-bits value) (declare (type (unsigned-byte 32) low high)) (aset-card32 low array index) (aset-card32 high array (the array-index (+ index 4)))) value) #+lispworks (progn (fli:define-c-struct %uint64 (high :uint32) (low :uint32)) (defun %double-float-bits (x) (declare (type double-float x)) (fli:with-dynamic-foreign-objects ((bits %uint64)) (fli:with-coerced-pointer (pointer :type :lisp-double-float) bits (setf (fli:dereference pointer) x)) (values (fli:foreign-slot-value bits 'low :type :uint32 :object-type '%uint64) (fli:foreign-slot-value bits 'high :type :uint32 :object-type '%uint64)))) (declaim (notinline aset-float64)) (defun aset-float64 (value array index) (declare (type double-float value) (type buffer-bytes array) (type array-index index)) #.(declare-buffun) (multiple-value-bind (low high) (%double-float-bits value) (declare (type (unsigned-byte 32) low high)) (aset-card32 low array index) (aset-card32 high array (the array-index (+ index 4)))) value)) (eval-when (:compile-toplevel :load-toplevel :execute) (defun byte-width (type) (ecase type ((int8 card8 bool) 1) ((int16 card16) 2) ((int32 card32 float32) 4) ((float64) 8))) (defun setter (type) (ecase type (int8 'aset-int8) (int16 'aset-int16) (int32 'aset-int32) (bool 'aset-card8) (card8 'aset-card8) (card16 'aset-card16) (card32 'aset-card32) (float32 'aset-float32) (float64 'aset-float64))) (defun sequence-setter (type) (ecase type (int8 'sset-int8) (int16 'sset-int16) (int32 'sset-int32) (bool 'sset-card8) (card8 'sset-card8) (card16 'sset-card16) (card32 'sset-card32) (float32 'sset-float32) (float64 'sset-float64))) (defmacro define-sequence-setter (type) `(defun ,(intern (format nil "~A-~A" 'sset type)) (seq buffer start length) (declare (type sequence seq) (type buffer-bytes buffer) (type array-index start) (type fixnum length)) #.(declare-buffun) (assert (= length (length seq)) (length seq) "SEQUENCE length should be ~D, not ~D." length (length seq)) (typecase seq (list (let ((offset 0)) (declare (type fixnum offset)) (dolist (n seq) (declare (type ,type n)) (,(setter type) n buffer (the array-index (+ start offset))) (incf offset ,(byte-width type))))) ((simple-array ,type) (dotimes (i ,(byte-width type)) (,(setter type) (aref seq i) buffer (the array-index (+ start (* i ,(byte-width type))))))) (vector (dotimes (i ,(byte-width type)) (,(setter type) (svref seq i) buffer (the array-index (+ start (* i ,(byte-width type)))))))))) (define-sequence-setter int8) (define-sequence-setter int16) (define-sequence-setter int32) (define-sequence-setter bool) (define-sequence-setter card8) (define-sequence-setter card16) (define-sequence-setter card32) (define-sequence-setter float32) (define-sequence-setter float64) (defun make-argspecs (list) (destructuring-bind (name type) list (etypecase type (symbol `(,name ,type 1 nil)) (list `(,name ,(second type) ,(third type) ,(if (consp (third type)) (make-symbol (format nil "~A-~A" name 'length)) nil)))))) (defun byte-width-calculation (argspecs) (let ((constant 0) (calculated ())) (loop for (name type length length-var) in argspecs do (let ((byte-width (byte-width type))) (typecase length (number (incf constant (* byte-width length))) (symbol (push `(* ,byte-width ,length) calculated)) (cons (push `(* ,byte-width ,length-var) calculated))))) (if (null calculated) constant (list* '+ constant calculated)))) (defun composite-args (argspecs) (loop for (name type length length-var) in argspecs when (consp length) collect (list length-var length))) (defun make-setter-forms (argspecs) (loop for (name type length length-var) in argspecs collecting `(progn ,(if (and (numberp length) (= 1 length)) `(,(setter type) ,name .rbuf. .index.) `(,(sequence-setter type) ,name .rbuf. .index. ,(if length-var length-var length))) (setf .index. (the array-index (+ .index. (the fixnum (* ,(byte-width type) ,(if length-var length-var length))))))))) (defmacro define-rendering-command (name opcode &rest args) ;; FIXME: Must heavily type-annotate. (labels ((expand-args (list) (loop for (arg type) in list if (consp arg) append (loop for name in arg collecting (list name type)) else collect (list arg type)))) (let* ((args (expand-args args)) (argspecs (mapcar 'make-argspecs args)) (total-byte-width (byte-width-calculation argspecs)) (composite-args (composite-args argspecs))) `(defun ,name ,(mapcar #'first argspecs) (declare ,@(mapcar #'(lambda (list) (if (symbolp (second list)) (list* 'type (reverse list)) `(type sequence ,(first list)))) args)) #.(declare-buffun) (assert (context-p *current-context*) (*current-context*) "*CURRENT-CONTEXT* is not set (~S)." *current-context*) (let* ((.ctx. *current-context*) (.index0. (context-index .ctx.)) (.index. (+ .index0. 4)) (.rbuf. (context-rbuf .ctx.)) ,@composite-args (.length. (+ 4 (* 4 (ceiling ,total-byte-width 4))))) (declare (type context .ctx.) (type array-index .index. .index0.) (type buffer-bytes .rbuf.) ,@(mapcar #'(lambda (list) `(type fixnum ,(first list))) composite-args) (type fixnum .length.)) (when (< (- (length .rbuf.) 8) (+ .index. .length.)) (error "Rendering command sequence too long. Implement automatic buffer flushing.")) (aset-card16 .length. .rbuf. (the array-index .index0.)) (aset-card16 ,opcode .rbuf. (the array-index (+ .index0. 2))) ,@(make-setter-forms argspecs) (setf (context-index .ctx.) (the array-index (+ .index0. .length.)))))))) ) ;; eval-when ;;; Command implementation. (defun get-string (name) (assert (context-p *current-context*) (*current-context*) "*CURRENT-CONTEXT* is not set (~S)." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +get-string+) ;; *** This is CONTEXT-TAG (card32 (context-tag ctx)) ;; *** This is ENUM. (card32 name)) (let* ((length (card32-get 12)) (bytes (sequence-get :format card8 :result-type '(simple-array card8 (*)) :index 32 :length length))) (declare (type (simple-array card8 (*)) bytes) (type fixnum length)) ;; FIXME: How does this interact with unicode? (map-into (make-string (1- length)) #'code-char bytes))))) ;;; Rendering commands (in alphabetical order). (define-rendering-command accum 137 ;; *** ENUM (op card32) (value float32)) (define-rendering-command active-texture-arb 197 ;; *** ENUM (texture card32)) (define-rendering-command alpha-func 159 ;; *** ENUM (func card32) (ref float32)) (define-rendering-command begin 4 ;; *** ENUM (mode card32)) (define-rendering-command bind-texture 4117 ;; *** ENUM (target card32) (texture card32)) (define-rendering-command blend-color 4096 (red float32) (green float32) (blue float32) (alpha float32)) (define-rendering-command blend-equotion 4097 ;; *** ENUM (mode card32)) (define-rendering-command blend-func 160 ;; *** ENUM (sfactor card32) ;; *** ENUM (dfactor card32)) (define-rendering-command call-list 1 (list card32)) (define-rendering-command clear 127 ;; *** BITFIELD (mask card32)) (define-rendering-command clear-accum 128 (red float32) (green float32) (blue float32) (alpha float32)) (define-rendering-command clear-color 130 (red float32) (green float32) (blue float32) (alpha float32)) (define-rendering-command clear-depth 132 (depth float64)) (define-rendering-command clear-index 129 (c float32)) (define-rendering-command clear-stencil 131 (s int32)) (define-rendering-command clip-plane 77 (equotion-0 float64) (equotion-1 float64) (equotion-2 float64) (equotion-3 float64) ;; *** ENUM (plane card32)) (define-rendering-command color-3b 6 ((r g b) int8)) (define-rendering-command color-3d 7 ((r g b) float64)) (define-rendering-command color-3f 8 ((r g b) float32)) (define-rendering-command color-3i 9 ((r g b) int32)) (define-rendering-command color-3s 10 ((r g b) int16)) (define-rendering-command color-3ub 11 ((r g b) card8)) (define-rendering-command color-3ui 12 ((r g b) card32)) (define-rendering-command color-3us 13 ((r g b) card16)) (define-rendering-command color-4b 14 ((r g b a) int8)) (define-rendering-command color-4d 15 ((r g b a) float64)) (define-rendering-command color-4f 16 ((r g b a) float32)) (define-rendering-command color-4i 17 ((r g b a) int32)) (define-rendering-command color-4s 18 ((r g b a) int16)) (define-rendering-command color-4ub 19 ((r g b a) card8)) (define-rendering-command color-4ui 20 ((r g b a) card32)) (define-rendering-command color-4us 21 ((r g b a) card16)) (define-rendering-command color-mask 134 (red bool) (green bool) (blue bool) (alpha bool)) (define-rendering-command color-material 78 ;; *** ENUM (face card32) ;; *** ENUM (mode card32)) (define-rendering-command color-table-parameter-fv 2054 ;; *** ENUM (target card32) ;; TODO: ;; +GL-COLOR-TABLE-SCALE+ (#x80D6) => (length params) = 4 ;; +GL-COLOR-TABLE-BIAS+ (#x80d7) => (length params) = 4 ;; else (length params) = 0 (command is erronous) ;; *** ENUM (pname card32) (params (list float32 4))) (define-rendering-command color-table-parameter-iv 2055 ;; *** ENUM (target card32) ;; TODO: ;; +GL-COLOR-TABLE-SCALE+ (#x80D6) => (length params) = 4 ;; +GL-COLOR-TABLE-BIAS+ (#x80d7) => (length params) = 4 ;; else (length params) = 0 (command is erronous) ;; *** ENUM (pname card32) (params (list int32 4))) (define-rendering-command convolution-parameter-f 4103 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (params float32)) (define-rendering-command convolution-parameter-fv 4104 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (params (list float32 (ecase pname ((#.+convolution-border-mode+ #.+convolution-format+ #.+convolution-width+ #.+convolution-height+ #.+max-convolution-width+ #.+max-convolution-height+) 1) ((#.+convolution-filter-scale+ #.+convolution-filter-bias+) 4))))) (define-rendering-command convolution-parameter-i 4105 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (params int32)) (define-rendering-command convolution-parameter-iv 4106 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (params (list int32 (ecase pname ((#.+convolution-border-mode+ #.+convolution-format+ #.+convolution-width+ #.+convolution-height+ #.+max-convolution-width+ #.+max-convolution-height+) 1) ((#.+convolution-filter-scale+ #.+convolution-filter-bias+) 4))))) (define-rendering-command copy-color-sub-table 196 ;; *** ENUM (target card32) (start int32) (x int32) (y int32) (width int32)) (define-rendering-command copy-color-table 2056 ;; *** ENUM (target card32) ;; *** ENUM (internalformat card32) (x int32) (y int32) (width int32)) (define-rendering-command copy-convolution-filter-id 4107 ;; *** ENUM (target card32) ;; *** ENUM (internalformat card32) (x int32) (y int32) (width int32)) (define-rendering-command copy-convolution-filter-2d 4108 ;; *** ENUM (target card32) ;; *** ENUM (internalformat card32) (x int32) (y int32) (width int32) (height int32)) (define-rendering-command copy-pixels 172 (x int32) (y int32) (width int32) (height int32) ;; *** ENUM (type card32)) (define-rendering-command copy-tex-image-1d 4119 ;; *** ENUM (target card32) (level int32) ;; *** ENUM (internalformat card32) (x int32) (y int32) (width int32) (border int32)) (define-rendering-command copy-tex-image-2d 4120 ;; *** ENUM (target card32) (level int32) ;; *** ENUM (internalformat card32) (x int32) (y int32) (width int32) (height int32) (border int32)) (define-rendering-command copy-tex-sub-image-1d 4121 ;; *** ENUM (target card32) (level int32) (xoffset int32) (x int32) (y int32) (width int32)) (define-rendering-command copy-tex-sub-image-2d 4122 ;; *** ENUM (target card32) (level int32) (xoffset int32) (yoffset int32) (x int32) (y int32) (width int32) (height int32)) (define-rendering-command copy-tex-sub-image-3d 4123 ;; *** ENUM (target card32) (level int32) (xoffset int32) (yoffset int32) (zoffset int32) (x int32) (y int32) (width int32) (height int32)) (define-rendering-command cull-face 79 ;; *** ENUM (mode card32)) (define-rendering-command depth-func 164 ;; *** ENUM (func card32)) (define-rendering-command depth-mask 135 (mask bool)) (define-rendering-command depth-range 174 (z-near float64) (z-far float64)) (define-rendering-command draw-buffer 126 ;; *** ENUM (mode card32)) (define-rendering-command edge-flag-v 22 (flag-0 bool)) (define-rendering-command end 23) (define-rendering-command eval-coord-1d 151 (u-0 float64)) (define-rendering-command eval-coord-1f 152 (u-0 float32)) (define-rendering-command eval-coord-2d 153 ((u-0 u-1) float64)) (define-rendering-command eval-coord-2f 154 ((u-0 u-1) float32)) (define-rendering-command eval-mesh-1 155 ;; *** ENUM (mode card32) ((i1 i2) int32)) (define-rendering-command eval-mesh-2 157 ;; *** ENUM (mode card32) ((i1 i2 j1 j2) int32)) (define-rendering-command eval-point-1 156 (i int32)) (define-rendering-command eval-point-2 158 (i int32) (j int32)) (define-rendering-command fog-f 80 ;; *** ENUM (pname card32) (param float32)) (define-rendering-command fog-fv 81 ;; *** ENUM (pname card32) (params (list float32 (ecase pname ((#.+fog-index+ #.+fog-density+ #.+fog-start+ #.+fog-end+ #.+fog-mode+) 1) ((#.+fog-color+) 4))))) (define-rendering-command fog-i 82 ;; *** ENUM (pname card32) (param int32)) (define-rendering-command fog-iv 83 ;; *** ENUM (pname card32) (params (list int32 (ecase pname ((#.+fog-index+ #.+fog-density+ #.+fog-start+ #.+fog-end+ #.+fog-mode+) 1) ((#.+fog-color+) 4))))) (define-rendering-command front-face 84 ;; *** ENUM (mode card32)) (define-rendering-command frustum 175 (left float64) (right float64) (bottom float64) (top float64) (z-near float64) (z-far float64)) (define-rendering-command hint 85 ;; *** ENUM (target card32) ;; *** ENUM (mode card32)) (define-rendering-command histogram 4110 ;; *** ENUM (target card32) (width int32) ;; *** ENUM (internalformat card32) (sink bool)) (define-rendering-command index-mask 136 (mask card32)) (define-rendering-command index-d 24 (c-0 float64)) (define-rendering-command index-f 25 (c-0 float32)) (define-rendering-command index-i 26 (c-0 int32)) (define-rendering-command index-s 27 (c-0 int16)) (define-rendering-command index-ub 194 (c-0 card8)) (define-rendering-command init-names 121) (define-rendering-command light-model-f 90 ;; *** ENUM (pname card32) (param float32)) (define-rendering-command light-model-fv 91 ;; *** ENUM (pname card32) (params (list float32 (ecase pname ((#.+light-model-color-control+ #.+light-model-local-viewer+ #.+light-model-two-side+) 1) ((#.+light-model-ambient+) 4))))) (define-rendering-command light-model-i 92 ;; *** ENUM (pname card32) (param int32)) (define-rendering-command light-model-iv 93 ;; *** ENUM (pname card32) (params (list int32 (ecase pname ((#.+light-model-color-control+ #.+light-model-local-viewer+ #.+light-model-two-side+) 1) ((#.+light-model-ambient+) 4))))) (define-rendering-command light-f 86 ;; *** ENUM (light card32) ;; *** ENUM (pname card32) (param float32)) (define-rendering-command light-fv 87 ;; *** ENUM (light card32) ;; *** ENUM (pname card32) (params (list float32 (ecase pname ((#.+ambient+ #.+diffuse+ #.+specular+ #.+position+) 4) ((#.+spot-direction+) 3) ((#.+spot-exponent+ #.+spot-cutoff+ #.+constant-attenuation+ #.+linear-attenuation+ #.+quadratic-attenuation+) 1))))) (define-rendering-command light-i 88 ;; *** ENUM (light card32) ;; *** ENUM (pname card32) (param int32)) (define-rendering-command light-iv 89 ;; *** ENUM (light card32) ;; *** ENUM (pname card32) (params (list int32 (ecase pname ((#.+ambient+ #.+diffuse+ #.+specular+ #.+position+) 4) ((#.+spot-direction+) 3) ((#.+spot-exponent+ #.+spot-cutoff+ #.+constant-attenuation+ #.+linear-attenuation+ #.+quadratic-attenuation+) 1))))) (define-rendering-command line-stipple 94 (factor int32) (pattern card16)) (define-rendering-command line-width 95 (width float32)) (define-rendering-command list-base 3 (base card32)) (define-rendering-command load-identity 176) (define-rendering-command load-matrix-d 178 (m (list float64 16))) (define-rendering-command load-matrix-f 177 (m (list float32 16))) (define-rendering-command load-name 122 (name card32)) (define-rendering-command logic-op 161 ;; *** ENUM (name card32)) (define-rendering-command map-grid-1d 147 (u1 float64) (u2 float64) (un int32)) (define-rendering-command map-grid-1f 148 (un int32) (u1 float32) (u2 float32)) (define-rendering-command map-grid-2d 149 (u1 float64) (u2 float64) (v1 float64) (v2 float64) (un int32) (vn int32)) (define-rendering-command map-grid-2f 150 (un int32) (u1 float32) (u2 float32) (vn int32) (v1 float32) (v2 float32)) (define-rendering-command material-f 96 ;; *** ENUM (face card32) ;; *** ENUM (pname card32) (param float32)) (define-rendering-command material-fv 97 ;; *** ENUM (face card32) ;; *** ENUM (pname card32) (params (list float32 (ecase pname ((#.+ambient+ #.+diffuse+ #.+specular+ #.+emission+ #.+ambient-and-diffuse+) 4) ((#.+shininess+) 1) ((#.+color-index+) 3))))) (define-rendering-command material-i 98 ;; *** ENUM (face card32) ;; *** ENUM (pname card32) (param int32)) (define-rendering-command material-iv 99 ;; *** ENUM (face card32) ;; *** ENUM (pname card32) (params (list int32 (ecase pname ((#.+ambient+ #.+diffuse+ #.+specular+ #.+emission+ #.+ambient-and-diffuse+) 4) ((#.+shininess+) 1) ((#.+color-index+) 3))))) (define-rendering-command matrix-mode 179 ;; *** ENUM (mode card32)) (define-rendering-command minmax 4111 ;; *** ENUM (target card32) ;; *** ENUM (internalformat card32) (sink bool)) (define-rendering-command mult-matrix-d 181 (m (list float64 16))) (define-rendering-command mult-matrix-f 180 (m (list float32 16))) ;;; *** Note that TARGET is placed last for FLOAT64 versions. (define-rendering-command multi-tex-coord-1d-arb 198 (v-0 float64) ;; *** ENUM (target card32)) (define-rendering-command multi-tex-coord-1f-arb 199 ;; *** ENUM (target card32) (v-0 float32)) (define-rendering-command multi-tex-coord-1i-arb 200 ;; *** ENUM (target card32) (v-0 int32)) (define-rendering-command multi-tex-coord-1s-arb 201 ;; *** ENUM (target card32) (v-0 int16)) (define-rendering-command multi-tex-coord-2d-arb 202 ((v-0 v-1) float64) ;; *** ENUM (target card32)) (define-rendering-command multi-tex-coord-2f-arb 203 ;; *** ENUM (target card32) ((v-0 v-1) float32)) (define-rendering-command multi-tex-coord-2i-arb 204 ;; *** ENUM (target card32) ((v-0 v-1) int32)) (define-rendering-command multi-tex-coord-2s-arb 205 ;; *** ENUM (target card32) ((v-0 v-1) int16)) (define-rendering-command multi-tex-coord-3d-arb 206 ((v-0 v-1 v-2) float64) ;; *** ENUM (target card32)) (define-rendering-command multi-tex-coord-3f-arb 207 ;; *** ENUM (target card32) ((v-0 v-1 v-2) float32)) (define-rendering-command multi-tex-coord-3i-arb 208 ;; *** ENUM (target card32) ((v-0 v-1 v-2) int32)) (define-rendering-command multi-tex-coord-3s-arb 209 ;; *** ENUM (target card32) ((v-0 v-1 v-2) int16)) (define-rendering-command multi-tex-coord-4d-arb 210 ((v-0 v-1 v-2 v-3) float64) ;; *** ENUM (target card32)) (define-rendering-command multi-tex-coord-4f-arb 211 ;; *** ENUM (target card32) ((v-0 v-1 v-2 v-3) float32)) (define-rendering-command multi-tex-coord-4i-arb 212 ;; *** ENUM (target card32) ((v-0 v-1 v-2 v-3) int32)) (define-rendering-command multi-tex-coord-4s-arb 213 ;; *** ENUM (target card32) ((v-0 v-1 v-2 v-3) int16)) (define-rendering-command normal-3b 28 ((v-0 v-1 v-2) int8)) (define-rendering-command normal-3d 29 ((v-0 v-1 v-2) float64)) (define-rendering-command normal-3f 30 ((v-0 v-1 v-2) float32)) (define-rendering-command normal-3i 31 ((v-0 v-1 v-2) int32)) (define-rendering-command normal-3s 32 ((v-0 v-1 v-2) int16)) (define-rendering-command ortho 182 (left float64) (right float64) (bottom float64) (top float64) (z-near float64) (z-far float64)) (define-rendering-command pass-through 123 (token float32)) (define-rendering-command pixel-transfer-f 166 ;; *** ENUM (pname card32) (param float32)) (define-rendering-command pixel-transfer-i 167 ;; *** ENUM (pname card32) (param int32)) (define-rendering-command pixel-zoom 165 (xfactor float32) (yfactor float32)) (define-rendering-command point-size 100 (size float32)) (define-rendering-command polygon-mode 101 ;; *** ENUM (face card32) ;; *** ENUM (mode card32)) (define-rendering-command polygon-offset 192 (factor float32) (units float32)) (define-rendering-command pop-attrib 141) (define-rendering-command pop-matrix 183) (define-rendering-command pop-name 124) (define-rendering-command prioritize-textures 4118 (n int32) (textures (list card32 n)) (priorities (list float32 n))) (define-rendering-command push-attrib 142 ;; *** BITFIELD (mask card32)) (define-rendering-command push-matrix 184) (define-rendering-command push-name 125 (name card32)) (define-rendering-command raster-pos-2d 33 ((v-0 v-1) float64)) (define-rendering-command raster-pos-2f 34 ((v-0 v-1) float32)) (define-rendering-command raster-pos-2i 35 ((v-0 v-1) int32)) (define-rendering-command raster-pos-2s 36 ((v-0 v-1) int16)) (define-rendering-command raster-pos-3d 37 ((v-0 v-1 v-2) float64)) (define-rendering-command raster-pos-3f 38 ((v-0 v-1 v-2) float32)) (define-rendering-command raster-pos-3i 39 ((v-0 v-1 v-2) int32)) (define-rendering-command raster-pos-3s 40 ((v-0 v-1 v-2) int16)) (define-rendering-command raster-pos-4d 41 ((v-0 v-1 v-2 v-3) float64)) (define-rendering-command raster-pos-4f 42 ((v-0 v-1 v-2 v-3) float32)) (define-rendering-command raster-pos-4i 43 ((v-0 v-1 v-2 v-3) int32)) (define-rendering-command raster-pos-4s 44 ((v-0 v-1 v-2 v-3) int16)) (define-rendering-command read-buffer 171 ;; *** ENUM (mode card32)) (define-rendering-command rect-d 45 ((v1-0 v1-1 v2-0 v2-1) float64)) (define-rendering-command rect-f 46 ((v1-0 v1-1 v2-0 v2-1) float32)) (define-rendering-command rect-i 47 ((v1-0 v1-1 v2-0 v2-1) int32)) (define-rendering-command rect-s 48 ((v1-0 v1-1 v2-0 v2-1) int16)) (define-rendering-command reset-histogram 4112 ;; *** ENUM (target card32)) (define-rendering-command reset-minmax 4113 ;; *** ENUM (target card32)) (define-rendering-command rotate-d 185 ((angle x y z) float64)) (define-rendering-command rotate-f 186 ((angle x y z) float32)) (define-rendering-command scale-d 187 ((x y z) float64)) (define-rendering-command scale-f 188 ((x y z) float32)) (define-rendering-command scissor 103 ((x y width height) int32)) (define-rendering-command shade-model 104 ;; *** ENUM (mode card32)) (define-rendering-command stencil-func 162 ;; *** ENUM (func card32) (ref int32) (mask card32)) (define-rendering-command stencil-mask 133 (mask card32)) (define-rendering-command stencil-op 163 ;; *** ENUM (fail card32) ;; *** ENUM (zfail card32) ;; *** ENUM (zpass card32)) (define-rendering-command tex-env-f 111 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (param float32)) (define-rendering-command tex-env-fv 112 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (param (list float32 (ecase pname (#.+texture-env-mode+ 1) (#.+texture-env-color+ 4))))) (define-rendering-command tex-env-i 113 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (param int32)) (define-rendering-command tex-env-iv 114 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (param (list int32 (ecase pname (#.+texture-env-mode+ 1) (#.+texture-env-color+ 4))))) ;;; *** ;;; last there. (define-rendering-command tex-gen-d 115 (param float64) ;; *** ENUM (coord card32) ;; *** ENUM (pname card32)) (define-rendering-command tex-gen-dv 116 ;; *** ENUM (coord card32) ;; *** ENUM (pname card32) ;; +texture-gen-mode+ n=1 ;; +object-plane+ n=4 ;; +eye-plane+ n=1 (params (list float64 (ecase pname ((#.+texture-gen-mode+ #.+eye-plane+) 1) (#.+object-plane+ 4))))) (define-rendering-command tex-gen-f 117 ;; *** ENUM (coord card32) ;; *** ENUM (pname card32) (param float32)) (define-rendering-command tex-gen-fv 118 ;; *** ENUM (coord card32) ;; *** ENUM (pname card32) (params (list float32 (ecase pname ((#.+texture-gen-mode+ #.+eye-plane+) 1) (#.+object-plane+ 4))))) (define-rendering-command tex-gen-i 119 ;; *** ENUM (coord card32) ;; *** ENUM (pname card32) (param int32)) (define-rendering-command tex-gen-iv 120 ;; *** ENUM (coord card32) ;; *** ENUM (pname card32) (params (list int32 (ecase pname ((#.+texture-gen-mode+ #.+eye-plane+) 1) (#.+object-plane+ 4))))) (define-rendering-command tex-parameter-f 105 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (param float32)) (define-rendering-command tex-parameter-fv 106 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (params (list float32 (ecase pname ((#.+texture-border-color+) 4) ((#.+texture-mag-filter+ #.+texture-min-filter+ #.+texture-wrap-s+ #.+texture-wrap-t+) 1))))) (define-rendering-command tex-parameter-i 107 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (param int32)) (define-rendering-command tex-parameter-iv 108 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (params (list int32 (ecase pname ((#.+texture-border-color+) 4) ((#.+texture-mag-filter+ #.+texture-min-filter+ #.+texture-wrap-s+ #.+texture-wrap-t+) 1))))) (define-rendering-command translate-d 189 ((x y z) float64)) (define-rendering-command translate-f 190 ((x y z) float32)) (define-rendering-command vertex-2d 65 ((x y) float64)) (define-rendering-command vertex-2f 66 ((x y) float32)) (define-rendering-command vertex-2i 67 ((x y) int32)) (define-rendering-command vertex-2s 68 ((x y) int16)) (define-rendering-command vertex-3d 69 ((x y z) float64)) (define-rendering-command vertex-3f 70 ((x y z) float32)) (define-rendering-command vertex-3i 71 ((x y z) int32)) (define-rendering-command vertex-3s 72 ((x y z) int16)) (define-rendering-command vertex-4d 73 ((x y z w) float64)) (define-rendering-command vertex-4f 74 ((x y z w) float32)) (define-rendering-command vertex-4i 75 ((x y z w) int32)) (define-rendering-command vertex-4s 76 ((x y z w) int16)) (define-rendering-command viewport 191 ((x y width height) int32)) ;;; Potentially lerge rendering commands. #-(and) (define-large-rendering-command call-lists 2 (n int32) ;; *** ENUM (type card32) (lists (list type n))) ;;; Requests for GL non-rendering commands. (defun new-list (list mode) (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request (display (extension-opcode display "GLX")) (data +new-list+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx)) (card32 list) ;; *** ENUM (card32 mode)))) (defun gen-lists (range) (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +gen-lists+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx)) (integer range)) (card32-get 8)))) (defun end-list () (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request (display (extension-opcode display "GLX")) (data +end-list+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx))))) (defun enable (cap) (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +enable+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx)) ;; *** ENUM? (card32 cap))))) ;;; FIXME: FLUSH and FINISH should send *all* buffered data, including ;;; buffered rendering commands. (defun flush () (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request (display (extension-opcode display "GLX")) (data +flush+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx))))) (defun finish () (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +finish+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx)))))) cl-clx-sbcl-0.7.4.20160323.orig/extensions/xc-misc.lisp0000644000175000017500000000471412715665272020263 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- ;;; --------------------------------------------------------------------------- ;;; Title: XC Misc Extension ;;; Created: 2014-11-17 ;;; Author: Johannes Martinez ;;; --------------------------------------------------------------------------- ;;; ;;; (c) copyright 2014 by Johannes Martinez ;;; ;;; 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. ;;; (in-package :xlib) (export '(xc-get-version xc-get-xid-range xc-get-xid-list )) (define-extension "XC-MISC") ;; version (defconstant +xc-major+ 1) (defconstant +xc-minor+ 1) ;; xc major opcode (defun xc-opcode (display) (extension-opcode display "XC-MISC")) ;; xc minor opcodes (defconstant +xc-get-version+ 0) (defconstant +xc-get-xid-range+ 1) (defconstant +xc-get-xid-list+ 2) ;; x requests (defun xc-get-version (display) (declare (type display display)) (with-buffer-request-and-reply (display (xc-opcode display) nil :sizes (16)) ((data +xc-get-version+) (card16 +xc-major+) (card16 +xc-minor+)) (values (card16-get 8) (card16-get 10)))) (defun xc-get-xid-range (display) "returns a range of available resource IDs for the client issuing the request." (declare (type display display)) (with-buffer-request-and-reply (display (xc-opcode display) nil :sizes (32)) ((data +xc-get-xid-range+)) (values (card32-get 8) (card32-get 12)))) (defun xc-get-xid-list (display count &optional (result-type 'list)) "This request returns a sequence of individual resource IDs in ids. Count is the number of resource IDs requested. The number returned may be smaller than the number requested." (declare (type display display) (type card32 count)) (with-buffer-request-and-reply (display (xc-opcode display) nil :sizes (32)) ((data +xc-get-xid-list+) (card32 count)) (let ((num (card32-get 8))) (values (sequence-get :format card32 :result-type result-type :length num :index 32))))) cl-clx-sbcl-0.7.4.20160323.orig/dep-lispworks.lisp0000644000175000017500000014145112715665272017324 0ustar pdmpdm;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- ;; This file contains some of the system dependent code for CLX ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (in-package :xlib) #-lispworks6 (error "Sorry, your ~S lisp version ~S is not currently supported. ~ Patches are welcome." (lisp-implementation-type) (lisp-implementation-version)) (eval-when (:compile-toplevel :load-toplevel :execute) (require "comm")) (proclaim '(declaration array-register)) ;;; The size of the output buffer. Must be a multiple of 4. (defparameter *output-buffer-size* 8192) ;;; Number of seconds to wait for a reply to a server request (defparameter *reply-timeout* nil) (defconstant +word-0+ 0) (defconstant +word-1+ 1) (defconstant +long-0+ 0) (defconstant +long-1+ 1) (defconstant +long-2+ 2) (defconstant +long-3+ 3) ;;; Set some compiler-options for often used code (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +buffer-speed+ #+clx-debugging 1 #-clx-debugging 3 "Speed compiler option for buffer code.") (defconstant +buffer-safety+ #+clx-debugging 3 #-clx-debugging 0 "Safety compiler option for buffer code.") (defconstant +buffer-debug+ #+clx-debugging 2 #-clx-debugging 1 "Debug compiler option for buffer code>") (defun declare-bufmac () `(declare (optimize (speed ,+buffer-speed+) (safety ,+buffer-safety+) (debug ,+buffer-debug+)))) ;; It's my impression that in lucid there's some way to make a ;; declaration called fast-entry or something that causes a function ;; to not do some checking on args. Sadly, we have no lucid manuals ;; here. If such a declaration is available, it would be a good ;; idea to make it here when +buffer-speed+ is 3 and +buffer-safety+ ;; is 0. (defun declare-buffun () `(declare (optimize (speed ,+buffer-speed+) (safety ,+buffer-safety+) (debug ,+buffer-debug+))))) (declaim (inline card8->int8 int8->card8 card16->int16 int16->card16 card32->int32 int32->card32)) (defun card8->int8 (x) (declare (type card8 x)) (declare (clx-values int8)) #.(declare-buffun) (the int8 (if (logbitp 7 x) (the int8 (- x #x100)) x))) (defun int8->card8 (x) (declare (type int8 x)) (declare (clx-values card8)) #.(declare-buffun) (the card8 (ldb (byte 8 0) x))) (defun card16->int16 (x) (declare (type card16 x)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (if (logbitp 15 x) (the int16 (- x #x10000)) x))) (defun int16->card16 (x) (declare (type int16 x)) (declare (clx-values card16)) #.(declare-buffun) (the card16 (ldb (byte 16 0) x))) (defun card32->int32 (x) (declare (type card32 x)) (declare (clx-values int32)) #.(declare-buffun) (the int32 (if (logbitp 31 x) (the int32 (- x #x100000000)) x))) (defun int32->card32 (x) (declare (type int32 x)) (declare (clx-values card32)) #.(declare-buffun) (the card32 (ldb (byte 32 0) x))) (declaim (inline aref-card8 aset-card8 aref-int8 aset-int8)) (defun aref-card8 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card8)) #.(declare-buffun) (the card8 (aref a i))) (defun aset-card8 (v a i) (declare (type card8 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a i) v)) (defun aref-int8 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int8)) #.(declare-buffun) (card8->int8 (aref a i))) (defun aset-int8 (v a i) (declare (type int8 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a i) (int8->card8 v))) (defun aref-card16 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card16)) #.(declare-buffun) (the card16 (logior (the card16 (ash (the card8 (aref a (index+ i +word-1+))) 8)) (the card8 (aref a (index+ i +word-0+)))))) (defun aset-card16 (v a i) (declare (type card16 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-int16 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (logior (the int16 (ash (the int8 (aref-int8 a (index+ i +word-1+))) 8)) (the card8 (aref a (index+ i +word-0+)))))) (defun aset-int16 (v a i) (declare (type int16 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-card32 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card32)) #.(declare-buffun) (the card32 (logior (the card32 (ash (the card8 (aref a (index+ i +long-3+))) 24)) (the card29 (ash (the card8 (aref a (index+ i +long-2+))) 16)) (the card16 (ash (the card8 (aref a (index+ i +long-1+))) 8)) (the card8 (aref a (index+ i +long-0+)))))) (defun aset-card32 (v a i) (declare (type card32 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-int32 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int32)) #.(declare-buffun) (the int32 (logior (the int32 (ash (the int8 (aref-int8 a (index+ i +long-3+))) 24)) (the card29 (ash (the card8 (aref a (index+ i +long-2+))) 16)) (the card16 (ash (the card8 (aref a (index+ i +long-1+))) 8)) (the card8 (aref a (index+ i +long-0+)))))) (defun aset-int32 (v a i) (declare (type int32 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-card29 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card29)) #.(declare-buffun) (the card29 (logior (the card29 (ash (the card8 (aref a (index+ i +long-3+))) 24)) (the card29 (ash (the card8 (aref a (index+ i +long-2+))) 16)) (the card16 (ash (the card8 (aref a (index+ i +long-1+))) 8)) (the card8 (aref a (index+ i +long-0+)))))) (defun aset-card29 (v a i) (declare (type card29 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) v) (defsetf aref-card8 (a i) (v) `(aset-card8 ,v ,a ,i)) (defsetf aref-int8 (a i) (v) `(aset-int8 ,v ,a ,i)) (defsetf aref-card16 (a i) (v) `(aset-card16 ,v ,a ,i)) (defsetf aref-int16 (a i) (v) `(aset-int16 ,v ,a ,i)) (defsetf aref-card32 (a i) (v) `(aset-card32 ,v ,a ,i)) (defsetf aref-int32 (a i) (v) `(aset-int32 ,v ,a ,i)) (defsetf aref-card29 (a i) (v) `(aset-card29 ,v ,a ,i)) ;;; Other random conversions (defun rgb-val->card16 (value) ;; Short floats are good enough (declare (type rgb-val value)) (declare (clx-values card16)) #.(declare-buffun) ;; Convert VALUE from float to card16 (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff))))) (defun card16->rgb-val (value) ;; Short floats are good enough (declare (type card16 value)) (declare (clx-values short-float)) #.(declare-buffun) ;; Convert VALUE from card16 to float (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff)))) (defun radians->int16 (value) ;; Short floats are good enough (declare (type angle value)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0))))) (defun int16->radians (value) ;; Short floats are good enough (declare (type int16 value)) (declare (clx-values short-float)) #.(declare-buffun) (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float)))) ;;; 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 protocol 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)))) ;;----------------------------------------------------------------------------- ;; Character transformation ;;----------------------------------------------------------------------------- ;;; This stuff transforms chars to ascii codes in card8's and back. ;;; You might have to hack it a little to get it to work for your machine. (declaim (inline char->card8 card8->char)) (macrolet ((char-translators () (let ((alist `(;; The normal ascii codes for the control characters. ,@`((#\Return . 13) (#\Linefeed . 10) (#\Rubout . 127) (#\Page . 12) (#\Tab . 9) (#\Backspace . 8) (#\Newline . 10) (#\Space . 32)) ;; The rest of the common lisp charater set with the normal ;; ascii codes for them. (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) (#\} . 125) (#\~ . 126)))) (cond ((dolist (pair alist nil) (when (not (= (char-code (car pair)) (cdr pair))) (return t))) `(progn (defconstant *char-to-card8-translation-table* ',(let ((array (make-array (let ((max-char-code 255)) (dolist (pair alist) (setq max-char-code (max max-char-code (char-code (car pair))))) (1+ max-char-code)) :element-type 'card8))) (dotimes (i (length array)) (setf (aref array i) (mod i 256))) (dolist (pair alist) (setf (aref array (char-code (car pair))) (cdr pair))) array)) (defconstant *card8-to-char-translation-table* ',(let ((array (make-array 256))) (dotimes (i (length array)) (setf (aref array i) (code-char i))) (dolist (pair alist) (setf (aref array (cdr pair)) (car pair))) array)) (progn (defun char->card8 (char) (declare (type base-char char)) #.(declare-buffun) (the card8 (aref (the (simple-array card8 (*)) *char-to-card8-translation-table*) (the array-index (char-code char))))) (defun card8->char (card8) (declare (type card8 card8)) #.(declare-buffun) (the base-char (or (aref (the simple-vector *card8-to-char-translation-table*) card8) (error "Invalid CHAR code ~D." card8)))) ) (dotimes (i 256) (unless (= i (char->card8 (card8->char i))) (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" (list i (card8->char i) (char->card8 (card8->char i)))) (return nil))) (dotimes (i (length *char-to-card8-translation-table*)) (let ((char (code-char i))) (unless (eql char (card8->char (char->card8 char))) (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S" (list char (char->card8 char) (card8->char (char->card8 char)))) (return nil)))))) (t `(progn (defun char->card8 (char) (declare (type base-char char)) #.(declare-buffun) (the card8 (char-code char))) (defun card8->char (card8) (declare (type card8 card8)) #.(declare-buffun) (the base-char (code-char card8))) )))))) (char-translators)) ;;----------------------------------------------------------------------------- ;; Process Locking ;; ;; Common-Lisp doesn't provide process locking primitives, so we define ;; our own here, based on Zetalisp primitives. Holding-Lock is very ;; similar to with-lock on The TI Explorer, and a little more efficient ;; than with-process-lock on a Symbolics. ;;----------------------------------------------------------------------------- ;;; MAKE-PROCESS-LOCK: Creating a process lock. (defun make-process-lock (name) (mp:make-lock :name name)) ;;; HOLDING-LOCK: Execute a body of code with a lock held. ;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN ;;; passes its timeout to the holding-lock macro, so any timeout you want to ;;; work for event-listen you should do for holding-lock. ;; If you're not sharing DISPLAY objects within a multi-processing ;; shared-memory environment, this is sufficient (defmacro holding-lock ((lock display &optional (whostate "CLX wait") &key timeout) &body body) (declare (ignore display)) `(mp:with-lock (,lock ,whostate ,timeout) ,@body)) ;;; WITHOUT-ABORTS ;;; If you can inhibit asynchronous keyboard aborts inside the body of this ;;; macro, then it is a good idea to do this. This macro is wrapped around ;;; request writing and reply reading to ensure that requests are atomically ;;; written and replies are atomically read from the stream. (defmacro without-aborts (&body body) `(progn ,@body)) ;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value. ;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's ;;; value changes. (defun process-block (whostate predicate &rest predicate-args) (declare (dynamic-extent predicate-args)) (apply #'mp:process-wait whostate predicate predicate-args)) ;;; PROCESS-WAKEUP: Check some other process' wait function. (declaim (inline process-wakeup)) (defun process-wakeup (process) (declare (ignore process)) (mp:process-allow-scheduling)) ;;; CURRENT-PROCESS: Return the current process object for input locking and ;;; for calling PROCESS-WAKEUP. (declaim (inline current-process)) (defun current-process () (mp:get-current-process)) ;;; WITHOUT-INTERRUPTS -- provide for atomic operations. (defvar *without-interrupts-sic-lock* (mp:make-lock :name "Lock simulating *without-interrupts*")) (defmacro without-interrupts (&body body) `(mp:with-lock (*without-interrupts-sic-lock*) ,@body)) ;;; CONDITIONAL-STORE: (defvar *conditional-store-lock* (mp:make-lock :name "Conditional store lock")) (defmacro conditional-store (place old-value new-value) `(mp:with-lock (*conditional-store-lock*) (cond ((eq ,place ,old-value) (setf ,place ,new-value) t)))) ;;;---------------------------------------------------------------------------- ;;; IO Error Recovery ;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro. ;;; It prevents multiple mindless errors when the network craters. ;;; ;;;---------------------------------------------------------------------------- (defmacro wrap-buf-output ((buffer) &body body) ;; Error recovery wrapper `(unless (buffer-dead ,buffer) ,@body)) (defmacro wrap-buf-input ((buffer) &body body) (declare (ignore buffer)) ;; Error recovery wrapper `(progn ,@body)) ;;;---------------------------------------------------------------------------- ;;; System dependent IO primitives ;;; Functions for opening, reading writing forcing-output and closing ;;; the stream to the server. ;;;---------------------------------------------------------------------------- ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X ;;; server ;;; NOTE: OPEN-UNIX-STREAM and HOST-ADDRESS implementation are borrowed from ;;; http://www.bew.org.uk/Lisp/ ;;; Original license of UNIX Domain Socket support for LispWorks: ;;; ;;; Copyright 2001, Barry Wilkes ;;; uk.org.bew.comm-ext, an extension to the network interface for LispWorks/Linux ;;; ;;; uk.org.bew.comm-ext is licensed under the terms of the Lisp Lesser GNU ;;; Public License (http://opensource.franz.com/preamble.html), known as ;;; the LLGPL. The LLGPL consists of a preamble (see above URL) and the ;;; LGPL. Where these conflict, the preamble takes precedence. ;;; uk.org.bew.comm-ext is referenced in the preamble as the "LIBRARY." ;;; NOTE: %CREATE-UNIX-DOMAIN-SOCKET implementation ideas are borrowed from ;;; http://common-lisp.net/project/cl-net-snmp/lispworks.html ;;; Original license of LispWorks-UDP: ;;; ;;; The MIT License ;;; ;;; Copyright (c) 2007-2008, Chun Tian (binghe) ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN ;;; THE SOFTWARE. (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +max-unix-path-length+ #+darwin 104 #-darwin 108)) (fli:define-c-struct %sockaddr-un #+darwin (sun-len (:unsigned :byte)) (sun-family (:unsigned #+darwin :byte #-darwin :short)) (sun-path (:c-array (:unsigned :byte) #.+max-unix-path-length+))) (defun %create-unix-domain-socket (pathname error) (let ((sock-fd (comm::socket comm::*socket_af_unix* comm::*socket_sock_stream* comm::*socket_pf_unspec*))) (if (null sock-fd) (and error (error "Failed to create unix domain socket at ~S." pathname)) (fli:with-dynamic-foreign-objects ((sock-addr (:struct %sockaddr-un))) (let ((pathname-string (namestring (translate-logical-pathname (truename pathname))))) (fli:fill-foreign-object sock-addr :byte 0) (let* ((code (ef:encode-lisp-string pathname-string :utf-8)) (len (length code))) (fli:with-foreign-slots (#+darwin sun-len sun-family) sock-addr #+darwin (setf sun-len (+ len 2)) (setf sun-family comm::*socket_af_unix*)) (fli:replace-foreign-array (fli:foreign-slot-pointer sock-addr 'sun-path) code :start1 0 :end1 (min len +max-unix-path-length+)) (setf (fli:foreign-aref (fli:foreign-slot-pointer sock-addr 'sun-path) (min len (1- +max-unix-path-length+))) 0))) (if (comm::connect sock-fd (fli:copy-pointer sock-addr :type '(:struct comm::sockaddr)) (fli:pointer-element-size sock-addr)) sock-fd (progn (comm::close-socket sock-fd) (and error (error "Failed to connect unix domain socket at ~S." pathname)))))))) (defun open-unix-stream (service &key (direction :io) (element-type 'base-char) (errorp t)) (let ((socket (%create-unix-domain-socket service errorp))) (when socket (make-instance 'comm:socket-stream :socket socket :element-type element-type :direction direction)))) (defun open-x-stream (host display protocol) (declare (ignore protocol) (type (integer 0) display)) (if (or (null host) (string= host "") (string= host "unix")) (open-unix-stream (unix-socket-path-from-host host display) :direction :io :element-type '(unsigned-byte 8) :errorp t) (comm:open-tcp-stream host (+ *x-tcp-port* display) :direction :io :element-type '(unsigned-byte 8) :errorp t))) ;;; BUFFER-READ-DEFAULT - read data from the X stream (defun buffer-read-default (display vector start end timeout) (declare (type display display) (type buffer-bytes vector) (type array-index start end) (type (or null fixnum) timeout)) #.(declare-buffun) (cond ((and (eql timeout 0) (not (listen (display-input-stream display)))) :timeout) (t (read-sequence vector (display-input-stream display) :start start :end end) nil))) ;;; BUFFER-WRITE-DEFAULT - write data to the X stream (defun buffer-write-default (vector display start end) (declare (type buffer-bytes vector) (type display display) (type array-index start end)) #.(declare-buffun) (write-sequence vector (display-output-stream display) :start start :end end) nil) ;;; buffer-force-output-default - force output to the X stream (defun buffer-force-output-default (display) ;; The default buffer force-output function for use with common-lisp streams (declare (type display display)) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (force-output stream)))) ;;; BUFFER-CLOSE-DEFAULT - close the X stream (defun buffer-close-default (display &key abort) ;; The default buffer close function for use with common-lisp streams (declare (type display display)) #.(declare-buffun) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (close stream :abort abort)))) ;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the ;;; buffer. This is called in read-input between requests, so that a process ;;; waiting for input is abortable when between requests. Should return ;;; :TIMEOUT if it times out, NIL otherwise. (defun buffer-input-wait-default (display timeout) (declare (type display display) (type (or null (real 0 *)) timeout)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (cond ((null stream)) ((listen stream) nil) ((eql timeout 0) :timeout) (t (if (sys:wait-for-input-streams-returning-first (list stream) :timeout timeout) nil :timeout))))) ;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the ;;; buffer. This should never block, so it can be called from the scheduler. (defun buffer-listen-default (display) (declare (type display display)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (if (null stream) t (listen stream)))) ;;;---------------------------------------------------------------------------- ;;; System dependent speed hacks ;;;---------------------------------------------------------------------------- ;; ;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature. ;; If your lisp doesn't have stack-lists, and you're worried about ;; consing garbage, you may want to re-write this to allocate and ;; initialize lists from a resource. ;; (defmacro with-stack-list ((var &rest elements) &body body) ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body) ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body) ;; except that the list produced by MAPCAR resides on the stack and ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list ,@elements))) (declare (type cons ,var) #+clx-ansi-common-lisp (dynamic-extent ,var)) ,@body)) (defmacro with-stack-list* ((var &rest elements) &body body) ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body) ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body) ;; except that the list produced by MAPCAR resides on the stack and ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list* ,@elements))) (declare (type cons ,var) #+clx-ansi-common-lisp (dynamic-extent ,var)) ,@body)) (declaim (inline buffer-replace)) (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) (declare (type buffer-bytes buf1 buf2) (type array-index start1 end1 start2)) (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) &body body) (let ((local-state (gensym)) (resets nil)) (dolist (index indexes) (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index)) resets)) `(unwind-protect (progn ,@body) (let ((,local-state (gcontext-local-state ,gc))) (declare (type gcontext-state ,local-state)) ,@resets (setf (svref ,local-state ,ts-index) 0)) (when ,temp-gc (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) (deallocate-gcontext-state ,saved-state)))) ;;;---------------------------------------------------------------------------- ;;; How much error detection should CLX do? ;;; Several levels are possible: ;;; ;;; 1. Do the equivalent of check-type on every argument. ;;; ;;; 2. Simply report TYPE-ERROR. This eliminates overhead of all the format ;;; strings generated by check-type. ;;; ;;; 3. Do error checking only on arguments that are likely to have errors ;;; (like keyword names) ;;; ;;; 4. Do error checking only where not doing so may dammage the envirnment ;;; on a non-tagged machine (i.e. when storing into a structure that has ;;; been passed in) ;;; ;;; 5. No extra error detection code. On lispm's, ASET may barf trying to ;;; store a non-integer into a number array. ;;; ;;; How extensive should the error checking be? For example, if the server ;;; expects a CARD16, is is sufficient for CLX to check for integer, or ;;; should it also check for non-negative and less than 65536? ;;;---------------------------------------------------------------------------- ;; The +TYPE-CHECK?+ constant controls how much error checking is done. ;; Possible values are: ;; NIL - Don't do any error checking ;; t - Do the equivalent of checktype on every argument ;; :minimal - Do error checking only where errors are likely ;;; This controls macro expansion, and isn't changable at run-time You will ;;; probably want to set this to nil if you want good performance at ;;; production time. (defconstant +type-check?+ nil) ;; TYPE? is used to allow the code to do error checking at a different level from ;; the declarations. It also does some optimizations for systems that don't have ;; good compiler support for TYPEP. The definitions for CARD32, CARD16, INT16, etc. ;; include range checks. You can modify TYPE? to do less extensive checking ;; for these types if you desire. ;; ;; ### This comment is a lie! TYPE? is really also used for run-time type ;; dispatching, not just type checking. -- Ram. (defmacro type? (object type) `(typep ,object ,type)) ;; X-TYPE-ERROR is the function called for type errors. ;; If you want lots of checking, but are concerned about code size, ;; this can be made into a macro that ignores some parameters. (defun x-type-error (object type &optional error-string) (x-error 'x-type-error :datum object :expected-type type :type-string error-string)) ;;----------------------------------------------------------------------------- ;; Error handlers ;; Hack up KMP error signaling using zetalisp until the real thing comes ;; along ;;----------------------------------------------------------------------------- (defun default-error-handler (display error-key &rest key-vals &key asynchronous &allow-other-keys) (declare (type generalized-boolean asynchronous) (dynamic-extent key-vals)) ;; The default display-error-handler. ;; It signals the conditions listed in the DISPLAY file. (if asynchronous (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals) (apply #'x-error error-key :display display :error-key error-key key-vals))) (defun x-error (condition &rest keyargs) (declare (dynamic-extent keyargs)) (apply #'error condition keyargs)) (defun x-cerror (proceed-format-string condition &rest keyargs) (declare (dynamic-extent keyargs)) (apply #'cerror proceed-format-string condition keyargs)) ;; version 15 of Pitman error handling defines the syntax for define-condition to be: ;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*] ;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string) ;; or (:report exp) (define-condition x-error (error) ()) ;;----------------------------------------------------------------------------- ;; HOST hacking ;;----------------------------------------------------------------------------- (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) (type (or null (member :internet :decnet :chaos) card8) family)) (declare (values list)) (labels ((no-host-error () (error "Unknown host ~S" host)) (no-address-error () (error "Host ~S has no ~S address" host family))) (let ((addr (comm:get-host-entry (string host) :fields '(:address)))) (when (not addr) (no-host-error)) (ecase family ((:internet 0) (list :internet (ldb (byte 8 24) addr) (ldb (byte 8 16) addr) (ldb (byte 8 8) addr) (ldb (byte 8 0) addr))))))) ;;----------------------------------------------------------------------------- ;; Whether to use closures for requests or not. ;;----------------------------------------------------------------------------- ;;; If this macro expands to non-NIL, then request and locking code is ;;; compiled in a much more compact format, as the common code is shared, and ;;; the specific code is built into a closure that is funcalled by the shared ;;; code. If your compiler makes efficient use of closures then you probably ;;; want to make this expand to T, as it makes the code more compact. (defmacro use-closures () nil) (defun clx-macroexpand (form env) (macroexpand form env)) ;;----------------------------------------------------------------------------- ;; Resource stuff ;;----------------------------------------------------------------------------- ;;; Utilities (defun getenv (name) (hcl:getenv name)) (defun get-host-name () "Return the same hostname as gethostname(3) would" ;; machine-instance probably works on a lot of lisps, but clisp is not ;; one of them (machine-instance)) (defun homedir-file-pathname (name) (merge-pathnames (user-homedir-pathname) (pathname name))) ;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if ;;; a resource manager isn't running. (defun default-resources-pathname () (homedir-file-pathname ".Xdefaults")) ;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the ;;; defaults have been loaded. (defun resources-pathname () (or (let ((string (getenv "XENVIRONMENT"))) (and string (pathname string))) (homedir-file-pathname (concatenate 'string ".Xdefaults-" (get-host-name))))) ;;; AUTHORITY-PATHNAME - The pathname of the authority file. (defun authority-pathname () (or (let ((xauthority (getenv "XAUTHORITY"))) (and xauthority (pathname xauthority))) (homedir-file-pathname ".Xauthority"))) ;;; this particular defaulting behaviour is typical to most Unices, I think (defun get-default-display (&optional display-name) "Parse the argument DISPLAY-NAME, or the environment variable $DISPLAY if it is NIL. Display names have the format [protocol/] [hostname] : [:] displaynumber [.screennumber] There are two special cases in parsing, to match that done in the Xlib C language bindings - If the hostname is ``unix'' or the empty string, any supplied protocol is ignored and a connection is made using the :local transport. - If a double colon separates hostname from displaynumber, the protocol is assumed to be decnet. Returns a list of (host display-number screen protocol)." (let* ((name (or display-name (getenv "DISPLAY") (error "DISPLAY environment variable is not set"))) (slash-i (or (position #\/ name) -1)) (colon-i (position #\: name :start (1+ slash-i))) (decnet-colon-p (eql (elt name (1+ colon-i)) #\:)) (host (subseq name (1+ slash-i) colon-i)) (dot-i (and colon-i (position #\. name :start colon-i))) (display (when colon-i (parse-integer name :start (if decnet-colon-p (+ colon-i 2) (1+ colon-i)) :end dot-i))) (screen (when dot-i (parse-integer name :start (1+ dot-i)))) (protocol (cond ((or (string= host "") (string-equal host "unix")) :local) (decnet-colon-p :decnet) ((> slash-i -1) (intern (string-upcase (subseq name 0 slash-i)) :keyword)) (t :internet)))) (list host (or display 0) (or screen 0) protocol))) ;;----------------------------------------------------------------------------- ;; GC stuff ;;----------------------------------------------------------------------------- (defun gc-cleanup () (declare (special *event-free-list* *pending-command-free-list* *reply-buffer-free-lists* *gcontext-local-state-cache* *temp-gcontext-cache*)) (setq *event-free-list* nil) (setq *pending-command-free-list* nil) (when (boundp '*reply-buffer-free-lists*) (fill *reply-buffer-free-lists* nil)) (setq *gcontext-local-state-cache* nil) (setq *temp-gcontext-cache* nil) nil) ;;----------------------------------------------------------------------------- ;; DEFAULT-KEYSYM-TRANSLATE ;;----------------------------------------------------------------------------- ;;; If object is a character, char-bits are set from state. ;;; ;;; [the following isn't implemented (should it be?)] ;;; If object is a list, it is an alist with entries: ;;; (base-char [modifiers] [mask-modifiers]) ;;; When MODIFIERS are specified, this character translation ;;; will only take effect when the specified modifiers are pressed. ;;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore. ;;; When MASK-MODIFIERS is missing, all other modifiers are ignored. ;;; In ambiguous cases, the most specific translation is used. (defun default-keysym-translate (display state object) (declare (type display display) (type card16 state) (type t object) (ignore display state) (clx-values t)) object) ;;----------------------------------------------------------------------------- ;; Image stuff ;;----------------------------------------------------------------------------- ;;; Types (deftype pixarray-1-element-type () 'bit) (deftype pixarray-4-element-type () '(unsigned-byte 4)) (deftype pixarray-8-element-type () '(unsigned-byte 8)) (deftype pixarray-16-element-type () '(unsigned-byte 16)) (deftype pixarray-24-element-type () '(unsigned-byte 24)) (deftype pixarray-32-element-type () '(unsigned-byte 32)) (deftype pixarray-1 () '(array pixarray-1-element-type (* *))) (deftype pixarray-4 () '(array pixarray-4-element-type (* *))) (deftype pixarray-8 () '(array pixarray-8-element-type (* *))) (deftype pixarray-16 () '(array pixarray-16-element-type (* *))) (deftype pixarray-24 () '(array pixarray-24-element-type (* *))) (deftype pixarray-32 () '(array pixarray-32-element-type (* *))) (deftype pixarray () '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32)) (deftype bitmap () 'pixarray-1) ;;; WITH-UNDERLYING-SIMPLE-VECTOR #+sbcl (defmacro with-underlying-simple-vector ((variable element-type pixarray) &body body) (declare (ignore element-type)) `(#+cmu kernel::with-array-data #+sbcl sb-kernel:with-array-data ((,variable ,pixarray) (start) (end)) (declare (ignore start end)) ,@body)) #+openmcl (defmacro with-underlying-simple-vector ((variable element-type pixarray) &body body) (declare (ignore element-type)) `(let* ((,variable (ccl::array-data-and-offset ,pixarray))) ,@body)) ;;; These are used to read and write pixels from and to CARD8s. ;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s. (defmacro read-image-load-byte (size position integer) (unless +image-bit-lsb-first-p+ (setq position (- 7 position))) `(the (unsigned-byte ,size) (ldb (byte ,size ,position) (the card8 ,integer)))) ;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from ;;; the appropriate number of CARD8s. (defmacro read-image-assemble-bytes (&rest bytes) (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes))) (let ((it (first bytes)) (count 0)) (dolist (byte (rest bytes)) (setq it `(dpb (the card8 ,byte) (byte 8 ,(incf count 8)) (the (unsigned-byte ,count) ,it)))) `(the (unsigned-byte ,(* (length bytes) 8)) ,it))) ;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit ;;; pixel. (defmacro write-image-load-byte (position integer integer-size) integer-size (unless +image-byte-lsb-first-p+ (setq position (- integer-size 8 position))) `(the card8 (ldb (byte 8 ,position) (the (unsigned-byte ,integer-size) ,integer)))) ;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit ;;; pixels. (defmacro write-image-assemble-bytes (&rest bytes) (unless +image-bit-lsb-first-p+ (setq bytes (reverse bytes))) (let ((size (floor 8 (length bytes))) (it (first bytes)) (count 0)) (dolist (byte (rest bytes)) (setq it `(dpb (the (unsigned-byte ,size) ,byte) (byte ,size ,(incf count size)) (the (unsigned-byte ,count) ,it)))) `(the card8 ,it))) ;;; The following table gives the bit ordering within bytes (when accessed ;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to ;;; 31, where bit 0 should be leftmost on the display. For a given byte ;;; labelled A-B, A is for the most significant bit of the byte, and B is ;;; for the least significant bit. ;;; ;;; legend: ;;; 1 scanline-unit = 8 ;;; 2 scanline-unit = 16 ;;; 4 scanline-unit = 32 ;;; M byte-order = MostSignificant ;;; L byte-order = LeastSignificant ;;; m bit-order = MostSignificant ;;; l bit-order = LeastSignificant ;;; ;;; ;;; format ordering ;;; ;;; 1Mm 00-07 08-15 16-23 24-31 ;;; 2Mm 00-07 08-15 16-23 24-31 ;;; 4Mm 00-07 08-15 16-23 24-31 ;;; 1Ml 07-00 15-08 23-16 31-24 ;;; 2Ml 15-08 07-00 31-24 23-16 ;;; 4Ml 31-24 23-16 15-08 07-00 ;;; 1Lm 00-07 08-15 16-23 24-31 ;;; 2Lm 08-15 00-07 24-31 16-23 ;;; 4Lm 24-31 16-23 08-15 00-07 ;;; 1Ll 07-00 15-08 23-16 31-24 ;;; 2Ll 07-00 15-08 23-16 31-24 ;;; 4Ll 07-00 15-08 23-16 31-24 ;;; If you can write fast routines that can read and write pixarrays out of a ;;; buffer-bytes, do it! It makes the image code a lot faster. The ;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines ;;; return T if they can do it, NIL if they can't. ;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s #+(or cmu sbcl) (defun pixarray-element-size (pixarray) (let ((eltype (array-element-type pixarray))) (cond ((eq eltype 'bit) 1) ((and (consp eltype) (eq (first eltype) 'unsigned-byte)) (second eltype)) (t (error "Invalid pixarray: ~S." pixarray))))) #+sbcl (defun copy-bit-rect (source source-width sx sy dest dest-width dx dy height width) (declare (type array-index source-width sx sy dest-width dx dy height width)) #.(declare-buffun) (sb-kernel:with-array-data ((sdata source) (sstart) (send)) (declare (ignore send)) (sb-kernel:with-array-data ((ddata dest) (dstart) (dend)) (declare (ignore dend)) (assert (and (zerop sstart) (zerop dstart))) (do ((src-idx (index+ (* sb-vm:vector-data-offset sb-vm:n-word-bits) sx (index* sy source-width)) (index+ src-idx source-width)) (dest-idx (index+ (* sb-vm:vector-data-offset sb-vm:n-word-bits) dx (index* dy dest-width)) (index+ dest-idx dest-width)) (count height (1- count))) ((zerop count)) (declare (type array-index src-idx dest-idx count)) (sb-kernel:ub1-bash-copy sdata src-idx ddata dest-idx width))))) #+sbcl (defun fast-read-pixarray-using-bitblt (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel) (declare (type (array * 2) pixarray)) #.(declare-buffun) (copy-bit-rect bbuf (index* padded-bytes-per-line #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) (index* boffset #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) 0 pixarray (index* (array-dimension pixarray 1) bits-per-pixel) x y height (index* width bits-per-pixel)) t) (defun fast-read-pixarray (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type array-index boffset padded-bytes-per-line) (type pixarray pixarray) (type card16 x y width height) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (progn bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (or (let ((function (or #+(or cmu) (and (index= (pixarray-element-size pixarray) bits-per-pixel) #'fast-read-pixarray-using-bitblt)))) (when function (read-pixarray-internal bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel function unit byte-lsb-first-p bit-lsb-first-p +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+))))) ;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s #+(or cmu sbcl) (defun fast-write-pixarray-24 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-24 array) (type int16 x y) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-24-element-type array) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index y start)) (do* ((end (index+ start (index* width 3))) (i start (index+ i 3)) (x (array-row-major-index array y x) (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (let ((pixel (aref vector x))) (declare (type pixarray-24-element-type pixel)) (setf (aref buffer-bbuf (index+ i 0)) (write-image-load-byte 0 pixel 24)) (setf (aref buffer-bbuf (index+ i 1)) (write-image-load-byte 8 pixel 24)) (setf (aref buffer-bbuf (index+ i 2)) (write-image-load-byte 16 pixel 24))))))) t) #+(or cmu sbcl) (defun fast-write-pixarray-using-bitblt (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel) #.(declare-buffun) (copy-bit-rect pixarray (index* (array-dimension pixarray 1) bits-per-pixel) x y bbuf (index* padded-bytes-per-line #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) (index* boffset #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) 0 height (index* width bits-per-pixel)) t) (defun fast-write-pixarray (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type pixarray pixarray) (type card16 x y width height) (type array-index boffset padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (progn bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (or (let ((function (or #+(or cmu) (and (index= (pixarray-element-size pixarray) bits-per-pixel) #'fast-write-pixarray-using-bitblt)))) (when function (write-pixarray-internal bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel function +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+ unit byte-lsb-first-p bit-lsb-first-p))))) ;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another (defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel) (declare (type pixarray pixarray copy) (type card16 x y width height) (type (member 1 4 8 16 24 32) bits-per-pixel)) (progn pixarray copy x y width height bits-per-pixel nil) (or #+(or cmu) (let* ((pixarray-padded-pixels-per-line (array-dimension pixarray 1)) (pixarray-padded-bits-per-line (* pixarray-padded-pixels-per-line bits-per-pixel)) (copy-padded-pixels-per-line (array-dimension copy 1)) (copy-padded-bits-per-line (* copy-padded-pixels-per-line bits-per-pixel))) #-(or cmu) (when (and (= (sys:array-element-size pixarray) bits-per-pixel) (zerop (index-mod pixarray-padded-bits-per-line 32)) (zerop (index-mod copy-padded-bits-per-line 32))) (sys:bitblt boole-1 width height pixarray x y copy 0 0) t) #+(or cmu) (when (index= (pixarray-element-size pixarray) (pixarray-element-size copy) bits-per-pixel) (copy-bit-rect pixarray pixarray-padded-bits-per-line x y copy copy-padded-bits-per-line 0 0 height (index* width bits-per-pixel)) t)))) cl-clx-sbcl-0.7.4.20160323.orig/big-requests.lisp0000644000175000017500000000224512715665271017127 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- ;;; ;;; (c) copyright 2006 Richard Kreuter ;;; (c) copyright 2007 by Christophe Rhodes ;;; ;;; 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. (in-package "XLIB") ;;; No new events or errors are defined by this extension. (Big ;;; Requests Extension, section 3) ;;; ;;; The name of this extension is "BIG-REQUESTS" (Big Requests ;;; Extension, section 4) (define-extension "BIG-REQUESTS") (defun enable-big-requests (display) (declare (type display display)) (let ((opcode (extension-opcode display "BIG-REQUESTS"))) (with-buffer-request-and-reply (display opcode nil) ((data 0)) (let ((maximum-request-length (card32-get 8))) (setf (display-extended-max-request-length display) maximum-request-length))))) cl-clx-sbcl-0.7.4.20160323.orig/defsystem.lisp0000644000175000017500000004556212715665272016532 0ustar pdmpdm;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Portions Copyright (C) 1987 Texas Instruments Incorporated. ;;; Portions Copyright (C) 1988, 1989 Franz Inc, Berkeley, Ca. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; ;;; Franz Incorporated provides this software "as is" without express or ;;; implied warranty. ;;; #+ features used in this file ;;; clx-ansi-common-lisp ;;; lispm ;;; genera ;;; minima ;;; lucid ;;; lcl3.0 ;;; apollo ;;; kcl ;;; ibcl ;;; excl ;;; CMU ;;; sbcl #+(or Genera Minima sbcl ecl) (eval-when (:compile-toplevel :load-toplevel :execute) (common-lisp:pushnew :clx-ansi-common-lisp common-lisp:*features*)) #+(and Genera clx-ansi-common-lisp) (eval-when (:compile-toplevel :load-toplevel :execute) (setf *readtable* si:*ansi-common-lisp-readtable*)) #-(or clx-ansi-common-lisp cmu) (lisp:in-package :user) #+cmu (lisp:in-package "XLIB") #+cmu (export 'load-clx) #+clx-ansi-common-lisp (common-lisp:in-package :common-lisp-user) ;;;; Lisp Machines #+(and lispm (not genera)) (global:defsystem CLX (:pathname-default "clx:clx;") (:patchable "clx:patch;" clx-ti) (:initial-status :experimental) (:module package "package") (:module depdefs "depdefs") (:module clx "clx") (:module dependent "dependent") (:module macros "macros") (:module bufmac "bufmac") (:module buffer "buffer") (:module display "display") (:module gcontext "gcontext") (:module requests "requests") (:module input "input") (:module fonts "fonts") (:module graphics "graphics") (:module text "text") (:module attributes "attributes") (:module translate "translate") (:module keysyms "keysyms") (:module manager "manager") (:module image "image") (:module resource "resource") (:module doc "doc") (:compile-load package) (:compile-load depdefs (:fasload package)) (:compile-load clx (:fasload package depdefs)) (:compile-load dependent (:fasload package depdefs clx)) ;; Macros only needed for compilation (:skip :compile-load macros (:fasload package depdefs clx dependent)) ;; Bufmac only needed for compilation (:skip :compile-load bufmac (:fasload package depdefs clx dependent macros)) (:compile-load buffer (:fasload package depdefs clx dependent macros bufmac)) (:compile-load display (:fasload package depdefs clx dependent macros bufmac buffer)) (:compile-load gcontext (:fasload package depdefs clx dependent macros bufmac buffer display)) (:compile-load input (:fasload package depdefs clx dependent macros bufmac buffer display)) (:compile-load requests (:fasload package depdefs clx dependent macros bufmac buffer display input)) (:compile-load fonts (:fasload package depdefs clx dependent macros bufmac buffer display)) (:compile-load graphics (:fasload package depdefs clx dependent macros fonts bufmac buffer display fonts)) (:compile-load text (:fasload package depdefs clx dependent macros fonts bufmac buffer display gcontext fonts)) (:compile-load-init attributes (dependent) (:fasload package depdefs clx dependent macros bufmac buffer display)) (:compile-load translate (:fasload package depdefs clx dependent macros bufmac buffer display)) (:compile-load keysyms (:fasload package depdefs clx dependent macros bufmac buffer display translate)) (:compile-load manager (:fasload package depdefs clx dependent macros bufmac buffer display)) (:compile-load image (:fasload package depdefs clx dependent macros bufmac buffer display)) (:compile-load resource (:fasload package depdefs clx dependent macros bufmac buffer display)) (:auxiliary doc) ) ;;; Symbolics Lisp Machines #+Genera (scl:defsystem CLX (:default-pathname "SYS:X11;CLX;" :pretty-name "CLX" :maintaining-sites (:scrc) :distribute-sources t :distribute-binaries t :source-category :basic) (:module doc ("doc") (:type :lisp-example)) (:serial "package" "depdefs" "generalock" "clx" "dependent" "macros" "bufmac" "buffer" "display" "gcontext" "input" "requests" "fonts" "graphics" "text" "attributes" "translate" "keysyms" "manager" "image" "resource")) #+Minima (zl:::scl:defsystem Minima-CLX (:default-pathname "SYS:X11;CLX;" :pretty-name "Minima CLX" :maintain-journals nil :maintaining-sites (:scrc) :distribute-sources t :distribute-binaries t :source-category :basic :default-module-type :minima-lisp) (:module doc ("doc") (:type :lisp-example)) (:serial "package" "depdefs" "clx" "dependent" "macros" "bufmac" "buffer" "display" "gcontext" "input" "requests" "fonts" "graphics" "text" "attributes" "translate" "keysyms" "manager" "image" "resource")) ;;; Franz ;; ;; The following is a suggestion. If you comment out this form be ;; prepared for possible deadlock, since no interrupts will be recognized ;; while reading from the X socket if the scheduler is not running. ;; #+excl (setq compiler::generate-interrupt-checks-switch (compile nil '(lambda (safety size speed &optional debug) (declare (ignore size debug)) (or (< speed 3) (> safety 0))))) ;;; Allegro #+allegro (excl:defsystem :clx () |package| (|excldep| :load-before-compile (|package|) :recompile-on (|package|)) (|depdefs| :load-before-compile (|package| |excldep|) :recompile-on (|excldep|)) (|clx| :load-before-compile (|package| |excldep| |depdefs|) :recompile-on (|package| |excldep| |depdefs|)) (|dependent| :load-before-compile (|package| |excldep| |depdefs| |clx|) :recompile-on (|clx|)) (|exclcmac| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|) :recompile-on (|dependent|)) (|macros| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac|) :recompile-on (|exclcmac|)) (|bufmac| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros|) :recompile-on (|macros|)) (|buffer| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac|) :recompile-on (|bufmac|)) (|display| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer|) :recompile-on (|buffer|)) (|gcontext| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) (|input| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) (|requests| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| |input|) :recompile-on (|display|)) (|fonts| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) (|graphics| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| |fonts|) :recompile-on (|fonts|)) (|text| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| |gcontext| |fonts|) :recompile-on (|gcontext| |fonts|) :load-after (|translate|)) ;; The above line gets around a compiler macro expansion bug. (|attributes| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) (|translate| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| |text|) :recompile-on (|display|)) (|keysyms| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| |translate|) :recompile-on (|translate|)) (|manager| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) (|image| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) ;; Don't know if l-b-c list is correct. XX (|resource| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) ) #+allegro (excl:defsystem :clx-debug (:default-pathname "debug/" :needed-systems (:clx) :load-before-compile (:clx)) |describe| |keytrans| |trace| |util|) ;;;; Compile CLX ;;; COMPILE-CLX compiles the lisp source files and loads the binaries. ;;; It goes to some trouble to let the source files be in one directory ;;; and the binary files in another. Thus the same set of sources can ;;; be used for different machines and/or lisp systems. It also allows ;;; you to supply explicit extensions, so source files do not have to ;;; be renamed to fit into the naming conventions of an implementation. ;;; For example, ;;; (compile-clx "*.lisp" "machine/") ;;; compiles source files from the connected directory and puts them ;;; into the "machine" subdirectory. You can then load CLX out of the ;;; machine directory. ;;; The code has no knowledge of the source file types (eg, ".l" or ;;; ".lisp") or of the binary file types (eg, ".b" or ".sbin"). Calling ;;; compile-file and load with a file type of NIL usually sorts things ;;; out correctly, but you may have to explicitly give the source and ;;; binary file types. ;;; An attempt at compiling the C language sources is also made, ;;; but you may have to set different compiler switches ;;; should be. If it doesn't do the right thing, then do ;;; (compile-clx "" "" :compile-c NIL) ;;; to prevent the compilation. ;;; compilation notes ;;; lucid2.0/hp9000s300 ;;; must uudecode the file make-sequence-patch.uu #+(or lucid kcl ibcl cmu) (defun clx-foreign-files (binary-path) #+(and lucid (not lcl3.0) (or mc68000 mc68020)) (load (merge-pathnames "make-sequence-patch" binary-path)) #+(and lucid apollo) (lucid::load-foreign-file (namestring (merge-pathnames "socket" binary-path)) :preserve-pathname t) #+(and lucid (not apollo)) (lucid::load-foreign-files (list (namestring (merge-pathnames "socket.o" binary-path))) '("-lc")) #+cmu (declare (ignore binary-path)) #+(or cmu sbcl) (alien:def-alien-routine ("connect_to_server" xlib::connect-to-server) c-call:int (host c-call:c-string) (port c-call:int)) #+(or kcl ibcl) (progn (let ((pathname (merge-pathnames "sockcl.o" binary-path)) (options (concatenate 'string (namestring (merge-pathnames "socket.o" binary-path)) " -lc"))) (format t "~&Faslinking ~A with ~A.~%" pathname options) (si:faslink (namestring pathname) options) (format t "~&Finished faslinking ~A.~%" pathname))) ) #-(or lispm allegro Minima) (defun compile-clx (&optional (source-pathname-defaults "") (binary-pathname-defaults "") &key (compile-c t)) ;; The pathname-defaults above might only be strings, so coerce them ;; to pathnames. Build a default binary path with every component ;; of the source except the file type. This should prevent ;; (compile-clx "*.lisp") from destroying source files. (let* ((source-path (pathname source-pathname-defaults)) (path (make-pathname :host (pathname-host source-path) :device (pathname-device source-path) :directory (pathname-directory source-path) :name (pathname-name source-path) :type nil :version (pathname-version source-path))) (binary-path (merge-pathnames binary-pathname-defaults path)) #+clx-ansi-common-lisp (*compile-verbose* t) (*load-verbose* t)) ;; Make sure source-path and binary-path file types are distinct so ;; we don't accidently overwrite the source files. NIL should be an ;; ok type, but anything else spells trouble. (if (and (equal (pathname-type source-path) (pathname-type binary-path)) (not (null (pathname-type binary-path)))) (error "Source and binary pathname defaults have same type ~s ~s" source-path binary-path)) (format t "~&;;; Default paths: ~s ~s~%" source-path binary-path) ;; In lucid make sure we're using the compiler in production mode. #+lcl3.0 (progn (unless (member :pqc *features*) (cerror "Go ahead anyway." "Lucid's production mode compiler must be loaded to compile CLX.")) (proclaim '(optimize (speed 3) (safety 1) (space 0) (compilation-speed 0)))) (labels ((compile-lisp (filename) (let ((source (merge-pathnames filename source-path)) (binary (merge-pathnames filename binary-path))) ;; If the source and binary pathnames are the same, ;; then don't supply an output file just to be sure ;; compile-file defaults correctly. #+(or kcl ibcl) (load source) (if (equal source binary) (compile-file source) (compile-file source :output-file binary)) binary)) (compile-and-load (filename) (load (compile-lisp filename))) #+(or lucid kcl ibcl) (compile-c (filename) (let* ((c-filename (concatenate 'string filename ".c")) (o-filename (concatenate 'string filename ".o")) (src (merge-pathnames c-filename source-path)) (obj (merge-pathnames o-filename binary-path)) (args (list "-c" (namestring src) "-o" (namestring obj) #+mips "-G 0" #+(or hp sysv) "-DSYSV" #+(and mips (not dec)) "-I/usr/include/bsd" #-(and mips (not dec)) "-DUNIXCONN" #+(and lucid pa) "-DHPUX -DHPUX7.0" ))) (format t ";;; cc~{ ~A~}~%" args) (unless (zerop #+lucid (multiple-value-bind (iostream estream exitstatus pid) ;; in 2.0, run-program is exported from system: ;; in 3.0, run-program is exported from lcl: ;; system inheirits lcl (system::run-program "cc" :arguments args) (declare (ignore iostream estream pid)) exitstatus) #+(or kcl ibcl) (system (format nil "cc~{ ~A~}" args))) (error "Compile of ~A failed." src))))) ;; Now compile and load all the files. ;; Defer compiler warnings until everything's compiled, if possible. (#+(or clx-ansi-common-lisp CMU) with-compilation-unit #+lcl3.0 lucid::with-deferred-warnings #-(or lcl3.0 clx-ansi-common-lisp CMU) progn () (compile-and-load "package") #+(or lucid kcl ibcl) (when compile-c (compile-c "socket")) #+(or kcl ibcl) (compile-lisp "sockcl") #+(or lucid kcl ibcl) (clx-foreign-files binary-path) #+excl (compile-and-load "excldep") (compile-and-load "depdefs") (compile-and-load "clx") (compile-and-load "dependent") #+excl (compile-and-load "exclcmac") ; these are just macros (compile-and-load "macros") ; these are just macros (compile-and-load "bufmac") ; these are just macros (compile-and-load "buffer") (compile-and-load "display") (compile-and-load "gcontext") (compile-and-load "input") (compile-and-load "requests") (compile-and-load "fonts") (compile-and-load "graphics") (compile-and-load "text") (compile-and-load "attributes") (compile-and-load "translate") (compile-and-load "keysyms") (compile-and-load "manager") (compile-and-load "image") (compile-and-load "resource") )))) ;;;; Load CLX ;;; This procedure loads the binaries for CLX. All of the binaries ;;; should be in the same directory, so setting the default pathname ;;; should point load to the right place. ;;; You should have a module definition somewhere so the require/provide ;;; mechanism can avoid reloading CLX. In an ideal world, somebody would ;;; just put ;;; (REQUIRE 'CLX) ;;; in their file (some implementations don't have a central registry for ;;; modules, so a pathname needs to be supplied). ;;; The REQUIRE should find a file that does ;;; (IN-PACKAGE 'XLIB :USE '(LISP)) ;;; (PROVIDE 'CLX) ;;; (LOAD ) ;;; (LOAD-CLX ) #-(or lispm allegro Minima) (defun load-clx (&optional (binary-pathname-defaults "") &key (macrosp nil)) (let* ((source-path (pathname "")) (path (make-pathname :host (pathname-host source-path) :device (pathname-device source-path) :directory (pathname-directory source-path) :name (pathname-name source-path) :type nil :version (pathname-version source-path))) (binary-path (merge-pathnames binary-pathname-defaults path)) (*load-verbose* t)) (flet ((load-binary (filename) (let ((binary (merge-pathnames filename binary-path))) (load binary)))) (load-binary "package") #+(or lucid kcl ibcl cmu) (clx-foreign-files binary-path) #+excl (load-binary "excldep") (load-binary "depdefs") (load-binary "clx") (load-binary "dependent") (when macrosp #+excl (load-binary "exclcmac") (load-binary "macros") (load-binary "bufmac")) (load-binary "buffer") (load-binary "display") (load-binary "gcontext") (load-binary "input") (load-binary "requests") (load-binary "fonts") (load-binary "graphics") (load-binary "text") (load-binary "attributes") (load-binary "translate") (load-binary "keysyms") (load-binary "manager") (load-binary "image") (load-binary "resource") ))) ;;; ;;; ECL likes to combine several files into a single dynamically loadable ;;; library. ;;; #+ecl (defconstant +clx-modules+ '("package" "depdefs" "clx" "dependent" "macros" "bufmac" "buffer" "display" "gcontext" "input" "requests" "fonts" "graphics" "text" "attributes" "translate" "keysyms" "manager" "image" "resource")) #+(or) ;ecl (flet ((compile-if-old (destdir sources &rest options) (mapcar #'(lambda (source) (let ((object (merge-pathnames destdir (compile-file-pathname source :type :object)))) (unless (and (probe-file object) (>= (file-write-date object) (file-write-date source))) (apply #'compile-file source :output-file object options)) object)) sources))) (let ((clx-objects (compile-if-old "./" +clx-modules+ :system-p t))) (c::build-fasl "clx" :lisp-files clx-objects))) (mapcar #'load +clx-modules+) cl-clx-sbcl-0.7.4.20160323.orig/keysyms.lisp0000644000175000017500000004164212715665272016226 0ustar pdmpdm;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES -*- ;;; Define lisp character to keysym mappings ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (in-package :xlib) (define-keysym-set :latin-1 (keysym 0 0) (keysym 0 255)) (define-keysym-set :latin-2 (keysym 1 0) (keysym 1 255)) (define-keysym-set :latin-3 (keysym 2 0) (keysym 2 255)) (define-keysym-set :latin-4 (keysym 3 0) (keysym 3 255)) (define-keysym-set :kana (keysym 4 0) (keysym 4 255)) (define-keysym-set :arabic (keysym 5 0) (keysym 5 255)) (define-keysym-set :cyrillic (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 :thai (keysym 13 0) (keysym 13 255)) (define-keysym-set :korean (keysym 14 0) (keysym 14 255)) (define-keysym-set :latin-5 (keysym 15 0) (keysym 15 255)) (define-keysym-set :latin-6 (keysym 16 0) (keysym 16 255)) (define-keysym-set :latin-7 (keysym 17 0) (keysym 17 255)) (define-keysym-set :latin-8 (keysym 18 0) (keysym 18 255)) (define-keysym-set :latin-9 (keysym 19 0) (keysym 19 255)) (define-keysym-set :currency (keysym 32 0) (keysym 32 255)) (define-keysym-set :|3270| (keysym 253 0) (keysym 253 255)) (define-keysym-set :xkb (keysym 254 0) (keysym 254 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 ) ;;; these keysym definitions are only correct if the underlying lisp's ;;; definition of characters between 160 and 255 match latin1 exactly. ;;; If the characters are in some way locale-dependent (as, I believe, ;;; in Allegro8) or are treated as opaque without any notions of ;;; graphicness or case (as in cmucl and openmcl) then defining these ;;; keysyms is either not useful or wrong. -- CSR, 2006-03-14 #+sbcl (progn (do ((i 160 (+ i 1))) ((>= i 256)) (if (or (<= #xc0 i #xd6) (<= #xd8 i #xde)) (define-keysym (code-char i) i :lowercase (+ i 32)) (define-keysym (code-char i) i)))) #+(or lispm excl) (progn ;; Nonstandard characters (define-keysym #\escape (keysym 255 027)) ; :tty ) #+ti (progn (define-keysym #\Inverted-exclamation-mark 161) (define-keysym #\american-cent-sign 162) (define-keysym #\british-pound-sign 163) (define-keysym #\Currency-sign 164) (define-keysym #\Japanese-yen-sign 165) (define-keysym #\Yen 165) (define-keysym #\Broken-bar 166) (define-keysym #\Section-symbol 167) (define-keysym #\Section 167) (define-keysym #\Diaresis 168) (define-keysym #\Umlaut 168) (define-keysym #\Copyright-sign 169) (define-keysym #\Copyright 169) (define-keysym #\Feminine-ordinal-indicator 170) (define-keysym #\Angle-quotation-left 171) (define-keysym #\Soft-hyphen 173) (define-keysym #\Shy 173) (define-keysym #\Registered-trademark 174) (define-keysym #\Macron 175) (define-keysym #\Degree-sign 176) (define-keysym #\Ring 176) (define-keysym #\Plus-minus-sign 177) (define-keysym #\Superscript-2 178) (define-keysym #\Superscript-3 179) (define-keysym #\Acute-accent 180) (define-keysym #\Greek-mu 181) (define-keysym #\Paragraph-symbol 182) (define-keysym #\Paragraph 182) (define-keysym #\Pilcrow-sign 182) (define-keysym #\Middle-dot 183) (define-keysym #\Cedilla 184) (define-keysym #\Superscript-1 185) (define-keysym #\Masculine-ordinal-indicator 186) (define-keysym #\Angle-quotation-right 187) (define-keysym #\Fraction-1/4 188) (define-keysym #\One-quarter 188) (define-keysym #\Fraction-1/2 189) (define-keysym #\One-half 189) (define-keysym #\Fraction-3/4 190) (define-keysym #\Three-quarters 190) (define-keysym #\Inverted-question-mark 191) (define-keysym #\Multiplication-sign 215) (define-keysym #\Eszet 223) (define-keysym #\Division-sign 247) ) #+ti (progn ;; There are no 7-bit ascii representations for the following ;; European characters, so use int-char to create them to ensure ;; nothing is lost while sending files through the mail. (define-keysym (int-char 192) 192 :lowercase 224) (define-keysym (int-char 193) 193 :lowercase 225) (define-keysym (int-char 194) 194 :lowercase 226) (define-keysym (int-char 195) 195 :lowercase 227) (define-keysym (int-char 196) 196 :lowercase 228) (define-keysym (int-char 197) 197 :lowercase 229) (define-keysym (int-char 198) 198 :lowercase 230) (define-keysym (int-char 199) 199 :lowercase 231) (define-keysym (int-char 200) 200 :lowercase 232) (define-keysym (int-char 201) 201 :lowercase 233) (define-keysym (int-char 202) 202 :lowercase 234) (define-keysym (int-char 203) 203 :lowercase 235) (define-keysym (int-char 204) 204 :lowercase 236) (define-keysym (int-char 205) 205 :lowercase 237) (define-keysym (int-char 206) 206 :lowercase 238) (define-keysym (int-char 207) 207 :lowercase 239) (define-keysym (int-char 208) 208 :lowercase 240) (define-keysym (int-char 209) 209 :lowercase 241) (define-keysym (int-char 210) 210 :lowercase 242) (define-keysym (int-char 211) 211 :lowercase 243) (define-keysym (int-char 212) 212 :lowercase 244) (define-keysym (int-char 213) 213 :lowercase 245) (define-keysym (int-char 214) 214 :lowercase 246) (define-keysym (int-char 215) 215) (define-keysym (int-char 216) 216 :lowercase 248) (define-keysym (int-char 217) 217 :lowercase 249) (define-keysym (int-char 218) 218 :lowercase 250) (define-keysym (int-char 219) 219 :lowercase 251) (define-keysym (int-char 220) 220 :lowercase 252) (define-keysym (int-char 221) 221 :lowercase 253) (define-keysym (int-char 222) 222 :lowercase 254) (define-keysym (int-char 223) 223) (define-keysym (int-char 224) 224) (define-keysym (int-char 225) 225) (define-keysym (int-char 226) 226) (define-keysym (int-char 227) 227) (define-keysym (int-char 228) 228) (define-keysym (int-char 229) 229) (define-keysym (int-char 230) 230) (define-keysym (int-char 231) 231) (define-keysym (int-char 232) 232) (define-keysym (int-char 233) 233) (define-keysym (int-char 234) 234) (define-keysym (int-char 235) 235) (define-keysym (int-char 236) 236) (define-keysym (int-char 237) 237) (define-keysym (int-char 238) 238) (define-keysym (int-char 239) 239) (define-keysym (int-char 240) 240) (define-keysym (int-char 241) 241) (define-keysym (int-char 242) 242) (define-keysym (int-char 243) 243) (define-keysym (int-char 244) 244) (define-keysym (int-char 245) 245) (define-keysym (int-char 246) 246) (define-keysym (int-char 247) 247) (define-keysym (int-char 248) 248) (define-keysym (int-char 249) 249) (define-keysym (int-char 250) 250) (define-keysym (int-char 251) 251) (define-keysym (int-char 252) 252) (define-keysym (int-char 253) 253) (define-keysym (int-char 254) 254) (define-keysym (int-char 255) 255) ) #+lispm ;; Nonstandard characters (progn (define-keysym #\center-dot (keysym 183)) ; :latin-1 (define-keysym #\down-arrow (keysym 008 254)) ; :technical (define-keysym #\alpha (keysym 007 225)) ; :greek (define-keysym #\beta (keysym 007 226)) ; :greek (define-keysym #\and-sign (keysym 008 222)) ; :technical (define-keysym #\not-sign (keysym 172)) ; :latin-1 (define-keysym #\epsilon (keysym 007 229)) ; :greek (define-keysym #\pi (keysym 007 240)) ; :greek (define-keysym #\lambda (keysym 007 235)) ; :greek (define-keysym #\gamma (keysym 007 227)) ; :greek (define-keysym #\delta (keysym 007 228)) ; :greek (define-keysym #\up-arrow (keysym 008 252)) ; :technical (define-keysym #\plus-minus (keysym 177)) ; :latin-1 (define-keysym #\infinity (keysym 008 194)) ; :technical (define-keysym #\partial-delta (keysym 008 239)) ; :technical (define-keysym #\left-horseshoe (keysym 011 218)) ; :apl (define-keysym #\right-horseshoe (keysym 011 216)) ; :apl (define-keysym #\up-horseshoe (keysym 011 195)) ; :apl (define-keysym #\down-horseshoe (keysym 011 214)) ; :apl (define-keysym #\double-arrow (keysym 008 205)) ; :technical (define-keysym #\left-arrow (keysym 008 251)) ; :technical (define-keysym #\right-arrow (keysym 008 253)) ; :technical (define-keysym #\not-equals (keysym 008 189)) ; :technical (define-keysym #\less-or-equal (keysym 008 188)) ; :technical (define-keysym #\greater-or-equal (keysym 008 190)) ; :technical (define-keysym #\equivalence (keysym 008 207)) ; :technical (define-keysym #\or-sign (keysym 008 223)) ; :technical (define-keysym #\integral (keysym 008 191)) ; :technical ;; break isn't null ;; (define-keysym #\null (keysym 255 107)) ; :function (define-keysym #\clear-input (keysym 255 011)) ; :tty (define-keysym #\help (keysym 255 106)) ; :function (define-keysym #\refresh (keysym 255 097)) ; :function (define-keysym #\abort (keysym 255 105)) ; :function (define-keysym #\resume (keysym 255 098)) ; :function (define-keysym #\end (keysym 255 087)) ; :cursor ;;#\universal-quantifier ;;#\existential-quantifier ;;#\circle-plus ;;#\circle-cross same as #\circle-x ) #+genera (progn ;;#\network ;;#\symbol-help (define-keysym #\lozenge (keysym 009 224)) ; :special (define-keysym #\suspend (keysym 255 019)) ; :tty (define-keysym #\function (keysym 255 032)) ; :function (define-keysym #\square (keysym 010 231)) ; :publishing (define-keysym #\circle (keysym 010 230)) ; :publishing (define-keysym #\triangle (keysym 010 232)) ; :publishing (define-keysym #\scroll (keysym 255 086)) ; :cursor (define-keysym #\select (keysym 255 096)) ; :function (define-keysym #\complete (keysym 255 104)) ; :function ) #+ti (progn (define-keysym #\terminal (keysym 255 032)) ; :function (define-keysym #\system (keysym 255 096)) ; :function (define-keysym #\center-arrow (keysym 255 80)) (define-keysym #\left-arrow (keysym 255 081)) ; :cursor (define-keysym #\up-arrow (keysym 255 082)) ; :cursor (define-keysym #\right-arrow (keysym 255 083)) ; :cursor (define-keysym #\down-arrow (keysym 255 084)) ; :cursor (define-keysym #\end (keysym 255 087)) ; :cursor (define-keysym #\undo (keysym 255 101)) ; :function (define-keysym #\break (keysym 255 107)) (define-keysym #\keypad-space (keysym 255 128)) ; :keypad (define-keysym #\keypad-tab (keysym 255 137)) ; :keypad (define-keysym #\keypad-enter (keysym 255 141)) ; :keypad (define-keysym #\f1 (keysym 255 145)) ; :keypad (define-keysym #\f2 (keysym 255 146)) ; :keypad (define-keysym #\f3 (keysym 255 147)) ; :keypad (define-keysym #\f4 (keysym 255 148)) ; :keypad (define-keysym #\f1 (keysym 255 190)) ; :keypad (define-keysym #\f2 (keysym 255 191)) ; :keypad (define-keysym #\f3 (keysym 255 192)) ; :keypad (define-keysym #\f4 (keysym 255 193)) ; :keypad (define-keysym #\keypad-plus (keysym 255 171)) ; :keypad (define-keysym #\keypad-comma (keysym 255 172)) ; :keypad (define-keysym #\keypad-minus (keysym 255 173)) ; :keypad (define-keysym #\keypad-period (keysym 255 174)) ; :keypad (define-keysym #\keypad-0 (keysym 255 176)) ; :keypad (define-keysym #\keypad-1 (keysym 255 177)) ; :keypad (define-keysym #\keypad-2 (keysym 255 178)) ; :keypad (define-keysym #\keypad-3 (keysym 255 179)) ; :keypad (define-keysym #\keypad-4 (keysym 255 180)) ; :keypad (define-keysym #\keypad-5 (keysym 255 181)) ; :keypad (define-keysym #\keypad-6 (keysym 255 182)) ; :keypad (define-keysym #\keypad-7 (keysym 255 183)) ; :keypad (define-keysym #\keypad-8 (keysym 255 184)) ; :keypad (define-keysym #\keypad-9 (keysym 255 185)) ; :keypad (define-keysym #\keypad-equal (keysym 255 189)) ; :keypad (define-keysym #\f1 (keysym 255 192)) ; :function (define-keysym #\f2 (keysym 255 193)) ; :function (define-keysym #\f3 (keysym 255 194)) ; :function (define-keysym #\f4 (keysym 255 195)) ; :function (define-keysym #\network (keysym 255 214)) (define-keysym #\status (keysym 255 215)) (define-keysym #\clear-screen (keysym 255 217)) (define-keysym #\left (keysym 255 218)) (define-keysym #\middle (keysym 255 219)) (define-keysym #\right (keysym 255 220)) (define-keysym #\resume (keysym 255 221)) (define-keysym #\vt (keysym 009 233)) ; :special ;; same as #\delete ) #+ti (progn ;; Explorer specific characters (define-keysym #\Call (keysym 131)) ; :latin-1 (define-keysym #\Macro (keysym 133)) ; :latin-1 (define-keysym #\Quote (keysym 142)) ; :latin-1 (define-keysym #\Hold-output (keysym 143)) ; :latin-1 (define-keysym #\Stop-output (keysym 144)) ; :latin-1 (define-keysym #\Center (keysym 156)) ; :latin-1 (define-keysym #\no-break-space (keysym 160)) ; :latin-1 (define-keysym #\circle-plus (keysym 13)) ; :latin-1 (define-keysym #\universal-quantifier (keysym 20)) ; :latin-1 (define-keysym #\existential-quantifier (keysym 21)) ; :latin-1 (define-keysym #\circle-cross (keysym 22)) ; :latin-1 ) cl-clx-sbcl-0.7.4.20160323.orig/build-clx.lisp0000644000175000017500000000162112715665272016376 0ustar pdmpdm;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- ;;; Load this file if you want to compile CLX in its entirety. (proclaim '(optimize (speed 3) (safety 1) (space 1) (compilation-speed 0))) ;;; Hide CLOS from CLX, so objects stay implemented as structures. ;;; #|| (when (find-package "CLOS") (rename-package (find-package "CLOS") "NO-CLOS-HERE")) (when (find-package "PCL") (rename-package (find-package "PCL") "NO-PCL-HERE")) (when (find-package "SB-PCL") (rename-package (find-package "SB-PCL") "NO-SB-PCL-HERE")) ||# (when (find-package "XLIB") (delete-package "XLIB")) (unless (find-package "XLIB") (make-package "XLIB" :use '("COMMON-LISP"))) #-sbcl (compile-file "clx:defsystem.lisp" :error-file nil :load t) #+sbcl (progn (compile-file "clx:defsystem.lisp") (load "clx:defsystem")) (with-compilation-unit () (#+cmu xlib:compile-clx #-cmu compile-clx (pathname "CLX:"))) cl-clx-sbcl-0.7.4.20160323.orig/xinerama.lisp0000644000175000017500000000547712715665273016335 0ustar pdmpdm;;; -*- Mode: Lisp -*- ;;; ;;; Copyright (C) 2008, Julian Stecklina ;;; ;;; (( ;;; )) This file is COFFEEWARE. As long as you retain this notice ;;; | |o) you can do whatever you want with this code. If you think, ;;; |___|jgs it's worth it, you may buy the author a coffee in return. ;;; ;;; Description: ;;; ;;; This is an implementation of the XINERAMA extension. It does not ;;; include the obsolete PanoramiX calls. (defpackage "XLIB.XINERAMA" (:use "COMMON-LISP" "XLIB") (:nicknames "XINERAMA") (:import-from "XLIB" "WITH-BUFFER-REQUEST" "WITH-BUFFER-REQUEST-AND-REPLY" "DATA" "BOOLEAN" "BOOLEAN-GET" "CARD8" "CARD8-GET" "CARD16" "CARD16-GET" "CARD32" "CARD32-GET" "INT16" "INT16-GET") (:export "SCREEN-INFO" "SCREEN-INFO-NUMBER" "SCREEN-INFO-X" "SCREEN-INFO-Y" "SCREEN-INFO-WIDTH" "SCREEN-INFO-HEIGHT" "XINERAMA-QUERY-VERSION" "XINERAMA-IS-ACTIVE" "XINERAMA-QUERY-SCREENS")) (in-package "XINERAMA") (define-extension "XINERAMA") (defun xinerama-opcode (display) (extension-opcode display "XINERAMA")) (defconstant +major-version+ 1) (defconstant +minor-version+ 1) (defconstant +get-version+ 0) (defconstant +get-state+ 1) (defconstant +get-screen-count+ 2) (defconstant +get-screen-size+ 3) (defconstant +is-active+ 4) (defconstant +query-screens+ 5) (defstruct screen-info (number 0 :type (unsigned-byte 32)) (x 0 :type (signed-byte 16)) (y 0 :type (signed-byte 16)) (width 0 :type (unsigned-byte 16)) (height 0 :type (unsigned-byte 16))) (defun xinerama-query-version (display) (with-buffer-request-and-reply (display (xinerama-opcode display) nil) ((data +get-version+) (card8 +major-version+) (card8 +minor-version+)) (values (card16-get 8) ; server major version (card16-get 10)))) ; server minor version (defun xinerama-is-active (display) "Returns T, iff Xinerama is supported and active." (with-buffer-request-and-reply (display (xinerama-opcode display) nil) ((data +is-active+)) (values ;; XCB says this is actually a CARD32, but why?! (boolean-get 8)))) (defun xinerama-query-screens (display) "Returns a list of screen-info structures." (with-buffer-request-and-reply (display (xinerama-opcode display) nil) ((data +query-screens+)) (values (loop with index = 32 for number from 0 below (card32-get 8) collect (prog1 (make-screen-info :number number :x (int16-get index) :y (int16-get (+ index 2)) :width (card16-get (+ index 4)) :height (card16-get (+ index 6))) (incf index 8)))))) ;;; EOF cl-clx-sbcl-0.7.4.20160323.orig/display.lisp0000644000175000017500000006766112715665272016200 0ustar pdmpdm;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11 ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (in-package :xlib) ;;; Authorizaton (defparameter *known-authorizations* '("MIT-MAGIC-COOKIE-1")) ;;; X11 Authorization: to prevent malicious users from snooping on a ;;; 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 xauth(1) and the AUTHORITY-PATHNAME ;;; function). 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. ;;; The format of the .Xauthority file is documented in the XFree ;;; sources, in the file xc/lib/Xau/README. ;;; Stolen from the cmucl sources, with patches by Hannu Rummukainen and ;;; Scott Fahlman. (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-id (read-short stream nil))) (if (null family-id) (list nil nil nil nil nil) (let* ((address-data (read-short-length-vector stream)) (num-string (read-short-length-string stream)) (number (when (string/= num-string "") (parse-integer num-string))) (name (read-short-length-string stream)) (data (read-short-length-vector stream)) (family (car (rassoc family-id *protocol-families*)))) (unless family (return-from read-xauth-entry ;; we return FAMILY-ID to signal to ;; GET-BEST-AUTHORIZATION that we haven't finished ;; with the stream. (list family-id nil nil nil nil))) (let ((address (case family (:local (map 'string #'code-char address-data)) (:internet (coerce address-data 'list)) ;; FIXME: we can probably afford not to support ;; :DECNET or :CHAOSNET in this modern age, but ;; :INTERNET6 probably deserve support. -- CSR, ;; 2005-08-07 (t nil)))) ;; if ADDRESS is NIL by this time, we will never match ;; the address of DISPLAY. (list family address 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) (or (null number) (= 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 "" ""))) (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)) ;; ;; 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 use in DISPLAY (declare (type display display)) (declare (clx-values resource-id)) (loop for next-count upfrom (1+ (display-resource-id-count display)) repeat (1+ (display-resource-id-mask display)) as id = (dpb next-count (display-resource-id-byte display) (display-resource-id-base display)) unless (nth-value 1 (gethash id (display-resource-id-map display))) do (setf (display-resource-id-count display) next-count) (setf (gethash id (display-resource-id-map display)) t) (return-from resourcealloc id)) ;; internal consistency check (assert (= (hash-table-count (display-resource-id-map display)) (1+ (display-resource-id-mask display)))) ;; tell the user what's gone wrong (error 'resource-ids-exhausted)) (defmacro allocate-resource-id (display object type) ;; Allocate a resource-id for OBJECT in DISPLAY `(with-display (,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) (declare (ignore type)) ;; Deallocate a resource-id for OBJECT in DISPLAY `(deallocate-resource-id-internal ,display ,id)) (defun deallocate-resource-id-internal (display id) (with-display (display) (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) ;; cache the object associated with ID for this display. (declare (type display display) (type integer id) (type t object)) (declare (clx-values object)) ;; we can't cache objects from other clients, because they may ;; become invalid without us being told about that. (let ((base (display-resource-id-base display)) (mask (display-resource-id-mask display))) (when (= (logandc2 id mask) base) (setf (gethash id (display-resource-id-map display)) object)) 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-event-queue ((display &key timeout inline) &body body &environment env) ;; exclusive access to event queue `(macrolet ((with-event-queue ((display &key timeout) &body body) ;; Speedup hack for lexically nested with-event-queues `(progn (progn ,display ,@(and timeout `(,timeout)) nil) ,@body))) ,(if (and (null inline) (macroexpand '(use-closures) env)) `(flet ((.with-event-queue-body. () ,@body)) #+clx-ansi-common-lisp (declare (dynamic-extent #'.with-event-queue-body.)) (with-event-queue-function ,display ,timeout #'.with-event-queue-body.)) (let ((disp (if (or (symbolp display) (constantp display)) display '.display.))) `(let (,@(unless (eq disp display) `((,disp ,display)))) (holding-lock ((display-event-lock ,disp) ,disp "CLX Event Lock" ,@(and timeout `(:timeout ,timeout))) ,@body)))))) (defun with-event-queue-function (display timeout function) (declare (type display display) (type (or null number) timeout) (type function function) #+clx-ansi-common-lisp (dynamic-extent function) ;; FIXME: see SBCL bug #243 (ignorable display timeout) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg function)) (with-event-queue (display :timeout timeout :inline t) (funcall function))) (defmacro with-event-queue-internal ((display &key timeout) &body body) ;; exclusive access to the internal event queues (let ((disp (if (or (symbolp display) (constantp display)) display '.display.))) `(let (,@(unless (eq disp display) `((,disp ,display)))) (holding-lock ((display-event-queue-lock ,disp) ,disp "CLX Event Queue Lock" ,@(and timeout `(:timeout ,timeout))) ,@body)))) (defun open-default-display (&optional display-name) "Open a connection to DISPLAY-NAME if supplied, or to the appropriate default display as given by GET-DEFAULT-DISPLAY otherwise. OPEN-DISPLAY-NAME always attempts to do display authorization. The hostname is resolved to an address, then authorization data for the (protocol, host-address, displaynumber) triple is looked up in the file given by AUTHORITY_PATHNAME (typically $HOME/.Xauthority). If the protocol is :local, or if the hostname resolves to the local host, authority data for the local machine's actual hostname - as returned by gethostname(3) - is used instead." (destructuring-bind (host display screen protocol) (get-default-display display-name) (let ((display (open-display host :display display :protocol protocol))) (setf (display-default-screen display) (nth screen (display-roots display))) display))) (defun open-display (host &key (display 0) protocol authorization-name authorization-data) ;; Implementation specific routine to setup the buffer for a ;; specific host and display. This must interface with the local ;; network facilities, and will probably do special things to ;; circumvent the nework when displaying on the local host. ;; ;; A string must be acceptable as a host, but otherwise the possible types ;; for host and protocol are not constrained, and will likely be very ;; system dependent. The default protocol is system specific. Authorization, ;; if any, is assumed to come from the environment somehow. (declare (type integer display)) (declare (clx-values display)) ;; Get the authorization mechanism from the environment. Handle the ;; special case of a host name of "" and "unix" which means the ;; protocol is :local (when (null authorization-name) (multiple-value-setq (authorization-name authorization-data) (get-best-authorization host display (if (member host '("" "unix") :test #'equal) :local protocol)))) ;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM. (let* ((stream (open-x-stream host display protocol)) (disp (make-buffer *output-buffer-size* #'make-display-internal :host host :display display :output-stream stream :input-stream stream)) (ok-p nil)) (unwind-protect (progn (display-connect disp :authorization-name authorization-name :authorization-data authorization-data) (setf (display-authorization-name disp) authorization-name) (setf (display-authorization-data disp) authorization-data) (initialize-resource-allocator disp) (initialize-predefined-atoms disp) (initialize-extensions disp) (when (assoc "BIG-REQUESTS" (display-extension-alist disp) :test #'string=) (enable-big-requests 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")) cl-clx-sbcl-0.7.4.20160323.orig/graphics.lisp0000644000175000017500000004102012715665272016310 0ustar pdmpdm;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; CLX drawing requests ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (in-package :xlib) (defvar *inhibit-appending* nil) (defun draw-point (drawable gcontext x y) ;; Should be clever about appending to existing buffered protocol request. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y)) (let ((display (drawable-display drawable))) (declare (type display display)) (with-display (display) (force-gcontext-changes-internal gcontext) (with-buffer-output (display :length +requestsize+) (let* ((last-request-byte (display-last-request display)) (current-boffset buffer-boffset)) ;; To append or not append, that is the question (if (and (not *inhibit-appending*) last-request-byte ;; Same request? (= (aref-card8 buffer-bbuf last-request-byte) +x-polypoint+) (progn ;; Set buffer pointers to last request (set-buffer-offset last-request-byte) ;; same drawable and gcontext? (or (compare-request (4) (data 0) (drawable drawable) (gcontext gcontext)) (progn ;; If failed, reset buffer pointers (set-buffer-offset current-boffset) nil)))) ;; Append request (progn ;; Set new request length (card16-put 2 (index+ 1 (index-ash (index- current-boffset last-request-byte) -2))) (set-buffer-offset current-boffset) (put-items (0) ; Insert new point (int16 x y)) (setf (display-boffset display) (index+ buffer-boffset 4))) ;; New Request (progn (put-items (4) (code +x-polypoint+) (data 0) ;; Relative-p false (length 4) (drawable drawable) (gcontext gcontext) (int16 x y)) (buffer-new-request-number display) (setf (buffer-last-request display) buffer-boffset) (setf (display-boffset display) (index+ buffer-boffset 16))))))) (display-invoke-after-function display))) (defun draw-points (drawable gcontext points &optional relative-p) (declare (type drawable drawable) (type gcontext gcontext) (type sequence points) ;(repeat-seq (integer x) (integer y)) (type generalized-boolean relative-p)) (with-buffer-request ((drawable-display drawable) +x-polypoint+ :gc-force gcontext) ((data boolean) relative-p) (drawable drawable) (gcontext gcontext) ((sequence :format int16) points))) (defun draw-line (drawable gcontext x1 y1 x2 y2 &optional relative-p) ;; Should be clever about appending to existing buffered protocol request. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x1 y1 x2 y2) (type generalized-boolean relative-p)) (let ((display (drawable-display drawable))) (declare (type display display)) (when relative-p (incf x2 x1) (incf y2 y1)) (with-display (display) (force-gcontext-changes-internal gcontext) (with-buffer-output (display :length +requestsize+) (let* ((last-request-byte (display-last-request display)) (current-boffset buffer-boffset)) ;; To append or not append, that is the question (if (and (not *inhibit-appending*) last-request-byte ;; Same request? (= (aref-card8 buffer-bbuf last-request-byte) +x-polysegment+) (progn ;; Set buffer pointers to last request (set-buffer-offset last-request-byte) ;; same drawable and gcontext? (or (compare-request (4) (drawable drawable) (gcontext gcontext)) (progn ;; If failed, reset buffer pointers (set-buffer-offset current-boffset) nil)))) ;; Append request (progn ;; Set new request length (card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte) -2))) (set-buffer-offset current-boffset) (put-items (0) ; Insert new point (int16 x1 y1 x2 y2)) (setf (display-boffset display) (index+ buffer-boffset 8))) ;; New Request (progn (put-items (4) (code +x-polysegment+) (length 5) (drawable drawable) (gcontext gcontext) (int16 x1 y1 x2 y2)) (buffer-new-request-number display) (setf (buffer-last-request display) buffer-boffset) (setf (display-boffset display) (index+ buffer-boffset 20))))))) (display-invoke-after-function display))) (defun draw-lines (drawable gcontext points &key relative-p fill-p (shape :complex)) (declare (type drawable drawable) (type gcontext gcontext) (type sequence points) ;(repeat-seq (integer x) (integer y)) (type generalized-boolean relative-p fill-p) (type (member :complex :non-convex :convex) shape)) (if fill-p (fill-polygon drawable gcontext points relative-p shape) (with-buffer-request ((drawable-display drawable) +x-polyline+ :gc-force gcontext) ((data boolean) relative-p) (drawable drawable) (gcontext gcontext) ((sequence :format int16) points)))) ;; Internal function called from DRAW-LINES (defun fill-polygon (drawable gcontext points relative-p shape) ;; This is clever about appending to previous requests. Should it be? (declare (type drawable drawable) (type gcontext gcontext) (type sequence points) ;(repeat-seq (integer x) (integer y)) (type generalized-boolean relative-p) (type (member :complex :non-convex :convex) shape)) (with-buffer-request ((drawable-display drawable) +x-fillpoly+ :gc-force gcontext) (drawable drawable) (gcontext gcontext) ((member8 :complex :non-convex :convex) shape) (boolean relative-p) ((sequence :format int16) points))) (defun draw-segments (drawable gcontext segments) (declare (type drawable drawable) (type gcontext gcontext) ;; (repeat-seq (integer x1) (integer y1) (integer x2) (integer y2))) (type sequence segments)) (with-buffer-request ((drawable-display drawable) +x-polysegment+ :gc-force gcontext) (drawable drawable) (gcontext gcontext) ((sequence :format int16) segments))) (defun draw-rectangle (drawable gcontext x y width height &optional fill-p) ;; Should be clever about appending to existing buffered protocol request. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type card16 width height) (type generalized-boolean fill-p)) (let ((display (drawable-display drawable)) (request (if fill-p +x-polyfillrectangle+ +x-polyrectangle+))) (declare (type display display) (type card16 request)) (with-display (display) (force-gcontext-changes-internal gcontext) (with-buffer-output (display :length +requestsize+) (let* ((last-request-byte (display-last-request display)) (current-boffset buffer-boffset)) ;; To append or not append, that is the question (if (and (not *inhibit-appending*) last-request-byte ;; Same request? (= (aref-card8 buffer-bbuf last-request-byte) request) (progn ;; Set buffer pointers to last request (set-buffer-offset last-request-byte) ;; same drawable and gcontext? (or (compare-request (4) (drawable drawable) (gcontext gcontext)) (progn ;; If failed, reset buffer pointers (set-buffer-offset current-boffset) nil)))) ;; Append request (progn ;; Set new request length (card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte) -2))) (set-buffer-offset current-boffset) (put-items (0) ; Insert new point (int16 x y) (card16 width height)) (setf (display-boffset display) (index+ buffer-boffset 8))) ;; New Request (progn (put-items (4) (code request) (length 5) (drawable drawable) (gcontext gcontext) (int16 x y) (card16 width height)) (buffer-new-request-number display) (setf (buffer-last-request display) buffer-boffset) (setf (display-boffset display) (index+ buffer-boffset 20))))))) (display-invoke-after-function display))) (defun draw-rectangles (drawable gcontext rectangles &optional fill-p) (declare (type drawable drawable) (type gcontext gcontext) ;; (repeat-seq (integer x) (integer y) (integer width) (integer height))) (type sequence rectangles) (type generalized-boolean fill-p)) (with-buffer-request ((drawable-display drawable) (if fill-p +x-polyfillrectangle+ +x-polyrectangle+) :gc-force gcontext) (drawable drawable) (gcontext gcontext) ((sequence :format int16) rectangles))) (defun draw-arc (drawable gcontext x y width height angle1 angle2 &optional fill-p) ;; Should be clever about appending to existing buffered protocol request. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type card16 width height) (type angle angle1 angle2) (type generalized-boolean fill-p)) (let ((display (drawable-display drawable)) (request (if fill-p +x-polyfillarc+ +x-polyarc+))) (declare (type display display) (type card16 request)) (with-display (display) (force-gcontext-changes-internal gcontext) (with-buffer-output (display :length +requestsize+) (let* ((last-request-byte (display-last-request display)) (current-boffset buffer-boffset)) ;; To append or not append, that is the question (if (and (not *inhibit-appending*) last-request-byte ;; Same request? (= (aref-card8 buffer-bbuf last-request-byte) request) (progn ;; Set buffer pointers to last request (set-buffer-offset last-request-byte) ;; same drawable and gcontext? (or (compare-request (4) (drawable drawable) (gcontext gcontext)) (progn ;; If failed, reset buffer pointers (set-buffer-offset current-boffset) nil)))) ;; Append request (progn ;; Set new request length (card16-put 2 (index+ 3 (index-ash (index- current-boffset last-request-byte) -2))) (set-buffer-offset current-boffset) (put-items (0) ; Insert new point (int16 x y) (card16 width height) (angle angle1 angle2)) (setf (display-boffset display) (index+ buffer-boffset 12))) ;; New Request (progn (put-items (4) (code request) (length 6) (drawable drawable) (gcontext gcontext) (int16 x y) (card16 width height) (angle angle1 angle2)) (buffer-new-request-number display) (setf (buffer-last-request display) buffer-boffset) (setf (display-boffset display) (index+ buffer-boffset 24))))))) (display-invoke-after-function display))) (defun draw-arcs-list (drawable gcontext arcs &optional fill-p) (declare (type drawable drawable) (type gcontext gcontext) (type list arcs) (type generalized-boolean fill-p)) (let* ((display (drawable-display drawable)) (limit (index- (buffer-size display) 12)) (length (length arcs)) (request (if fill-p +x-polyfillarc+ +x-polyarc+))) (with-buffer-request ((drawable-display drawable) request :gc-force gcontext) (drawable drawable) (gcontext gcontext) (progn (card16-put 2 (index+ (index-ash length -1) 3)) ; Set request length (in words) (set-buffer-offset (index+ buffer-boffset 12)) ; Position to start of data (do ((arc arcs)) ((endp arc) (setf (buffer-boffset display) buffer-boffset)) ;; Make sure there's room (when (index>= buffer-boffset limit) (setf (buffer-boffset display) buffer-boffset) (buffer-flush display) (set-buffer-offset (buffer-boffset display))) (int16-put 0 (pop arc)) (int16-put 2 (pop arc)) (card16-put 4 (pop arc)) (card16-put 6 (pop arc)) (angle-put 8 (pop arc)) (angle-put 10 (pop arc)) (set-buffer-offset (index+ buffer-boffset 12))))))) (defun draw-arcs-vector (drawable gcontext arcs &optional fill-p) (declare (type drawable drawable) (type gcontext gcontext) (type vector arcs) (type generalized-boolean fill-p)) (let* ((display (drawable-display drawable)) (limit (index- (buffer-size display) 12)) (length (length arcs)) (request (if fill-p +x-polyfillarc+ +x-polyarc+))) (with-buffer-request ((drawable-display drawable) request :gc-force gcontext) (drawable drawable) (gcontext gcontext) (progn (card16-put 2 (index+ (index-ash length -1) 3)) ; Set request length (in words) (set-buffer-offset (index+ buffer-boffset 12)) ; Position to start of data (do ((n 0 (index+ n 6)) (length (length arcs))) ((index>= n length) (setf (buffer-boffset display) buffer-boffset)) ;; Make sure there's room (when (index>= buffer-boffset limit) (setf (buffer-boffset display) buffer-boffset) (buffer-flush display) (set-buffer-offset (buffer-boffset display))) (int16-put 0 (aref arcs (index+ n 0))) (int16-put 2 (aref arcs (index+ n 1))) (card16-put 4 (aref arcs (index+ n 2))) (card16-put 6 (aref arcs (index+ n 3))) (angle-put 8 (aref arcs (index+ n 4))) (angle-put 10 (aref arcs (index+ n 5))) (set-buffer-offset (index+ buffer-boffset 12))))))) (defun draw-arcs (drawable gcontext arcs &optional fill-p) (declare (type drawable drawable) (type gcontext gcontext) (type sequence arcs) (type generalized-boolean fill-p)) (etypecase arcs (list (draw-arcs-list drawable gcontext arcs fill-p)) (vector (draw-arcs-vector drawable gcontext arcs fill-p)))) ;; The following image routines are bare minimum. It may be useful to define ;; some form of "image" object to hide representation details and format ;; conversions. It also may be useful to provide stream-oriented interfaces ;; for reading and writing the data. (defun put-raw-image (drawable gcontext data &key (start 0) (depth (required-arg depth)) (x (required-arg x)) (y (required-arg y)) (width (required-arg width)) (height (required-arg height)) (left-pad 0) (format (required-arg format))) ;; Data must be a sequence of 8-bit quantities, already in the appropriate format ;; for transmission; the caller is responsible for all byte and bit swapping and ;; compaction. Start is the starting index in data; the end is computed from the ;; other arguments. (declare (type drawable drawable) (type gcontext gcontext) (type sequence data) ; Sequence of integers (type array-index start) (type card8 depth left-pad) ;; required (type int16 x y) ;; required (type card16 width height) ;; required (type (member :bitmap :xy-pixmap :z-pixmap) format)) (with-buffer-request ((drawable-display drawable) +x-putimage+ :gc-force gcontext) ((data (member :bitmap :xy-pixmap :z-pixmap)) format) (drawable drawable) (gcontext gcontext) (card16 width height) (int16 x y) (card8 left-pad depth) (pad16 nil) ((sequence :format card8 :start start) data))) (defun get-raw-image (drawable &key data (start 0) (x (required-arg x)) (y (required-arg y)) (width (required-arg width)) (height (required-arg height)) (plane-mask #xffffffff) (format (required-arg format)) (result-type '(vector card8))) ;; If data is given, it is modified in place (and returned), otherwise a new sequence ;; is created and returned, with a size computed from the other arguments and the ;; returned depth. The sequence is filled with 8-bit quantities, in transmission ;; format; the caller is responsible for any byte and bit swapping and compaction ;; required for further local use. (declare (type drawable drawable) (type (or null sequence) data) ;; sequence of integers (type int16 x y) ;; required (type card16 width height) ;; required (type array-index start) (type pixel plane-mask) (type (member :xy-pixmap :z-pixmap) format)) (declare (clx-values (clx-sequence integer) depth visual-info)) (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display +x-getimage+ nil :sizes (8 32)) (((data (member error :xy-pixmap :z-pixmap)) format) (drawable drawable) (int16 x y) (card16 width height) (card32 plane-mask)) (let ((depth (card8-get 1)) (length (* 4 (card32-get 4))) (visual (resource-id-get 8))) (values (sequence-get :result-type result-type :format card8 :length length :start start :data data :index +replysize+) depth (visual-info display visual)))))) cl-clx-sbcl-0.7.4.20160323.orig/gl.lisp0000644000175000017500000034501312715665272015123 0ustar pdmpdm(defpackage :gl (:use :common-lisp :xlib) (:import-from :glx "*CURRENT-CONTEXT*" "CONTEXT" "CONTEXT-P" "CONTEXT-DISPLAY" "CONTEXT-TAG" "CONTEXT-RBUF" "CONTEXT-INDEX" ) (:import-from :xlib "DATA" "WITH-BUFFER-REQUEST" "WITH-BUFFER-REQUEST-AND-REPLY" "CARD32-GET" "SEQUENCE-GET" "WITH-DISPLAY" "DISPLAY-FORCE-OUTPUT" "INT8" "INT16" "INT32" "INTEGER" "CARD8" "CARD16" "CARD32" "ASET-CARD8" "ASET-CARD16" "ASET-CARD32" "ASET-INT8" "ASET-INT16" "ASET-INT32" "DECLARE-BUFFUN" ;; Types "ARRAY-INDEX" "BUFFER-BYTES" ) (:export "GET-STRING" ;; Rendering commands (alphabetical order) "ACCUM" "ACTIVE-TEXTURE-ARB" "ALPHA-FUNC" "BEGIN" "BIND-TEXTURE" "BLEND-COLOR" "BLEND-EQUOTION" "BLEND-FUNC" "CALL-LIST" "CLEAR" "CLEAR-ACCUM" "CLEAR-COLOR" "CLEAR-DEPTH" "CLEAR-INDEX" "CLEAR-STENCIL" "CLIP-PLANE" "COLOR-3B" "COLOR-3D" "COLOR-3F" "COLOR-3I" "COLOR-3S" "COLOR-3UB" "COLOR-3UI" "COLOR-3US" "COLOR-4B" "COLOR-4D" "COLOR-4F" "COLOR-4I" "COLOR-4S" "COLOR-4UB" "COLOR-4UI" "COLOR-4US" "COLOR-MASK" "COLOR-MATERIAL" "CONVOLUTION-PARAMETER-F" "CONVOLUTION-PARAMETER-I" "COPY-COLOR-SUB-TABLE" "COPY-COLOR-TABLE" "COPY-CONVOLUTION-FILTER-ID" "COPY-CONVOLUTION-FILTER-2D" "COPY-PIXELS" "COPY-TEX-IMAGE-1D" "COPY-TEX-IMAGE-2D" "COPY-TEX-SUB-IMAGE-1D" "COPY-TEX-SUB-IMAGE-2D" "COPY-TEX-SUB-IMAGE-3D" "CULL-FACE" "DEPTH-FUNC" "DEPTH-MASK" "DEPTH-RANGE" "DRAW-BUFFER" "EDGE-FLAG-V" "END" "EVAL-COORD-1D" "EVAL-COORD-1F" "EVAL-COORD-2D" "EVAL-COORD-2F" "EVAL-MESH-1" "EVAL-MESH-2" "EVAL-POINT-1" "EVAL-POINT-2" "FOG-F" "FOG-I" "FRONT-FACE" "FRUSTUM" "HINT" "HISTOGRAM" "INDEX-MASK" "INDEX-D" "INDEX-F" "INDEX-I" "INDEX-S" "INDEX-UB" "INIT-NAMES" "LIGHT-MODEL-F" "LIGHT-MODEL-I" "LIGHT-F" "LIGHT-FV" "LIGHT-I" "LIGHT-IV" "LINE-STIPPLE" "LINE-WIDTH" "LIST-BASE" "LOAD-IDENTITY" "LOAD-NAME" "LOGIC-OP" "MAP-GRID-1D" "MAP-GRID-1F" "MAP-GRID-2D" "MAP-GRID-2F" "MATERIAL-F" "MATERIAL-FV" "MATERIAL-I" "MATERIAL-IV" "MATRIX-MODE" "MINMAX" "MULTI-TEX-COORD-1D-ARB" "MULTI-TEX-COORD-1F-ARB" "MULTI-TEX-COORD-1I-ARB" "MULTI-TEX-COORD-1S-ARB" "MULTI-TEX-COORD-2D-ARB" "MULTI-TEX-COORD-2F-ARB" "MULTI-TEX-COORD-2I-ARB" "MULTI-TEX-COORD-2S-ARB" "MULTI-TEX-COORD-3D-ARB" "MULTI-TEX-COORD-3F-ARB" "MULTI-TEX-COORD-3I-ARB" "MULTI-TEX-COORD-3S-ARB" "MULTI-TEX-COORD-4D-ARB" "MULTI-TEX-COORD-4F-ARB" "MULTI-TEX-COORD-4I-ARB" "MULTI-TEX-COORD-4S-ARB" "NORMAL-3B" "NORMAL-3D" "NORMAL-3F" "NORMAL-3I" "NORMAL-3S" "ORTHO" "PASS-THROUGH" "PIXEL-TRANSFER-F" "PIXEL-TRANSFER-I" "PIXEL-ZOOM" "POINT-SIZE" "POLYGON-MODE" "POLYGON-OFFSET" "POP-ATTRIB" "POP-MATRIX" "POP-NAME" "PUSH-ATTRIB" "PUSH-MATRIX" "PUSH-NAME" "RASTER-POS-2D" "RASTER-POS-2F" "RASTER-POS-2I" "RASTER-POS-2S" "RASTER-POS-3D" "RASTER-POS-3F" "RASTER-POS-3I" "RASTER-POS-3S" "RASTER-POS-4D" "RASTER-POS-4F" "RASTER-POS-4I" "RASTER-POS-4S" "READ-BUFFER" "RECT-D" "RECT-F" "RECT-I" "RECT-S" "RESET-HISTOGRAM" "RESET-MINMAX" "ROTATE-D" "ROTATE-F" "SCALE-D" "SCALE-F" "SCISSOR" "SHADE-MODEL" "STENCIL-FUNC" "STENCIL-MASK" "STENCIL-OP" "TEX-ENV-F" "TEX-ENV-I" "TEX-GEN-D" "TEX-GEN-F" "TEX-GEN-I" "TEX-PARAMETER-F" "TEX-PARAMETER-I" "TRANSLATE-D" "TRANSLATE-F" "VERTEX-2D" "VERTEX-2F" "VERTEX-2I" "VERTEX-2S" "VERTEX-3D" "VERTEX-3F" "VERTEX-3I" "VERTEX-3S" "VERTEX-4D" "VERTEX-4F" "VERTEX-4I" "VERTEX-4S" "VIEWPORT" ;; * Where did this come from? ;;"NO-FLOATS" ;; Non-rendering commands "NEW-LIST" "END-LIST" "GEN-LISTS" "ENABLE" "DISABLE" "FLUSH" "FINISH" ;; Constants ;; Boolean "+FALSE+" "+TRUE+" ;; Types "+BYTE+" "+UNSIGNED-BYTE+" "+SHORT+" "+UNSIGNED-SHORT+" "+INT+" "+UNSIGNED-INT+" "+FLOAT+" "+DOUBLE+" "+2-BYTES+" "+3-BYTES+" "+4-BYTES+" ;; Primitives "+POINTS+" "+LINES+" "+LINE-LOOP+" "+LINE-STRIP+" "+TRIANGLES+" "+TRIANGLE-STRIP+" "+triangle-fan+" "+QUADS+" "+QUAD-STRIP+" "+POLYGON+" ;; Arrays "+VERTEX-ARRAY+" "+NORMAL-ARRAY+" "+COLOR-ARRAY+" "+INDEX-ARRAY+" "+TEXTURE-COORD-ARRAY+" "+EDGE-FLAG-ARRAY+" "+VERTEX-ARRAY-SIZE+" "+VERTEX-ARRAY-TYPE+" "+VERTEX-ARRAY-STRIDE+" "+NORMAL-ARRAY-TYPE+" "+NORMAL-ARRAY-STRIDE+" "+COLOR-ARRAY-SIZE+" "+COLOR-ARRAY-TYPE+" "+COLOR-ARRAY-STRIDE+" "+INDEX-ARRAY-TYPE+" "+INDEX-ARRAY-STRIDE+" "+TEXTURE-COORD-ARRAY-SIZE+" "+TEXTURE-COORD-ARRAY-TYPE+" "+TEXTURE-COORD-ARRAY-STRIDE+" "+EDGE-FLAG-ARRAY-STRIDE+" "+VERTEX-ARRAY-POINTER+" "+NORMAL-ARRAY-POINTER+" "+COLOR-ARRAY-POINTER+" "+INDEX-ARRAY-POINTER+" "+TEXTURE-COORD-ARRAY-POINTER+" "+EDGE-FLAG-ARRAY-POINTER+" ;; Array formats "+V2F+" "+V3F+" "+C4UB-V2F+" "+C4UB-V3F+" "+C3F-V3F+" "+N3F-V3F+" "+C4F-N3F-V3F+" "+T2F-V3F+" "+T4F-V4F+" "+T2F-C4UB-V3F+" "+T2F-C3F-V3F+" "+T2F-N3F-V3F+" "+T2F-C4F-N3F-V3F+" "+T4F-C4F-N3F-V4F+" ;; Matrices "+MATRIX-MODE+" "+MODELVIEW+" "+PROJECTION+" "+TEXTURE+" ;; Points "+POINT-SMOOTH+" "+POINT-SIZE+" "+POINT-SIZE-GRANULARITY+" "+POINT-SIZE-RANGE+" ;; Lines "+LINE-SMOOTH+" "+LINE-STIPPLE+" "+LINE-STIPPLE-PATTERN+" "+LINE-STIPPLE-REPEAT+" "+LINE-WIDTH+" "+LINE-WIDTH-GRANULARITY+" "+LINE-WIDTH-RANGE+" ;; Polygons "+POINT+" "+LINE+" "+FILL+" "+CW+" "+CCW+" "+FRONT+" "+BACK+" "+POLYGON-MODE+" "+POLYGON-SMOOTH+" "+POLYGON-STIPPLE+" "+EDGE-FLAG+" "+CULL-FACE+" "+CULL-FACE-MODE+" "+FRONT-FACE+" "+POLYGON-OFFSET-FACTOR+" "+POLYGON-OFFSET-UNITS+" "+POLYGON-OFFSET-POINT+" "+POLYGON-OFFSET-LINE+" "+POLYGON-OFFSET-FILL+" ;; Display Lists "+COMPILE+" "+COMPILE-AND-EXECUTE+" "+LIST-BASE+" "+LIST-INDEX+" "+LIST-MODE+" ;; Depth Buffer "+NEVER+" "+LESS+" "+EQUAL+" "+LEQUAL+" "+GREATER+" "+NOTEQUAL+" "+GEQUAL+" "+ALWAYS+" "+DEPTH-TEST+" "+DEPTH-BITS+" "+DEPTH-CLEAR-VALUE+" "+DEPTH-FUNC+" "+DEPTH-RANGE+" "+DEPTH-WRITEMASK+" "+DEPTH-COMPONENT+" ;; Lighting "+LIGHTING+" "+LIGHT0+" "+LIGHT1+" "+LIGHT2+" "+LIGHT3+" "+LIGHT4+" "+LIGHT5+" "+LIGHT6+" "+LIGHT7+" "+SPOT-EXPONENT+" "+SPOT-CUTOFF+" "+CONSTANT-ATTENUATION+" "+LINEAR-ATTENUATION+" "+QUADRATIC-ATTENUATION+" "+AMBIENT+" "+DIFFUSE+" "+SPECULAR+" "+SHININESS+" "+EMISSION+" "+POSITION+" "+SPOT-DIRECTION+" "+AMBIENT-AND-DIFFUSE+" "+COLOR-INDEXES+" "+LIGHT-MODEL-TWO-SIDE+" "+LIGHT-MODEL-LOCAL-VIEWER+" "+LIGHT-MODEL-AMBIENT+" "+FRONT-AND-BACK+" "+SHADE-MODEL+" "+FLAT+" "+SMOOTH+" "+COLOR-MATERIAL+" "+COLOR-MATERIAL-FACE+" "+COLOR-MATERIAL-PARAMETER+" "+NORMALIZE+" ;; Clipping planes "+CLIP-PLANE0+" "+CLIP-PLANE1+" "+CLIP-PLANE2+" "+CLIP-PLANE3+" "+CLIP-PLANE4+" "+CLIP-PLANE5+" ;; Accumulation buffer "+ACCUM-RED-BITS+" "+ACCUM-GREEN-BITS+" "+ACCUM-BLUE-BITS+" "+ACCUM-ALPHA-BITS+" "+ACCUM-CLEAR-VALUE+" "+ACCUM+" "+ADD+" "+LOAD+" "+MULT+" "+RETURN+" ;; Alpha Testing "+ALPHA-TEST+" "+ALPHA-TEST-REF+" "+ALPHA-TEST-FUNC+" ;; Blending "+BLEND+" "+BLEND-SRC+" "+BLEND-DST+" "+ZERO+" "+ONE+" "+SRC-COLOR+" "+ONE-MINUS-SRC-COLOR+" "+DST-COLOR+" "+ONE-MINUS-DST-COLOR+" "+SRC-ALPHA+" "+ONE-MINUS-SRC-ALPHA+" "+DST-ALPHA+" "+ONE-MINUS-DST-ALPHA+" "+SRC-ALPHA-SATURATE+" "+CONSTANT-COLOR+" "+ONE-MINUS-CONSTANT-COLOR+" "+CONSTANT-ALPHA+" "+ONE-MINUS-CONSTANT-ALPHA+" ;; Render mode "+FEEDBACK+" "+RENDER+" "+SELECT+" ;; Feedback "+2D+" "+3D+" "+3D-COLOR+" "+3D-COLOR-TEXTURE+" "+4D-COLOR-TEXTURE+" "+POINT-TOKEN+" "+LINE-TOKEN+" "+LINE-RESET-TOKEN+" "+POLYGON-TOKEN+" "+BITMAP-TOKEN+" "+DRAW-PIXEL-TOKEN+" "+COPY-PIXEL-TOKEN+" "+PASS-THROUGH-TOKEN+" "+FEEDBACK-BUFFER-POINTER+" "+FEEDBACK-BUFFER-SIZE+" "+FEEDBACK-BUFFER-TYPE+" ;; Selection "+SELECTION-BUFFER-POINTER+" "+SELECTION-BUFFER-SIZE+" ;; Fog "+FOG+" "+FOG-MODE+" "+FOG-DENSITY+" "+FOG-COLOR+" "+FOG-INDEX+" "+FOG-START+" "+FOG-END+" "+LINEAR+" "+EXP+" "+EXP2+" ;; Logic operations "+LOGIC-OP+" "+INDEX-LOGIC-OP+" "+COLOR-LOGIC-OP+" "+LOGIC-OP-MODE+" "+CLEAR+" "+SET+" "+COPY+" "+COPY-INVERTED+" "+NOOP+" "+INVERT+" "+AND+" "+NAND+" "+OR+" "+NOR+" "+XOR+" "+EQUIV+" "+AND-REVERSE+" "+AND-INVERTED+" "+OR-REVERSE+" "+OR-INVERTED+" ;; Stencil "+STENCIL-TEST+" "+STENCIL-WRITEMASK+" "+STENCIL-BITS+" "+STENCIL-FUNC+" "+STENCIL-VALUE-MASK+" "+STENCIL-REF+" "+STENCIL-FAIL+" "+STENCIL-PASS-DEPTH-PASS+" "+STENCIL-PASS-DEPTH-FAIL+" "+STENCIL-CLEAR-VALUE+" "+STENCIL-INDEX+" "+KEEP+" "+REPLACE+" "+INCR+" "+DECR+" ;; Buffers, Pixel Drawing/Reading "+NONE+" "+LEFT+" "+RIGHT+" "+FRONT-LEFT+" "+FRONT-RIGHT+" "+BACK-LEFT+" "+BACK-RIGHT+" "+AUX0+" "+AUX1+" "+AUX2+" "+AUX3+" "+COLOR-INDEX+" "+RED+" "+GREEN+" "+BLUE+" "+ALPHA+" "+LUMINANCE+" "+LUMINANCE-ALPHA+" "+ALPHA-BITS+" "+RED-BITS+" "+GREEN-BITS+" "+BLUE-BITS+" "+INDEX-BITS+" "+SUBPIXEL-BITS+" "+AUX-BUFFERS+" "+READ-BUFFER+" "+DRAW-BUFFER+" "+DOUBLEBUFFER+" "+STEREO+" "+BITMAP+" "+COLOR+" "+DEPTH+" "+STENCIL+" "+DITHER+" "+RGB+" "+RGBA+" ;; Implementation Limits "+MAX-LIST-NESTING+" "+MAX-ATTRIB-STACK-DEPTH+" "+MAX-MODELVIEW-STACK-DEPTH+" "+MAX-NAME-STACK-DEPTH+" "+MAX-PROJECTION-STACK-DEPTH+" "+MAX-TEXTURE-STACK-DEPTH+" "+MAX-EVAL-ORDER+" "+MAX-LIGHTS+" "+MAX-CLIP-PLANES+" "+MAX-TEXTURE-SIZE+" "+MAX-PIXEL-MAP-TABLE+" "+MAX-VIEWPORT-DIMS+" "+MAX-CLIENT-ATTRIB-STACK-DEPTH+" ;; Gets "+ATTRIB-STACK-DEPTH+" "+CLIENT-ATTRIB-STACK-DEPTH+" "+COLOR-CLEAR-VALUE+" "+COLOR-WRITEMASK+" "+CURRENT-INDEX+" "+CURRENT-COLOR+" "+CURRENT-NORMAL+" "+CURRENT-RASTER-COLOR+" "+CURRENT-RASTER-DISTANCE+" "+current-raster-index+" "+CURRENT-RASTER-POSITION+" "+CURRENT-RASTER-TEXTURE-COORDS+" "+CURRENT-RASTER-POSITION-VALID+" "+CURRENT-TEXTURE-COORDS+" "+INDEX-CLEAR-VALUE+" "+INDEX-MODE+" "+INDEX-WRITEMASK+" "+MODELVIEW-MATRIX+" "+MODELVIEW-STACK-DEPTH+" "+NAME-STACK-DEPTH+" "+PROJECTION-MATRIX+" "+PROJECTION-STACK-DEPTH+" "+RENDER-MODE+" "+RGBA-MODE+" "+TEXTURE-MATRIX+" "+TEXTURE-STACK-DEPTH+" "+VIEWPORT+" ;; GL Evaluators "+AUTO-NORMAL+" "+MAP1-COLOR-4+" "+MAP1-GRID-DOMAIN+" "+MAP1-GRID-SEGMENTS+" "+MAP1-INDEX+" "+MAP1-NORMAL+" "+MAP1-TEXTURE-COORD-1+" "+MAP1-TEXTURE-COORD-2+" "+MAP1-TEXTURE-COORD-3+" "+MAP1-TEXTURE-COORD-4+" "+MAP1-VERTEX-3+" "+MAP1-VERTEX-4+" "+MAP2-COLOR-4+" "+MAP2-GRID-DOMAIN+" "+MAP2-GRID-SEGMENTS+" "+MAP2-INDEX+" "+MAP2-NORMAL+" "+MAP2-TEXTURE-COORD-1+" "+MAP2-TEXTURE-COORD-2+" "+MAP2-TEXTURE-COORD-3+" "+MAP2-TEXTURE-COORD-4+" "+MAP2-VERTEX-3+" "+MAP2-VERTEX-4+" "+COEFF+" "+DOMAIN+" "+ORDER+" ;; Hints "+FOG-HINT+" "+LINE-SMOOTH-HINT+" "+PERSPECTIVE-CORRECTION-HINT+" "+POINT-SMOOTH-HINT+" "+POLYGON-SMOOTH-HINT+" "+DONT-CARE+" "+FASTEST+" "+NICEST+" ;; Scissor box "+SCISSOR-TEST+" "+SCISSOR-BOX+" ;; Pixel Mode / Transfer "+MAP-COLOR+" "+MAP-STENCIL+" "+INDEX-SHIFT+" "+INDEX-OFFSET+" "+RED-SCALE+" "+RED-BIAS+" "+GREEN-SCALE+" "+GREEN-BIAS+" "+BLUE-SCALE+" "+BLUE-BIAS+" "+ALPHA-SCALE+" "+ALPHA-BIAS+" "+DEPTH-SCALE+" "+DEPTH-BIAS+" "+PIXEL-MAP-S-TO-S-SIZE+" "+PIXEL-MAP-I-TO-I-SIZE+" "+PIXEL-MAP-I-TO-R-SIZE+" "+PIXEL-MAP-I-TO-G-SIZE+" "+PIXEL-MAP-I-TO-B-SIZE+" "+PIXEL-MAP-I-TO-A-SIZE+" "+PIXEL-MAP-R-TO-R-SIZE+" "+PIXEL-MAP-G-TO-G-SIZE+" "+PIXEL-MAP-B-TO-B-SIZE+" "+PIXEL-MAP-A-TO-A-SIZE+" "+PIXEL-MAP-S-TO-S+" "+PIXEL-MAP-I-TO-I+" "+PIXEL-MAP-I-TO-R+" "+PIXEL-MAP-I-TO-G+" "+PIXEL-MAP-I-TO-B+" "+PIXEL-MAP-I-TO-A+" "+PIXEL-MAP-R-TO-R+" "+PIXEL-MAP-G-TO-G+" "+PIXEL-MAP-B-TO-B+" "+PIXEL-MAP-A-TO-A+" "+PACK-ALIGNMENT+" "+PACK-LSB-FIRST+" "+PACK-ROW-LENGTH+" "+PACK-SKIP-PIXELS+" "+PACK-SKIP-ROWS+" "+PACK-SWAP-BYTES+" "+UNPACK-ALIGNMENT+" "+UNPACK-LSB-FIRST+" "+UNPACK-ROW-LENGTH+" "+UNPACK-SKIP-PIXELS+" "+UNPACK-SKIP-ROWS+" "+UNPACK-SWAP-BYTES+" "+ZOOM-X+" "+ZOOM-Y+" ;; Texture Mapping "+TEXTURE-ENV+" "+TEXTURE-ENV-MODE+" "+TEXTURE-1D+" "+TEXTURE-2D+" "+TEXTURE-WRAP-S+" "+TEXTURE-WRAP-T+" "+TEXTURE-MAG-FILTER+" "+TEXTURE-MIN-FILTER+" "+TEXTURE-ENV-COLOR+" "+TEXTURE-GEN-S+" "+TEXTURE-GEN-T+" "+TEXTURE-GEN-MODE+" "+TEXTURE-BORDER-COLOR+" "+TEXTURE-WIDTH+" "+TEXTURE-HEIGHT+" "+TEXTURE-BORDER+" "+TEXTURE-COMPONENTS+" "+TEXTURE-RED-SIZE+" "+TEXTURE-GREEN-SIZE+" "+TEXTURE-BLUE-SIZE+" "+TEXTURE-ALPHA-SIZE+" "+TEXTURE-LUMINANCE-SIZE+" "+TEXTURE-INTENSITY-SIZE+" "+NEAREST-MIPMAP-NEAREST+" "+NEAREST-MIPMAP-LINEAR+" "+LINEAR-MIPMAP-NEAREST+" "+LINEAR-MIPMAP-LINEAR+" "+OBJECT-LINEAR+" "+OBJECT-PLANE+" "+EYE-LINEAR+" "+EYE-PLANE+" "+SPHERE-MAP+" "+DECAL+" "+MODULATE+" "+NEAREST+" "+REPEAT+" "+CLAMP+" "+S+" "+T+" "+R+" "+Q+" "+TEXTURE-GEN-R+" "+TEXTURE-GEN-Q+" ;; GL 1.1 Texturing "+PROXY-TEXTURE-1D+" "+PROXY-TEXTURE-2D+" "+TEXTURE-PRIORITY+" "+TEXTURE-RESIDENT+" "+TEXTURE-BINDING-1D+" "+TEXTURE-BINDING-2D+" "+TEXTURE-INTERNAL-FORMAT+" "+PACK-SKIP-IMAGES+" "+PACK-IMAGE-HEIGHT+" "+UNPACK-SKIP-IMAGES+" "+UNPACK-IMAGE-HEIGHT+" "+TEXTURE-3D+" "+PROXY-TEXTURE-3D+" "+TEXTURE-DEPTH+" "+TEXTURE-WRAP-R+" "+MAX-3D-TEXTURE-SIZE+" "+TEXTURE-BINDING-3D+" ;; Internal texture formats (GL 1.1) "+ALPHA4+" "+ALPHA8+" "+ALPHA12+" "+ALPHA16+" "+LUMINANCE4+" "+LUMINANCE8+" "+LUMINANCE12+" "+LUMINANCE16+" "+LUMINANCE4-ALPHA4+" "+LUMINANCE6-ALPHA2+" "+LUMINANCE8-ALPHA8+" "+LUMINANCE12-ALPHA4+" "+LUMINANCE12-ALPHA12+" "+LUMINANCE16-ALPHA16+" "+INTENSITY+" "+INTENSITY4+" "+INTENSITY8+" "+INTENSITY12+" "+INTENSITY16+" "+R3-G3-B2+" "+RGB4+" "+RGB5+" "+RGB8+" "+RGB10+" "+RGB12+" "+RGB16+" "+RGBA2+" "+RGBA4+" "+RGB5-A1+" "+RGBA8+" "+rgb10-a2+" "+RGBA12+" "+RGBA16+" ;; Utility "+VENDOR+" "+RENDERER+" "+VERSION+" "+EXTENSIONS+" ;; Errors "+NO-ERROR+" "+INVALID-VALUE+" "+INVALID-ENUM+" "+INVALID-OPERATION+" "+STACK-OVERFLOW+" "+STACK-UNDERFLOW+" "+OUT-OF-MEMORY+" ;; OpenGL 1.2 "+RESCALE-NORMAL+" "+CLAMP-TO-EDGE+" "+MAX-ELEMENTS-VERTICES+" "+MAX-ELEMENTS-INDICES+" "+BGR+" "+BGRA+" "+UNSIGNED-BYTE-3-3-2+" "+UNSIGNED-BYTE-2-3-3-REV+" "+UNSIGNED-SHORT-5-6-5+" "+UNSIGNED-SHORT-5-6-5-REV+" "+UNSIGNED-SHORT-4-4-4-4+" "+UNSIGNED-SHORT-4-4-4-4-REV+" "+UNSIGNED-SHORT-5-5-5-1+" "+UNSIGNED-SHORT-1-5-5-5-REV+" "+UNSIGNED-INT-8-8-8-8+" "+UNSIGNED-INT-8-8-8-8-REV+" "+UNSIGNED-INT-10-10-10-2+" "+UNSIGNED-INT-2-10-10-10-REV+" "+LIGHT-MODEL-COLOR-CONTROL+" "+SINGLE-COLOR+" "+SEPARATE-SPECULAR-COLOR+" "+TEXTURE-MIN-LOD+" "+TEXTURE-MAX-LOD+" "+TEXTURE-BASE-LEVEL+" "+TEXTURE-MAX-LEVEL+" "+SMOOTH-POINT-SIZE-RANGE+" "+SMOOTH-POINT-SIZE-GRANULARITY+" "+SMOOTH-LINE-WIDTH-RANGE+" "+SMOOTH-LINE-WIDTH-GRANULARITY+" "+ALIASED-POINT-SIZE-RANGE+" "+ALIASED-LINE-WIDTH-RANGE+" ;; OpenGL 1.2 Imaging subset ;; GL_EXT_color_table "+COLOR-TABLE+" "+POST-CONVOLUTION-COLOR-TABLE+" "+POST-COLOR-MATRIX-COLOR-TABLE+" "+PROXY-COLOR-TABLE+" "+PROXY-POST-CONVOLUTION-COLOR-TABLE+" "+PROXY-POST-COLOR-MATRIX-COLOR-TABLE+" "+COLOR-TABLE-SCALE+" "+COLOR-TABLE-BIAS+" "+COLOR-TABLE-FORMAT+" "+COLOR-TABLE-WIDTH+" "+COLOR-TABLE-RED-SIZE+" "+COLOR-TABLE-GREEN-SIZE+" "+COLOR-TABLE-BLUE-SIZE+" "+COLOR-TABLE-ALPHA-SIZE+" "+COLOR-TABLE-LUMINANCE-SIZE+" "+COLOR-TABLE-INTENSITY-SIZE+" ;; GL_EXT_convolution and GL_HP_convolution "+CONVOLUTION-1D+" "+CONVOLUTION-2D+" "+SEPARABLE-2D+" "+CONVOLUTION-BORDER-MODE+" "+CONVOLUTION-FILTER-SCALE+" "+CONVOLUTION-FILTER-BIAS+" "+REDUCE+" "+CONVOLUTION-FORMAT+" "+CONVOLUTION-WIDTH+" "+CONVOLUTION-HEIGHT+" "+MAX-CONVOLUTION-WIDTH+" "+MAX-CONVOLUTION-HEIGHT+" "+POST-CONVOLUTION-RED-SCALE+" "+POST-CONVOLUTION-GREEN-SCALE+" "+POST-CONVOLUTION-BLUE-SCALE+" "+POST-CONVOLUTION-ALPHA-SCALE+" "+POST-CONVOLUTION-RED-BIAS+" "+POST-CONVOLUTION-GREEN-BIAS+" "+POST-CONVOLUTION-BLUE-BIAS+" "+POST-CONVOLUTION-ALPHA-BIAS+" "+CONSTANT-BORDER+" "+REPLICATE-BORDER+" "+CONVOLUTION-BORDER-COLOR+" ;; GL_SGI_color_matrix "+COLOR-MATRIX+" "+COLOR-MATRIX-STACK-DEPTH+" "+MAX-COLOR-MATRIX-STACK-DEPTH+" "+POST-COLOR-MATRIX-RED-SCALE+" "+POST-COLOR-MATRIX-GREEN-SCALE+" "+POST-COLOR-MATRIX-BLUE-SCALE+" "+POST-COLOR-MATRIX-ALPHA-SCALE+" "+POST-COLOR-MATRIX-RED-BIAS+" "+POST-COLOR-MATRIX-GREEN-BIAS+" "+POST-COLOR-MATRIX-BLUE-BIAS+" "+POST-COLOR-MATRIX-ALPHA-BIAS+" ;; GL_EXT_histogram "+HISTOGRAM+" "+PROXY-HISTOGRAM+" "+HISTOGRAM-WIDTH+" "+HISTOGRAM-FORMAT+" "+HISTOGRAM-RED-SIZE+" "+HISTOGRAM-GREEN-SIZE+" "+HISTOGRAM-BLUE-SIZE+" "+HISTOGRAM-ALPHA-SIZE+" "+HISTOGRAM-LUMINANCE-SIZE+" "+HISTOGRAM-SINK+" "+MINMAX+" "+MINMAX-FORMAT+" "+MINMAX-SINK+" "+TABLE-TOO-LARGE+" ;; GL_EXT_blend_color, GL_EXT_blend_minmax "+BLEND-EQUATION+" "+MIN+" "+MAX+" "+FUNC-ADD+" "+FUNC-SUBTRACT+" "+FUNC-REVERSE-SUBTRACT+" ;; glPush/PopAttrib bits "+CURRENT-BIT+" "+POINT-BIT+" "+LINE-BIT+" "+POLYGON-BIT+" "+POLYGON-STIPPLE-BIT+" "+PIXEL-MODE-BIT+" "+LIGHTING-BIT+" "+FOG-BIT+" "+DEPTH-BUFFER-BIT+" "+ACCUM-BUFFER-BIT+" "+STENCIL-BUFFER-BIT+" "+VIEWPORT-BIT+" "+TRANSFORM-BIT+" "+ENABLE-BIT+" "+COLOR-BUFFER-BIT+" "+HINT-BIT+" "+EVAL-BIT+" "+LIST-BIT+" "+TEXTURE-BIT+" "+SCISSOR-BIT+" "+ALL-ATTRIB-BITS+" "+CLIENT-PIXEL-STORE-BIT+" "+CLIENT-VERTEX-ARRAY-BIT+" "+CLIENT-ALL-ATTRIB-BITS+" ;; ARB Multitexturing extension "+ARB-MULTITEXTURE+" "+TEXTURE0-ARB+" "+TEXTURE1-ARB+" "+TEXTURE2-ARB+" "+TEXTURE3-ARB+" "+TEXTURE4-ARB+" "+TEXTURE5-ARB+" "+TEXTURE6-ARB+" "+TEXTURE7-ARB+" "+TEXTURE8-ARB+" "+TEXTURE9-ARB+" "+TEXTURE10-ARB+" "+TEXTURE11-ARB+" "+TEXTURE12-ARB+" "+TEXTURE13-ARB+" "+TEXTURE14-ARB+" "+TEXTURE15-ARB+" "+TEXTURE16-ARB+" "+TEXTURE17-ARB+" "+TEXTURE18-ARB+" "+TEXTURE19-ARB+" "+TEXTURE20-ARB+" "+TEXTURE21-ARB+" "+TEXTURE22-ARB+" "+TEXTURE23-ARB+" "+TEXTURE24-ARB+" "+TEXTURE25-ARB+" "+TEXTURE26-ARB+" "+TEXTURE27-ARB+" "+TEXTURE28-ARB+" "+TEXTURE29-ARB+" "+TEXTURE30-ARB+" "+TEXTURE31-ARB+" "+ACTIVE-TEXTURE-ARB+" "+CLIENT-ACTIVE-TEXTURE-ARB+" "+MAX-TEXTURE-UNITS-ARB+" ;;; Misc extensions "+EXT-ABGR+" "+ABGR-EXT+" "+EXT-BLEND-COLOR+" "+CONSTANT-COLOR-EXT+" "+ONE-MINUS-CONSTANT-COLOR-EXT+" "+CONSTANT-ALPHA-EXT+" "+ONE-MINUS-CONSTANT-ALPHA-EXT+" "+blend-color-ext+" "+EXT-POLYGON-OFFSET+" "+POLYGON-OFFSET-EXT+" "+POLYGON-OFFSET-FACTOR-EXT+" "+POLYGON-OFFSET-BIAS-EXT+" "+EXT-TEXTURE3D+" "+PACK-SKIP-IMAGES-EXT+" "+PACK-IMAGE-HEIGHT-EXT+" "+UNPACK-SKIP-IMAGES-EXT+" "+UNPACK-IMAGE-HEIGHT-EXT+" "+TEXTURE-3D-EXT+" "+PROXY-TEXTURE-3D-EXT+" "+TEXTURE-DEPTH-EXT+" "+TEXTURE-WRAP-R-EXT+" "+MAX-3D-TEXTURE-SIZE-EXT+" "+TEXTURE-3D-BINDING-EXT+" "+EXT-TEXTURE-OBJECT+" "+TEXTURE-PRIORITY-EXT+" "+TEXTURE-RESIDENT-EXT+" "+TEXTURE-1D-BINDING-EXT+" "+TEXTURE-2D-BINDING-EXT+" "+EXT-RESCALE-NORMAL+" "+RESCALE-NORMAL-EXT+" "+EXT-VERTEX-ARRAY+" "+VERTEX-ARRAY-EXT+" "+NORMAL-ARRAY-EXT+" "+COLOR-ARRAY-EXT+" "+INDEX-ARRAY-EXT+" "+TEXTURE-COORD-ARRAY-EXT+" "+EDGE-FLAG-ARRAY-EXT+" "+VERTEX-ARRAY-SIZE-EXT+" "+VERTEX-ARRAY-TYPE-EXT+" "+VERTEX-ARRAY-STRIDE-EXT+" "+VERTEX-ARRAY-COUNT-EXT+" "+NORMAL-ARRAY-TYPE-EXT+" "+NORMAL-ARRAY-STRIDE-EXT+" "+NORMAL-ARRAY-COUNT-EXT+" "+COLOR-ARRAY-SIZE-EXT+" "+COLOR-ARRAY-TYPE-EXT+" "+COLOR-ARRAY-STRIDE-EXT+" "+COLOR-ARRAY-COUNT-EXT+" "+INDEX-ARRAY-TYPE-EXT+" "+INDEX-ARRAY-STRIDE-EXT+" "+INDEX-ARRAY-COUNT-EXT+" "+TEXTURE-COORD-ARRAY-SIZE-EXT+" "+TEXTURE-COORD-ARRAY-TYPE-EXT+" "+TEXTURE-COORD-ARRAY-STRIDE-EXT+" "+TEXTURE-COORD-ARRAY-COUNT-EXT+" "+EDGE-FLAG-ARRAY-STRIDE-EXT+" "+EDGE-FLAG-ARRAY-COUNT-EXT+" "+VERTEX-ARRAY-POINTER-EXT+" "+NORMAL-ARRAY-POINTER-EXT+" "+COLOR-ARRAY-POINTER-EXT+" "+INDEX-ARRAY-POINTER-EXT+" "+TEXTURE-COORD-ARRAY-POINTER-EXT+" "+EDGE-FLAG-ARRAY-POINTER-EXT+" "+SGIS-TEXTURE-EDGE-CLAMP+" "+CLAMP-TO-EDGE-SGIS+" "+EXT-BLEND-MINMAX+" "+FUNC-ADD-EXT+" "+MIN-EXT+" "+MAX-EXT+" "+BLEND-EQUATION-EXT+" "+EXT-BLEND-SUBTRACT+" "+FUNC-SUBTRACT-EXT+" "+FUNC-REVERSE-SUBTRACT-EXT+" "+EXT-BLEND-LOGIC-OP+" "+EXT-POINT-PARAMETERS+" "+POINT-SIZE-MIN-EXT+" "+POINT-SIZE-MAX-EXT+" "+POINT-FADE-THRESHOLD-SIZE-EXT+" "+DISTANCE-ATTENUATION-EXT+" "+EXT-PALETTED-TEXTURE+" "+TABLE-TOO-LARGE-EXT+" "+COLOR-TABLE-FORMAT-EXT+" "+COLOR-TABLE-WIDTH-EXT+" "+COLOR-TABLE-RED-SIZE-EXT+" "+COLOR-TABLE-GREEN-SIZE-EXT+" "+COLOR-TABLE-BLUE-SIZE-EXT+" "+COLOR-TABLE-ALPHA-SIZE-EXT+" "+COLOR-TABLE-LUMINANCE-SIZE-EXT+" "+COLOR-TABLE-INTENSITY-SIZE-EXT+" "+TEXTURE-INDEX-SIZE-EXT+" "+COLOR-INDEX1-EXT+" "+COLOR-INDEX2-EXT+" "+COLOR-INDEX4-EXT+" "+COLOR-INDEX8-EXT+" "+COLOR-INDEX12-EXT+" "+COLOR-INDEX16-EXT+" "+EXT-CLIP-VOLUME-HINT+" "+CLIP-VOLUME-CLIPPING-HINT-EXT+" "+EXT-COMPILED-VERTEX-ARRAY+" "+ARRAY-ELEMENT-LOCK-FIRST-EXT+" "+ARRAY-ELEMENT-LOCK-COUNT-EXT+" "+HP-OCCLUSION-TEST+" "+OCCLUSION-TEST-HP+" "+OCCLUSION-TEST-RESULT-HP+" "+EXT-SHARED-TEXTURE-PALETTE+" "+SHARED-TEXTURE-PALETTE-EXT+" "+EXT-STENCIL-WRAP+" "+INCR-WRAP-EXT+" "+DECR-WRAP-EXT+" "+NV-TEXGEN-REFLECTION+" "+NORMAL-MAP-NV+" "+REFLECTION-MAP-NV+" "+EXT-TEXTURE-ENV-ADD+" "+MESA-WINDOW-POS+" "+MESA-RESIZE-BUFFERS+" )) (in-package :gl) ;;; Opcodes. (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +get-string+ 129) (defconstant +new-list+ 101) (defconstant +end-list+ 102) (defconstant +gen-lists+ 104) (defconstant +finish+ 108) (defconstant +disable+ 138) (defconstant +enable+ 139) (defconstant +flush+ 142) ;;; Constants. ;;; Shamelessly taken from CL-SDL. ;; Boolean (defconstant +false+ #x0) (defconstant +true+ #x1) ;; Types (defconstant +byte+ #x1400) (defconstant +unsigned-byte+ #x1401) (defconstant +short+ #x1402) (defconstant +unsigned-short+ #x1403) (defconstant +int+ #x1404) (defconstant +unsigned-int+ #x1405) (defconstant +float+ #x1406) (defconstant +double+ #x140a) (defconstant +2-bytes+ #x1407) (defconstant +3-bytes+ #x1408) (defconstant +4-bytes+ #x1409) ;; Primitives (defconstant +points+ #x0000) (defconstant +lines+ #x0001) (defconstant +line-loop+ #x0002) (defconstant +line-strip+ #x0003) (defconstant +triangles+ #x0004) (defconstant +triangle-strip+ #x0005) (defconstant +triangle-fan+ #x0006) (defconstant +quads+ #x0007) (defconstant +quad-strip+ #x0008) (defconstant +polygon+ #x0009) ;; Arrays (defconstant +vertex-array+ #x8074) (defconstant +normal-array+ #x8075) (defconstant +color-array+ #x8076) (defconstant +index-array+ #x8077) (defconstant +texture-coord-array+ #x8078) (defconstant +edge-flag-array+ #x8079) (defconstant +vertex-array-size+ #x807a) (defconstant +vertex-array-type+ #x807b) (defconstant +vertex-array-stride+ #x807c) (defconstant +normal-array-type+ #x807e) (defconstant +normal-array-stride+ #x807f) (defconstant +color-array-size+ #x8081) (defconstant +color-array-type+ #x8082) (defconstant +color-array-stride+ #x8083) (defconstant +index-array-type+ #x8085) (defconstant +index-array-stride+ #x8086) (defconstant +texture-coord-array-size+ #x8088) (defconstant +texture-coord-array-type+ #x8089) (defconstant +texture-coord-array-stride+ #x808a) (defconstant +edge-flag-array-stride+ #x808c) (defconstant +vertex-array-pointer+ #x808e) (defconstant +normal-array-pointer+ #x808f) (defconstant +color-array-pointer+ #x8090) (defconstant +index-array-pointer+ #x8091) (defconstant +texture-coord-array-pointer+ #x8092) (defconstant +edge-flag-array-pointer+ #x8093) ;; Array formats (defconstant +v2f+ #x2a20) (defconstant +v3f+ #x2a21) (defconstant +c4ub-v2f+ #x2a22) (defconstant +c4ub-v3f+ #x2a23) (defconstant +c3f-v3f+ #x2a24) (defconstant +n3f-v3f+ #x2a25) (defconstant +c4f-n3f-v3f+ #x2a26) (defconstant +t2f-v3f+ #x2a27) (defconstant +t4f-v4f+ #x2a28) (defconstant +t2f-c4ub-v3f+ #x2a29) (defconstant +t2f-c3f-v3f+ #x2a2a) (defconstant +t2f-n3f-v3f+ #x2a2b) (defconstant +t2f-c4f-n3f-v3f+ #x2a2c) (defconstant +t4f-c4f-n3f-v4f+ #x2a2d) ;; Matrices (defconstant +matrix-mode+ #x0ba0) (defconstant +modelview+ #x1700) (defconstant +projection+ #x1701) (defconstant +texture+ #x1702) ;; Points (defconstant +point-smooth+ #x0b10) (defconstant +point-size+ #x0b11) (defconstant +point-size-granularity+ #x0b13) (defconstant +point-size-range+ #x0b12) ;; Lines (defconstant +line-smooth+ #x0b20) (defconstant +line-stipple+ #x0b24) (defconstant +line-stipple-pattern+ #x0b25) (defconstant +line-stipple-repeat+ #x0b26) (defconstant +line-width+ #x0b21) (defconstant +line-width-granularity+ #x0b23) (defconstant +line-width-range+ #x0b22) ;; Polygons (defconstant +point+ #x1b00) (defconstant +line+ #x1b01) (defconstant +fill+ #x1b02) (defconstant +cw+ #x0900) (defconstant +ccw+ #x0901) (defconstant +front+ #x0404) (defconstant +back+ #x0405) (defconstant +polygon-mode+ #x0b40) (defconstant +polygon-smooth+ #x0b41) (defconstant +polygon-stipple+ #x0b42) (defconstant +edge-flag+ #x0b43) (defconstant +cull-face+ #x0b44) (defconstant +cull-face-mode+ #x0b45) (defconstant +front-face+ #x0b46) (defconstant +polygon-offset-factor+ #x8038) (defconstant +polygon-offset-units+ #x2a00) (defconstant +polygon-offset-point+ #x2a01) (defconstant +polygon-offset-line+ #x2a02) (defconstant +polygon-offset-fill+ #x8037) ;; Display Lists (defconstant +compile+ #x1300) (defconstant +compile-and-execute+ #x1301) (defconstant +list-base+ #x0b32) (defconstant +list-index+ #x0b33) (defconstant +list-mode+ #x0b30) ;; Depth Buffer (defconstant +never+ #x0200) (defconstant +less+ #x0201) (defconstant +equal+ #x0202) (defconstant +lequal+ #x0203) (defconstant +greater+ #x0204) (defconstant +notequal+ #x0205) (defconstant +gequal+ #x0206) (defconstant +always+ #x0207) (defconstant +depth-test+ #x0b71) (defconstant +depth-bits+ #x0d56) (defconstant +depth-clear-value+ #x0b73) (defconstant +depth-func+ #x0b74) (defconstant +depth-range+ #x0b70) (defconstant +depth-writemask+ #x0b72) (defconstant +depth-component+ #x1902) ;; Lighting (defconstant +lighting+ #x0b50) (defconstant +light0+ #x4000) (defconstant +light1+ #x4001) (defconstant +light2+ #x4002) (defconstant +light3+ #x4003) (defconstant +light4+ #x4004) (defconstant +light5+ #x4005) (defconstant +light6+ #x4006) (defconstant +light7+ #x4007) (defconstant +spot-exponent+ #x1205) (defconstant +spot-cutoff+ #x1206) (defconstant +constant-attenuation+ #x1207) (defconstant +linear-attenuation+ #x1208) (defconstant +quadratic-attenuation+ #x1209) (defconstant +ambient+ #x1200) (defconstant +diffuse+ #x1201) (defconstant +specular+ #x1202) (defconstant +shininess+ #x1601) (defconstant +emission+ #x1600) (defconstant +position+ #x1203) (defconstant +spot-direction+ #x1204) (defconstant +ambient-and-diffuse+ #x1602) (defconstant +color-indexes+ #x1603) (defconstant +light-model-two-side+ #x0b52) (defconstant +light-model-local-viewer+ #x0b51) (defconstant +light-model-ambient+ #x0b53) (defconstant +front-and-back+ #x0408) (defconstant +shade-model+ #x0b54) (defconstant +flat+ #x1d00) (defconstant +smooth+ #x1d01) (defconstant +color-material+ #x0b57) (defconstant +color-material-face+ #x0b55) (defconstant +color-material-parameter+ #x0b56) (defconstant +normalize+ #x0ba1) ;; Clipping planes (defconstant +clip-plane0+ #x3000) (defconstant +clip-plane1+ #x3001) (defconstant +clip-plane2+ #x3002) (defconstant +clip-plane3+ #x3003) (defconstant +clip-plane4+ #x3004) (defconstant +clip-plane5+ #x3005) ;; Accumulation buffer (defconstant +accum-red-bits+ #x0d58) (defconstant +accum-green-bits+ #x0d59) (defconstant +accum-blue-bits+ #x0d5a) (defconstant +accum-alpha-bits+ #x0d5b) (defconstant +accum-clear-value+ #x0b80) (defconstant +accum+ #x0100) (defconstant +add+ #x0104) (defconstant +load+ #x0101) (defconstant +mult+ #x0103) (defconstant +return+ #x0102) ;; Alpha Testing (defconstant +alpha-test+ #x0bc0) (defconstant +alpha-test-ref+ #x0bc2) (defconstant +alpha-test-func+ #x0bc1) ;; Blending (defconstant +blend+ #x0be2) (defconstant +blend-src+ #x0be1) (defconstant +blend-dst+ #x0be0) (defconstant +zero+ #x0) (defconstant +one+ #x1) (defconstant +src-color+ #x0300) (defconstant +one-minus-src-color+ #x0301) (defconstant +dst-color+ #x0306) (defconstant +one-minus-dst-color+ #x0307) (defconstant +src-alpha+ #x0302) (defconstant +one-minus-src-alpha+ #x0303) (defconstant +dst-alpha+ #x0304) (defconstant +one-minus-dst-alpha+ #x0305) (defconstant +src-alpha-saturate+ #x0308) (defconstant +constant-color+ #x8001) (defconstant +one-minus-constant-color+ #x8002) (defconstant +constant-alpha+ #x8003) (defconstant +one-minus-constant-alpha+ #x8004) ;; Render mode (defconstant +feedback+ #x1c01) (defconstant +render+ #x1c00) (defconstant +select+ #x1c02) ;; Feedback (defconstant +2d+ #x0600) (defconstant +3d+ #x0601) (defconstant +3d-color+ #x0602) (defconstant +3d-color-texture+ #x0603) (defconstant +4d-color-texture+ #x0604) (defconstant +point-token+ #x0701) (defconstant +line-token+ #x0702) (defconstant +line-reset-token+ #x0707) (defconstant +polygon-token+ #x0703) (defconstant +bitmap-token+ #x0704) (defconstant +draw-pixel-token+ #x0705) (defconstant +copy-pixel-token+ #x0706) (defconstant +pass-through-token+ #x0700) (defconstant +feedback-buffer-pointer+ #x0df0) (defconstant +feedback-buffer-size+ #x0df1) (defconstant +feedback-buffer-type+ #x0df2) ;; Selection (defconstant +selection-buffer-pointer+ #x0df3) (defconstant +selection-buffer-size+ #x0df4) ;; Fog (defconstant +fog+ #x0b60) (defconstant +fog-mode+ #x0b65) (defconstant +fog-density+ #x0b62) (defconstant +fog-color+ #x0b66) (defconstant +fog-index+ #x0b61) (defconstant +fog-start+ #x0b63) (defconstant +fog-end+ #x0b64) (defconstant +linear+ #x2601) (defconstant +exp+ #x0800) (defconstant +exp2+ #x0801) ;; Logic operations (defconstant +logic-op+ #x0bf1) (defconstant +index-logic-op+ #x0bf1) (defconstant +color-logic-op+ #x0bf2) (defconstant +logic-op-mode+ #x0bf0) (defconstant +clear+ #x1500) (defconstant +set+ #x150f) (defconstant +copy+ #x1503) (defconstant +copy-inverted+ #x150c) (defconstant +noop+ #x1505) (defconstant +invert+ #x150a) (defconstant +and+ #x1501) (defconstant +nand+ #x150e) (defconstant +or+ #x1507) (defconstant +nor+ #x1508) (defconstant +xor+ #x1506) (defconstant +equiv+ #x1509) (defconstant +and-reverse+ #x1502) (defconstant +and-inverted+ #x1504) (defconstant +or-reverse+ #x150b) (defconstant +or-inverted+ #x150d) ;; Stencil (defconstant +stencil-test+ #x0b90) (defconstant +stencil-writemask+ #x0b98) (defconstant +stencil-bits+ #x0d57) (defconstant +stencil-func+ #x0b92) (defconstant +stencil-value-mask+ #x0b93) (defconstant +stencil-ref+ #x0b97) (defconstant +stencil-fail+ #x0b94) (defconstant +stencil-pass-depth-pass+ #x0b96) (defconstant +stencil-pass-depth-fail+ #x0b95) (defconstant +stencil-clear-value+ #x0b91) (defconstant +stencil-index+ #x1901) (defconstant +keep+ #x1e00) (defconstant +replace+ #x1e01) (defconstant +incr+ #x1e02) (defconstant +decr+ #x1e03) ;; Buffers, Pixel Drawing/Reading (defconstant +none+ #x0) (defconstant +left+ #x0406) (defconstant +right+ #x0407) (defconstant +front-left+ #x0400) (defconstant +front-right+ #x0401) (defconstant +back-left+ #x0402) (defconstant +back-right+ #x0403) (defconstant +aux0+ #x0409) (defconstant +aux1+ #x040a) (defconstant +aux2+ #x040b) (defconstant +aux3+ #x040c) (defconstant +color-index+ #x1900) (defconstant +red+ #x1903) (defconstant +green+ #x1904) (defconstant +blue+ #x1905) (defconstant +alpha+ #x1906) (defconstant +luminance+ #x1909) (defconstant +luminance-alpha+ #x190a) (defconstant +alpha-bits+ #x0d55) (defconstant +red-bits+ #x0d52) (defconstant +green-bits+ #x0d53) (defconstant +blue-bits+ #x0d54) (defconstant +index-bits+ #x0d51) (defconstant +subpixel-bits+ #x0d50) (defconstant +aux-buffers+ #x0c00) (defconstant +read-buffer+ #x0c02) (defconstant +draw-buffer+ #x0c01) (defconstant +doublebuffer+ #x0c32) (defconstant +stereo+ #x0c33) (defconstant +bitmap+ #x1a00) (defconstant +color+ #x1800) (defconstant +depth+ #x1801) (defconstant +stencil+ #x1802) (defconstant +dither+ #x0bd0) (defconstant +rgb+ #x1907) (defconstant +rgba+ #x1908) ;; Implementation Limits (defconstant +max-list-nesting+ #x0b31) (defconstant +max-attrib-stack-depth+ #x0d35) (defconstant +max-modelview-stack-depth+ #x0d36) (defconstant +max-name-stack-depth+ #x0d37) (defconstant +max-projection-stack-depth+ #x0d38) (defconstant +max-texture-stack-depth+ #x0d39) (defconstant +max-eval-order+ #x0d30) (defconstant +max-lights+ #x0d31) (defconstant +max-clip-planes+ #x0d32) (defconstant +max-texture-size+ #x0d33) (defconstant +max-pixel-map-table+ #x0d34) (defconstant +max-viewport-dims+ #x0d3a) (defconstant +max-client-attrib-stack-depth+ #x0d3b) ;; Gets (defconstant +attrib-stack-depth+ #x0bb0) (defconstant +client-attrib-stack-depth+ #x0bb1) (defconstant +color-clear-value+ #x0c22) (defconstant +color-writemask+ #x0c23) (defconstant +current-index+ #x0b01) (defconstant +current-color+ #x0b00) (defconstant +current-normal+ #x0b02) (defconstant +current-raster-color+ #x0b04) (defconstant +current-raster-distance+ #x0b09) (defconstant +current-raster-index+ #x0b05) (defconstant +current-raster-position+ #x0b07) (defconstant +current-raster-texture-coords+ #x0b06) (defconstant +current-raster-position-valid+ #x0b08) (defconstant +current-texture-coords+ #x0b03) (defconstant +index-clear-value+ #x0c20) (defconstant +index-mode+ #x0c30) (defconstant +index-writemask+ #x0c21) (defconstant +modelview-matrix+ #x0ba6) (defconstant +modelview-stack-depth+ #x0ba3) (defconstant +name-stack-depth+ #x0d70) (defconstant +projection-matrix+ #x0ba7) (defconstant +projection-stack-depth+ #x0ba4) (defconstant +render-mode+ #x0c40) (defconstant +rgba-mode+ #x0c31) (defconstant +texture-matrix+ #x0ba8) (defconstant +texture-stack-depth+ #x0ba5) (defconstant +viewport+ #x0ba2) ;; GL Evaluators (defconstant +auto-normal+ #x0d80) (defconstant +map1-color-4+ #x0d90) (defconstant +map1-grid-domain+ #x0dd0) (defconstant +map1-grid-segments+ #x0dd1) (defconstant +map1-index+ #x0d91) (defconstant +map1-normal+ #x0d92) (defconstant +map1-texture-coord-1+ #x0d93) (defconstant +map1-texture-coord-2+ #x0d94) (defconstant +map1-texture-coord-3+ #x0d95) (defconstant +map1-texture-coord-4+ #x0d96) (defconstant +map1-vertex-3+ #x0d97) (defconstant +map1-vertex-4+ #x0d98) (defconstant +map2-color-4+ #x0db0) (defconstant +map2-grid-domain+ #x0dd2) (defconstant +map2-grid-segments+ #x0dd3) (defconstant +map2-index+ #x0db1) (defconstant +map2-normal+ #x0db2) (defconstant +map2-texture-coord-1+ #x0db3) (defconstant +map2-texture-coord-2+ #x0db4) (defconstant +map2-texture-coord-3+ #x0db5) (defconstant +map2-texture-coord-4+ #x0db6) (defconstant +map2-vertex-3+ #x0db7) (defconstant +map2-vertex-4+ #x0db8) (defconstant +coeff+ #x0a00) (defconstant +domain+ #x0a02) (defconstant +order+ #x0a01) ;; Hints (defconstant +fog-hint+ #x0c54) (defconstant +line-smooth-hint+ #x0c52) (defconstant +perspective-correction-hint+ #x0c50) (defconstant +point-smooth-hint+ #x0c51) (defconstant +polygon-smooth-hint+ #x0c53) (defconstant +dont-care+ #x1100) (defconstant +fastest+ #x1101) (defconstant +nicest+ #x1102) ;; Scissor box (defconstant +scissor-test+ #x0c11) (defconstant +scissor-box+ #x0c10) ;; Pixel Mode / Transfer (defconstant +map-color+ #x0d10) (defconstant +map-stencil+ #x0d11) (defconstant +index-shift+ #x0d12) (defconstant +index-offset+ #x0d13) (defconstant +red-scale+ #x0d14) (defconstant +red-bias+ #x0d15) (defconstant +green-scale+ #x0d18) (defconstant +green-bias+ #x0d19) (defconstant +blue-scale+ #x0d1a) (defconstant +blue-bias+ #x0d1b) (defconstant +alpha-scale+ #x0d1c) (defconstant +alpha-bias+ #x0d1d) (defconstant +depth-scale+ #x0d1e) (defconstant +depth-bias+ #x0d1f) (defconstant +pixel-map-s-to-s-size+ #x0cb1) (defconstant +pixel-map-i-to-i-size+ #x0cb0) (defconstant +pixel-map-i-to-r-size+ #x0cb2) (defconstant +pixel-map-i-to-g-size+ #x0cb3) (defconstant +pixel-map-i-to-b-size+ #x0cb4) (defconstant +pixel-map-i-to-a-size+ #x0cb5) (defconstant +pixel-map-r-to-r-size+ #x0cb6) (defconstant +pixel-map-g-to-g-size+ #x0cb7) (defconstant +pixel-map-b-to-b-size+ #x0cb8) (defconstant +pixel-map-a-to-a-size+ #x0cb9) (defconstant +pixel-map-s-to-s+ #x0c71) (defconstant +pixel-map-i-to-i+ #x0c70) (defconstant +pixel-map-i-to-r+ #x0c72) (defconstant +pixel-map-i-to-g+ #x0c73) (defconstant +pixel-map-i-to-b+ #x0c74) (defconstant +pixel-map-i-to-a+ #x0c75) (defconstant +pixel-map-r-to-r+ #x0c76) (defconstant +pixel-map-g-to-g+ #x0c77) (defconstant +pixel-map-b-to-b+ #x0c78) (defconstant +pixel-map-a-to-a+ #x0c79) (defconstant +pack-alignment+ #x0d05) (defconstant +pack-lsb-first+ #x0d01) (defconstant +pack-row-length+ #x0d02) (defconstant +pack-skip-pixels+ #x0d04) (defconstant +pack-skip-rows+ #x0d03) (defconstant +pack-swap-bytes+ #x0d00) (defconstant +unpack-alignment+ #x0cf5) (defconstant +unpack-lsb-first+ #x0cf1) (defconstant +unpack-row-length+ #x0cf2) (defconstant +unpack-skip-pixels+ #x0cf4) (defconstant +unpack-skip-rows+ #x0cf3) (defconstant +unpack-swap-bytes+ #x0cf0) (defconstant +zoom-x+ #x0d16) (defconstant +zoom-y+ #x0d17) ;; Texture Mapping (defconstant +texture-env+ #x2300) (defconstant +texture-env-mode+ #x2200) (defconstant +texture-1d+ #x0de0) (defconstant +texture-2d+ #x0de1) (defconstant +texture-wrap-s+ #x2802) (defconstant +texture-wrap-t+ #x2803) (defconstant +texture-mag-filter+ #x2800) (defconstant +texture-min-filter+ #x2801) (defconstant +texture-env-color+ #x2201) (defconstant +texture-gen-s+ #x0c60) (defconstant +texture-gen-t+ #x0c61) (defconstant +texture-gen-mode+ #x2500) (defconstant +texture-border-color+ #x1004) (defconstant +texture-width+ #x1000) (defconstant +texture-height+ #x1001) (defconstant +texture-border+ #x1005) (defconstant +texture-components+ #x1003) (defconstant +texture-red-size+ #x805c) (defconstant +texture-green-size+ #x805d) (defconstant +texture-blue-size+ #x805e) (defconstant +texture-alpha-size+ #x805f) (defconstant +texture-luminance-size+ #x8060) (defconstant +texture-intensity-size+ #x8061) (defconstant +nearest-mipmap-nearest+ #x2700) (defconstant +nearest-mipmap-linear+ #x2702) (defconstant +linear-mipmap-nearest+ #x2701) (defconstant +linear-mipmap-linear+ #x2703) (defconstant +object-linear+ #x2401) (defconstant +object-plane+ #x2501) (defconstant +eye-linear+ #x2400) (defconstant +eye-plane+ #x2502) (defconstant +sphere-map+ #x2402) (defconstant +decal+ #x2101) (defconstant +modulate+ #x2100) (defconstant +nearest+ #x2600) (defconstant +repeat+ #x2901) (defconstant +clamp+ #x2900) (defconstant +s+ #x2000) (defconstant +t+ #x2001) (defconstant +r+ #x2002) (defconstant +q+ #x2003) (defconstant +texture-gen-r+ #x0c62) (defconstant +texture-gen-q+ #x0c63) ;; GL 1.1 Texturing (defconstant +proxy-texture-1d+ #x8063) (defconstant +proxy-texture-2d+ #x8064) (defconstant +texture-priority+ #x8066) (defconstant +texture-resident+ #x8067) (defconstant +texture-binding-1d+ #x8068) (defconstant +texture-binding-2d+ #x8069) (defconstant +texture-internal-format+ #x1003) (defconstant +pack-skip-images+ #x806b) (defconstant +pack-image-height+ #x806c) (defconstant +unpack-skip-images+ #x806d) (defconstant +unpack-image-height+ #x806e) (defconstant +texture-3d+ #x806f) (defconstant +proxy-texture-3d+ #x8070) (defconstant +texture-depth+ #x8071) (defconstant +texture-wrap-r+ #x8072) (defconstant +max-3d-texture-size+ #x8073) (defconstant +texture-binding-3d+ #x806a) ;; Internal texture formats (GL 1.1) (defconstant +alpha4+ #x803b) (defconstant +alpha8+ #x803c) (defconstant +alpha12+ #x803d) (defconstant +alpha16+ #x803e) (defconstant +luminance4+ #x803f) (defconstant +luminance8+ #x8040) (defconstant +luminance12+ #x8041) (defconstant +luminance16+ #x8042) (defconstant +luminance4-alpha4+ #x8043) (defconstant +luminance6-alpha2+ #x8044) (defconstant +luminance8-alpha8+ #x8045) (defconstant +luminance12-alpha4+ #x8046) (defconstant +luminance12-alpha12+ #x8047) (defconstant +luminance16-alpha16+ #x8048) (defconstant +intensity+ #x8049) (defconstant +intensity4+ #x804a) (defconstant +intensity8+ #x804b) (defconstant +intensity12+ #x804c) (defconstant +intensity16+ #x804d) (defconstant +r3-g3-b2+ #x2a10) (defconstant +rgb4+ #x804f) (defconstant +rgb5+ #x8050) (defconstant +rgb8+ #x8051) (defconstant +rgb10+ #x8052) (defconstant +rgb12+ #x8053) (defconstant +rgb16+ #x8054) (defconstant +rgba2+ #x8055) (defconstant +rgba4+ #x8056) (defconstant +rgb5-a1+ #x8057) (defconstant +rgba8+ #x8058) (defconstant +rgb10-a2+ #x8059) (defconstant +rgba12+ #x805a) (defconstant +rgba16+ #x805b) ;; Utility (defconstant +vendor+ #x1f00) (defconstant +renderer+ #x1f01) (defconstant +version+ #x1f02) (defconstant +extensions+ #x1f03) ;; Errors (defconstant +no-error+ #x0) (defconstant +invalid-value+ #x0501) (defconstant +invalid-enum+ #x0500) (defconstant +invalid-operation+ #x0502) (defconstant +stack-overflow+ #x0503) (defconstant +stack-underflow+ #x0504) (defconstant +out-of-memory+ #x0505) ;; OpenGL 1.2 (defconstant +rescale-normal+ #x803a) (defconstant +clamp-to-edge+ #x812f) (defconstant +max-elements-vertices+ #x80e8) (defconstant +max-elements-indices+ #x80e9) (defconstant +bgr+ #x80e0) (defconstant +bgra+ #x80e1) (defconstant +unsigned-byte-3-3-2+ #x8032) (defconstant +unsigned-byte-2-3-3-rev+ #x8362) (defconstant +unsigned-short-5-6-5+ #x8363) (defconstant +unsigned-short-5-6-5-rev+ #x8364) (defconstant +unsigned-short-4-4-4-4+ #x8033) (defconstant +unsigned-short-4-4-4-4-rev+ #x8365) (defconstant +unsigned-short-5-5-5-1+ #x8034) (defconstant +unsigned-short-1-5-5-5-rev+ #x8366) (defconstant +unsigned-int-8-8-8-8+ #x8035) (defconstant +unsigned-int-8-8-8-8-rev+ #x8367) (defconstant +unsigned-int-10-10-10-2+ #x8036) (defconstant +unsigned-int-2-10-10-10-rev+ #x8368) (defconstant +light-model-color-control+ #x81f8) (defconstant +single-color+ #x81f9) (defconstant +separate-specular-color+ #x81fa) (defconstant +texture-min-lod+ #x813a) (defconstant +texture-max-lod+ #x813b) (defconstant +texture-base-level+ #x813c) (defconstant +texture-max-level+ #x813d) (defconstant +smooth-point-size-range+ #x0b12) (defconstant +smooth-point-size-granularity+ #x0b13) (defconstant +smooth-line-width-range+ #x0b22) (defconstant +smooth-line-width-granularity+ #x0b23) (defconstant +aliased-point-size-range+ #x846d) (defconstant +aliased-line-width-range+ #x846e) ;; OpenGL 1.2 Imaging subset ;; GL_EXT_color_table (defconstant +color-table+ #x80d0) (defconstant +post-convolution-color-table+ #x80d1) (defconstant +post-color-matrix-color-table+ #x80d2) (defconstant +proxy-color-table+ #x80d3) (defconstant +proxy-post-convolution-color-table+ #x80d4) (defconstant +proxy-post-color-matrix-color-table+ #x80d5) (defconstant +color-table-scale+ #x80d6) (defconstant +color-table-bias+ #x80d7) (defconstant +color-table-format+ #x80d8) (defconstant +color-table-width+ #x80d9) (defconstant +color-table-red-size+ #x80da) (defconstant +color-table-green-size+ #x80db) (defconstant +color-table-blue-size+ #x80dc) (defconstant +color-table-alpha-size+ #x80dd) (defconstant +color-table-luminance-size+ #x80de) (defconstant +color-table-intensity-size+ #x80df) ;; GL_EXT_convolution and GL_HP_convolution (defconstant +convolution-1d+ #x8010) (defconstant +convolution-2d+ #x8011) (defconstant +separable-2d+ #x8012) (defconstant +convolution-border-mode+ #x8013) (defconstant +convolution-filter-scale+ #x8014) (defconstant +convolution-filter-bias+ #x8015) (defconstant +reduce+ #x8016) (defconstant +convolution-format+ #x8017) (defconstant +convolution-width+ #x8018) (defconstant +convolution-height+ #x8019) (defconstant +max-convolution-width+ #x801a) (defconstant +max-convolution-height+ #x801b) (defconstant +post-convolution-red-scale+ #x801c) (defconstant +post-convolution-green-scale+ #x801d) (defconstant +post-convolution-blue-scale+ #x801e) (defconstant +post-convolution-alpha-scale+ #x801f) (defconstant +post-convolution-red-bias+ #x8020) (defconstant +post-convolution-green-bias+ #x8021) (defconstant +post-convolution-blue-bias+ #x8022) (defconstant +post-convolution-alpha-bias+ #x8023) (defconstant +constant-border+ #x8151) (defconstant +replicate-border+ #x8153) (defconstant +convolution-border-color+ #x8154) ;; GL_SGI_color_matrix (defconstant +color-matrix+ #x80b1) (defconstant +color-matrix-stack-depth+ #x80b2) (defconstant +max-color-matrix-stack-depth+ #x80b3) (defconstant +post-color-matrix-red-scale+ #x80b4) (defconstant +post-color-matrix-green-scale+ #x80b5) (defconstant +post-color-matrix-blue-scale+ #x80b6) (defconstant +post-color-matrix-alpha-scale+ #x80b7) (defconstant +post-color-matrix-red-bias+ #x80b8) (defconstant +post-color-matrix-green-bias+ #x80b9) (defconstant +post-color-matrix-blue-bias+ #x80ba) (defconstant +post-color-matrix-alpha-bias+ #x80bb) ;; GL_EXT_histogram (defconstant +histogram+ #x8024) (defconstant +proxy-histogram+ #x8025) (defconstant +histogram-width+ #x8026) (defconstant +histogram-format+ #x8027) (defconstant +histogram-red-size+ #x8028) (defconstant +histogram-green-size+ #x8029) (defconstant +histogram-blue-size+ #x802a) (defconstant +histogram-alpha-size+ #x802b) (defconstant +histogram-luminance-size+ #x802c) (defconstant +histogram-sink+ #x802d) (defconstant +minmax+ #x802e) (defconstant +minmax-format+ #x802f) (defconstant +minmax-sink+ #x8030) (defconstant +table-too-large+ #x8031) ;; GL_EXT_blend_color, GL_EXT_blend_minmax (defconstant +blend-equation+ #x8009) (defconstant +min+ #x8007) (defconstant +max+ #x8008) (defconstant +func-add+ #x8006) (defconstant +func-subtract+ #x800a) (defconstant +func-reverse-subtract+ #x800b) ;; glPush/PopAttrib bits (defconstant +current-bit+ #x00000001) (defconstant +point-bit+ #x00000002) (defconstant +line-bit+ #x00000004) (defconstant +polygon-bit+ #x00000008) (defconstant +polygon-stipple-bit+ #x00000010) (defconstant +pixel-mode-bit+ #x00000020) (defconstant +lighting-bit+ #x00000040) (defconstant +fog-bit+ #x00000080) (defconstant +depth-buffer-bit+ #x00000100) (defconstant +accum-buffer-bit+ #x00000200) (defconstant +stencil-buffer-bit+ #x00000400) (defconstant +viewport-bit+ #x00000800) (defconstant +transform-bit+ #x00001000) (defconstant +enable-bit+ #x00002000) (defconstant +color-buffer-bit+ #x00004000) (defconstant +hint-bit+ #x00008000) (defconstant +eval-bit+ #x00010000) (defconstant +list-bit+ #x00020000) (defconstant +texture-bit+ #x00040000) (defconstant +scissor-bit+ #x00080000) (defconstant +all-attrib-bits+ #x000fffff) (defconstant +client-pixel-store-bit+ #x00000001) (defconstant +client-vertex-array-bit+ #x00000002) (defconstant +client-all-attrib-bits+ #xffffffff) ;; ARB Multitexturing extension (defconstant +arb-multitexture+ 1) (defconstant +texture0-arb+ #x84c0) (defconstant +texture1-arb+ #x84c1) (defconstant +texture2-arb+ #x84c2) (defconstant +texture3-arb+ #x84c3) (defconstant +texture4-arb+ #x84c4) (defconstant +texture5-arb+ #x84c5) (defconstant +texture6-arb+ #x84c6) (defconstant +texture7-arb+ #x84c7) (defconstant +texture8-arb+ #x84c8) (defconstant +texture9-arb+ #x84c9) (defconstant +texture10-arb+ #x84ca) (defconstant +texture11-arb+ #x84cb) (defconstant +texture12-arb+ #x84cc) (defconstant +texture13-arb+ #x84cd) (defconstant +texture14-arb+ #x84ce) (defconstant +texture15-arb+ #x84cf) (defconstant +texture16-arb+ #x84d0) (defconstant +texture17-arb+ #x84d1) (defconstant +texture18-arb+ #x84d2) (defconstant +texture19-arb+ #x84d3) (defconstant +texture20-arb+ #x84d4) (defconstant +texture21-arb+ #x84d5) (defconstant +texture22-arb+ #x84d6) (defconstant +texture23-arb+ #x84d7) (defconstant +texture24-arb+ #x84d8) (defconstant +texture25-arb+ #x84d9) (defconstant +texture26-arb+ #x84da) (defconstant +texture27-arb+ #x84db) (defconstant +texture28-arb+ #x84dc) (defconstant +texture29-arb+ #x84dd) (defconstant +texture30-arb+ #x84de) (defconstant +texture31-arb+ #x84df) (defconstant +active-texture-arb+ #x84e0) (defconstant +client-active-texture-arb+ #x84e1) (defconstant +max-texture-units-arb+ #x84e2) ;;; Misc extensions (defconstant +ext-abgr+ 1) (defconstant +abgr-ext+ #x8000) (defconstant +ext-blend-color+ 1) (defconstant +constant-color-ext+ #x8001) (defconstant +one-minus-constant-color-ext+ #x8002) (defconstant +constant-alpha-ext+ #x8003) (defconstant +one-minus-constant-alpha-ext+ #x8004) (defconstant +blend-color-ext+ #x8005) (defconstant +ext-polygon-offset+ 1) (defconstant +polygon-offset-ext+ #x8037) (defconstant +polygon-offset-factor-ext+ #x8038) (defconstant +polygon-offset-bias-ext+ #x8039) (defconstant +ext-texture3d+ 1) (defconstant +pack-skip-images-ext+ #x806b) (defconstant +pack-image-height-ext+ #x806c) (defconstant +unpack-skip-images-ext+ #x806d) (defconstant +unpack-image-height-ext+ #x806e) (defconstant +texture-3d-ext+ #x806f) (defconstant +proxy-texture-3d-ext+ #x8070) (defconstant +texture-depth-ext+ #x8071) (defconstant +texture-wrap-r-ext+ #x8072) (defconstant +max-3d-texture-size-ext+ #x8073) (defconstant +texture-3d-binding-ext+ #x806a) (defconstant +ext-texture-object+ 1) (defconstant +texture-priority-ext+ #x8066) (defconstant +texture-resident-ext+ #x8067) (defconstant +texture-1d-binding-ext+ #x8068) (defconstant +texture-2d-binding-ext+ #x8069) (defconstant +ext-rescale-normal+ 1) (defconstant +rescale-normal-ext+ #x803a) (defconstant +ext-vertex-array+ 1) (defconstant +vertex-array-ext+ #x8074) (defconstant +normal-array-ext+ #x8075) (defconstant +color-array-ext+ #x8076) (defconstant +index-array-ext+ #x8077) (defconstant +texture-coord-array-ext+ #x8078) (defconstant +edge-flag-array-ext+ #x8079) (defconstant +vertex-array-size-ext+ #x807a) (defconstant +vertex-array-type-ext+ #x807b) (defconstant +vertex-array-stride-ext+ #x807c) (defconstant +vertex-array-count-ext+ #x807d) (defconstant +normal-array-type-ext+ #x807e) (defconstant +normal-array-stride-ext+ #x807f) (defconstant +normal-array-count-ext+ #x8080) (defconstant +color-array-size-ext+ #x8081) (defconstant +color-array-type-ext+ #x8082) (defconstant +color-array-stride-ext+ #x8083) (defconstant +color-array-count-ext+ #x8084) (defconstant +index-array-type-ext+ #x8085) (defconstant +index-array-stride-ext+ #x8086) (defconstant +index-array-count-ext+ #x8087) (defconstant +texture-coord-array-size-ext+ #x8088) (defconstant +texture-coord-array-type-ext+ #x8089) (defconstant +texture-coord-array-stride-ext+ #x808a) (defconstant +texture-coord-array-count-ext+ #x808b) (defconstant +edge-flag-array-stride-ext+ #x808c) (defconstant +edge-flag-array-count-ext+ #x808d) (defconstant +vertex-array-pointer-ext+ #x808e) (defconstant +normal-array-pointer-ext+ #x808f) (defconstant +color-array-pointer-ext+ #x8090) (defconstant +index-array-pointer-ext+ #x8091) (defconstant +texture-coord-array-pointer-ext+ #x8092) (defconstant +edge-flag-array-pointer-ext+ #x8093) (defconstant +sgis-texture-edge-clamp+ 1) (defconstant +clamp-to-edge-sgis+ #x812f) (defconstant +ext-blend-minmax+ 1) (defconstant +func-add-ext+ #x8006) (defconstant +min-ext+ #x8007) (defconstant +max-ext+ #x8008) (defconstant +blend-equation-ext+ #x8009) (defconstant +ext-blend-subtract+ 1) (defconstant +func-subtract-ext+ #x800a) (defconstant +func-reverse-subtract-ext+ #x800b) (defconstant +ext-blend-logic-op+ 1) (defconstant +ext-point-parameters+ 1) (defconstant +point-size-min-ext+ #x8126) (defconstant +point-size-max-ext+ #x8127) (defconstant +point-fade-threshold-size-ext+ #x8128) (defconstant +distance-attenuation-ext+ #x8129) (defconstant +ext-paletted-texture+ 1) (defconstant +table-too-large-ext+ #x8031) (defconstant +color-table-format-ext+ #x80d8) (defconstant +color-table-width-ext+ #x80d9) (defconstant +color-table-red-size-ext+ #x80da) (defconstant +color-table-green-size-ext+ #x80db) (defconstant +color-table-blue-size-ext+ #x80dc) (defconstant +color-table-alpha-size-ext+ #x80dd) (defconstant +color-table-luminance-size-ext+ #x80de) (defconstant +color-table-intensity-size-ext+ #x80df) (defconstant +texture-index-size-ext+ #x80ed) (defconstant +color-index1-ext+ #x80e2) (defconstant +color-index2-ext+ #x80e3) (defconstant +color-index4-ext+ #x80e4) (defconstant +color-index8-ext+ #x80e5) (defconstant +color-index12-ext+ #x80e6) (defconstant +color-index16-ext+ #x80e7) (defconstant +ext-clip-volume-hint+ 1) (defconstant +clip-volume-clipping-hint-ext+ #x80f0) (defconstant +ext-compiled-vertex-array+ 1) (defconstant +array-element-lock-first-ext+ #x81a8) (defconstant +array-element-lock-count-ext+ #x81a9) (defconstant +hp-occlusion-test+ 1) (defconstant +occlusion-test-hp+ #x8165) (defconstant +occlusion-test-result-hp+ #x8166) (defconstant +ext-shared-texture-palette+ 1) (defconstant +shared-texture-palette-ext+ #x81fb) (defconstant +ext-stencil-wrap+ 1) (defconstant +incr-wrap-ext+ #x8507) (defconstant +decr-wrap-ext+ #x8508) (defconstant +nv-texgen-reflection+ 1) (defconstant +normal-map-nv+ #x8511) (defconstant +reflection-map-nv+ #x8512) (defconstant +ext-texture-env-add+ 1) (defconstant +mesa-window-pos+ 1) (defconstant +mesa-resize-buffers+ 1) ) ;;; Utility stuff (deftype bool () 'card8) (deftype float32 () 'single-float) (deftype float64 () 'double-float) (declaim (inline aset-float32 aset-float64)) #+sbcl (defun aset-float32 (value array index) (declare (type single-float value) (type buffer-bytes array) (type array-index index)) #.(declare-buffun) (let ((bits (sb-kernel:single-float-bits value))) (declare (type (unsigned-byte 32) bits)) (aset-card32 bits array index)) value) #+cmu (defun aset-float32 (value array index) (declare (type single-float value) (type buffer-bytes array) (type array-index index)) #.(declare-buffun) (let ((bits (kernel:single-float-bits value))) (declare (type (unsigned-byte 32) bits)) (aset-card32 bits array index)) value) #+openmcl (defun aset-float32 (value array index) (declare (type single-float value) (type buffer-bytes array) (type array-index index)) #.(declare-buffun) (let ((bits (ccl::single-float-bits value))) (declare (type (unsigned-byte 32) bits)) (aset-card32 bits array index)) value) #+lispworks (progn (defun %single-float-bits (x) (declare (type single-float x)) (fli:with-dynamic-foreign-objects ((bits :int32)) (fli:with-coerced-pointer (pointer :type :lisp-single-float) bits (setf (fli:dereference pointer) x)) (fli:dereference bits))) (declaim (notinline aset-float32)) (defun aset-float32 (value array index) (declare (type (or short-float single-float) value) (type buffer-bytes array) (type array-index index)) #.(declare-buffun) (let ((bits (%single-float-bits (coerce value 'single-float)))) (declare (type (unsigned-byte 32) bits)) (aset-card32 bits array index)) value)) #+sbcl (defun aset-float64 (value array index) (declare (type double-float value) (type buffer-bytes array) (type array-index index)) #.(declare-buffun) (let ((low (sb-kernel:double-float-low-bits value)) (high (sb-kernel:double-float-high-bits value))) (declare (type (unsigned-byte 32) low high)) (aset-card32 low array index) (aset-card32 high array (the array-index (+ index 4)))) value) #+cmu (defun aset-float64 (value array index) (declare (type double-float value) (type buffer-bytes array) (type array-index index)) #.(declare-buffun) (let ((low (kernel:double-float-low-bits value)) (high (kernel:double-float-high-bits value))) (declare (type (unsigned-byte 32) low high)) (aset-card32 low array index) (aset-card32 high array (+ index 4))) value) #+openmcl (defun aset-float64 (value array index) (declare (type double-float value) (type buffer-bytes array) (type array-index index)) #.(declare-buffun) (multiple-value-bind (low high) (ccl::double-float-bits value) (declare (type (unsigned-byte 32) low high)) (aset-card32 low array index) (aset-card32 high array (the array-index (+ index 4)))) value) #+lispworks (progn (fli:define-c-struct %uint64 (high :uint32) (low :uint32)) (defun %double-float-bits (x) (declare (type double-float x)) (fli:with-dynamic-foreign-objects ((bits %uint64)) (fli:with-coerced-pointer (pointer :type :lisp-double-float) bits (setf (fli:dereference pointer) x)) (values (fli:foreign-slot-value bits 'low :type :uint32 :object-type '%uint64) (fli:foreign-slot-value bits 'high :type :uint32 :object-type '%uint64)))) (declaim (notinline aset-float64)) (defun aset-float64 (value array index) (declare (type double-float value) (type buffer-bytes array) (type array-index index)) #.(declare-buffun) (multiple-value-bind (low high) (%double-float-bits value) (declare (type (unsigned-byte 32) low high)) (aset-card32 low array index) (aset-card32 high array (the array-index (+ index 4)))) value)) (eval-when (:compile-toplevel :load-toplevel :execute) (defun byte-width (type) (ecase type ((int8 card8 bool) 1) ((int16 card16) 2) ((int32 card32 float32) 4) ((float64) 8))) (defun setter (type) (ecase type (int8 'aset-int8) (int16 'aset-int16) (int32 'aset-int32) (bool 'aset-card8) (card8 'aset-card8) (card16 'aset-card16) (card32 'aset-card32) (float32 'aset-float32) (float64 'aset-float64))) (defun sequence-setter (type) (ecase type (int8 'sset-int8) (int16 'sset-int16) (int32 'sset-int32) (bool 'sset-card8) (card8 'sset-card8) (card16 'sset-card16) (card32 'sset-card32) (float32 'sset-float32) (float64 'sset-float64))) (defmacro define-sequence-setter (type) `(defun ,(intern (format nil "~A-~A" 'sset type)) (seq buffer start length) (declare (type sequence seq) (type buffer-bytes buffer) (type array-index start) (type fixnum length)) #.(declare-buffun) (assert (= length (length seq)) (length seq) "SEQUENCE length should be ~D, not ~D." length (length seq)) (typecase seq (list (let ((offset 0)) (declare (type fixnum offset)) (dolist (n seq) (declare (type ,type n)) (,(setter type) n buffer (the array-index (+ start offset))) (incf offset ,(byte-width type))))) ((simple-array ,type) (dotimes (i ,(byte-width type)) (,(setter type) (aref seq i) buffer (the array-index (+ start (* i ,(byte-width type))))))) (vector (dotimes (i ,(byte-width type)) (,(setter type) (svref seq i) buffer (the array-index (+ start (* i ,(byte-width type)))))))))) (define-sequence-setter int8) (define-sequence-setter int16) (define-sequence-setter int32) (define-sequence-setter bool) (define-sequence-setter card8) (define-sequence-setter card16) (define-sequence-setter card32) (define-sequence-setter float32) (define-sequence-setter float64) (defun make-argspecs (list) (destructuring-bind (name type) list (etypecase type (symbol `(,name ,type 1 nil)) (list `(,name ,(second type) ,(third type) ,(if (consp (third type)) (make-symbol (format nil "~A-~A" name 'length)) nil)))))) (defun byte-width-calculation (argspecs) (let ((constant 0) (calculated ())) (loop for (name type length length-var) in argspecs do (let ((byte-width (byte-width type))) (typecase length (number (incf constant (* byte-width length))) (symbol (push `(* ,byte-width ,length) calculated)) (cons (push `(* ,byte-width ,length-var) calculated))))) (if (null calculated) constant (list* '+ constant calculated)))) (defun composite-args (argspecs) (loop for (name type length length-var) in argspecs when (consp length) collect (list length-var length))) (defun make-setter-forms (argspecs) (loop for (name type length length-var) in argspecs collecting `(progn ,(if (and (numberp length) (= 1 length)) `(,(setter type) ,name .rbuf. .index.) `(,(sequence-setter type) ,name .rbuf. .index. ,(if length-var length-var length))) (setf .index. (the array-index (+ .index. (the fixnum (* ,(byte-width type) ,(if length-var length-var length))))))))) (defmacro define-rendering-command (name opcode &rest args) ;; FIXME: Must heavily type-annotate. (labels ((expand-args (list) (loop for (arg type) in list if (consp arg) append (loop for name in arg collecting (list name type)) else collect (list arg type)))) (let* ((args (expand-args args)) (argspecs (mapcar 'make-argspecs args)) (total-byte-width (byte-width-calculation argspecs)) (composite-args (composite-args argspecs))) `(defun ,name ,(mapcar #'first argspecs) (declare ,@(mapcar #'(lambda (list) (if (symbolp (second list)) (list* 'type (reverse list)) `(type sequence ,(first list)))) args)) #.(declare-buffun) (assert (context-p *current-context*) (*current-context*) "*CURRENT-CONTEXT* is not set (~S)." *current-context*) (let* ((.ctx. *current-context*) (.index0. (context-index .ctx.)) (.index. (+ .index0. 4)) (.rbuf. (context-rbuf .ctx.)) ,@composite-args (.length. (+ 4 (* 4 (ceiling ,total-byte-width 4))))) (declare (type context .ctx.) (type array-index .index. .index0.) (type buffer-bytes .rbuf.) ,@(mapcar #'(lambda (list) `(type fixnum ,(first list))) composite-args) (type fixnum .length.)) (when (< (- (length .rbuf.) 8) (+ .index. .length.)) (error "Rendering command sequence too long. Implement automatic buffer flushing.")) (aset-card16 .length. .rbuf. (the array-index .index0.)) (aset-card16 ,opcode .rbuf. (the array-index (+ .index0. 2))) ,@(make-setter-forms argspecs) (setf (context-index .ctx.) (the array-index (+ .index0. .length.)))))))) ) ;; eval-when ;;; Command implementation. (defun get-string (name) (assert (context-p *current-context*) (*current-context*) "*CURRENT-CONTEXT* is not set (~S)." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +get-string+) ;; *** This is CONTEXT-TAG (card32 (context-tag ctx)) ;; *** This is ENUM. (card32 name)) (let* ((length (card32-get 12)) (bytes (sequence-get :format card8 :result-type '(simple-array card8 (*)) :index 32 :length length))) (declare (type (simple-array card8 (*)) bytes) (type fixnum length)) ;; FIXME: How does this interact with unicode? (map-into (make-string (1- length)) #'code-char bytes))))) ;;; Rendering commands (in alphabetical order). (define-rendering-command accum 137 ;; *** ENUM (op card32) (value float32)) (define-rendering-command active-texture-arb 197 ;; *** ENUM (texture card32)) (define-rendering-command alpha-func 159 ;; *** ENUM (func card32) (ref float32)) (define-rendering-command begin 4 ;; *** ENUM (mode card32)) (define-rendering-command bind-texture 4117 ;; *** ENUM (target card32) (texture card32)) (define-rendering-command blend-color 4096 (red float32) (green float32) (blue float32) (alpha float32)) (define-rendering-command blend-equotion 4097 ;; *** ENUM (mode card32)) (define-rendering-command blend-func 160 ;; *** ENUM (sfactor card32) ;; *** ENUM (dfactor card32)) (define-rendering-command call-list 1 (list card32)) (define-rendering-command clear 127 ;; *** BITFIELD (mask card32)) (define-rendering-command clear-accum 128 (red float32) (green float32) (blue float32) (alpha float32)) (define-rendering-command clear-color 130 (red float32) (green float32) (blue float32) (alpha float32)) (define-rendering-command clear-depth 132 (depth float64)) (define-rendering-command clear-index 129 (c float32)) (define-rendering-command clear-stencil 131 (s int32)) (define-rendering-command clip-plane 77 (equotion-0 float64) (equotion-1 float64) (equotion-2 float64) (equotion-3 float64) ;; *** ENUM (plane card32)) (define-rendering-command color-3b 6 ((r g b) int8)) (define-rendering-command color-3d 7 ((r g b) float64)) (define-rendering-command color-3f 8 ((r g b) float32)) (define-rendering-command color-3i 9 ((r g b) int32)) (define-rendering-command color-3s 10 ((r g b) int16)) (define-rendering-command color-3ub 11 ((r g b) card8)) (define-rendering-command color-3ui 12 ((r g b) card32)) (define-rendering-command color-3us 13 ((r g b) card16)) (define-rendering-command color-4b 14 ((r g b a) int8)) (define-rendering-command color-4d 15 ((r g b a) float64)) (define-rendering-command color-4f 16 ((r g b a) float32)) (define-rendering-command color-4i 17 ((r g b a) int32)) (define-rendering-command color-4s 18 ((r g b a) int16)) (define-rendering-command color-4ub 19 ((r g b a) card8)) (define-rendering-command color-4ui 20 ((r g b a) card32)) (define-rendering-command color-4us 21 ((r g b a) card16)) (define-rendering-command color-mask 134 (red bool) (green bool) (blue bool) (alpha bool)) (define-rendering-command color-material 78 ;; *** ENUM (face card32) ;; *** ENUM (mode card32)) (define-rendering-command color-table-parameter-fv 2054 ;; *** ENUM (target card32) ;; TODO: ;; +GL-COLOR-TABLE-SCALE+ (#x80D6) => (length params) = 4 ;; +GL-COLOR-TABLE-BIAS+ (#x80d7) => (length params) = 4 ;; else (length params) = 0 (command is erronous) ;; *** ENUM (pname card32) (params (list float32 4))) (define-rendering-command color-table-parameter-iv 2055 ;; *** ENUM (target card32) ;; TODO: ;; +GL-COLOR-TABLE-SCALE+ (#x80D6) => (length params) = 4 ;; +GL-COLOR-TABLE-BIAS+ (#x80d7) => (length params) = 4 ;; else (length params) = 0 (command is erronous) ;; *** ENUM (pname card32) (params (list int32 4))) (define-rendering-command convolution-parameter-f 4103 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (params float32)) (define-rendering-command convolution-parameter-fv 4104 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (params (list float32 (ecase pname ((#.+convolution-border-mode+ #.+convolution-format+ #.+convolution-width+ #.+convolution-height+ #.+max-convolution-width+ #.+max-convolution-height+) 1) ((#.+convolution-filter-scale+ #.+convolution-filter-bias+) 4))))) (define-rendering-command convolution-parameter-i 4105 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (params int32)) (define-rendering-command convolution-parameter-iv 4106 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (params (list int32 (ecase pname ((#.+convolution-border-mode+ #.+convolution-format+ #.+convolution-width+ #.+convolution-height+ #.+max-convolution-width+ #.+max-convolution-height+) 1) ((#.+convolution-filter-scale+ #.+convolution-filter-bias+) 4))))) (define-rendering-command copy-color-sub-table 196 ;; *** ENUM (target card32) (start int32) (x int32) (y int32) (width int32)) (define-rendering-command copy-color-table 2056 ;; *** ENUM (target card32) ;; *** ENUM (internalformat card32) (x int32) (y int32) (width int32)) (define-rendering-command copy-convolution-filter-id 4107 ;; *** ENUM (target card32) ;; *** ENUM (internalformat card32) (x int32) (y int32) (width int32)) (define-rendering-command copy-convolution-filter-2d 4108 ;; *** ENUM (target card32) ;; *** ENUM (internalformat card32) (x int32) (y int32) (width int32) (height int32)) (define-rendering-command copy-pixels 172 (x int32) (y int32) (width int32) (height int32) ;; *** ENUM (type card32)) (define-rendering-command copy-tex-image-1d 4119 ;; *** ENUM (target card32) (level int32) ;; *** ENUM (internalformat card32) (x int32) (y int32) (width int32) (border int32)) (define-rendering-command copy-tex-image-2d 4120 ;; *** ENUM (target card32) (level int32) ;; *** ENUM (internalformat card32) (x int32) (y int32) (width int32) (height int32) (border int32)) (define-rendering-command copy-tex-sub-image-1d 4121 ;; *** ENUM (target card32) (level int32) (xoffset int32) (x int32) (y int32) (width int32)) (define-rendering-command copy-tex-sub-image-2d 4122 ;; *** ENUM (target card32) (level int32) (xoffset int32) (yoffset int32) (x int32) (y int32) (width int32) (height int32)) (define-rendering-command copy-tex-sub-image-3d 4123 ;; *** ENUM (target card32) (level int32) (xoffset int32) (yoffset int32) (zoffset int32) (x int32) (y int32) (width int32) (height int32)) (define-rendering-command cull-face 79 ;; *** ENUM (mode card32)) (define-rendering-command depth-func 164 ;; *** ENUM (func card32)) (define-rendering-command depth-mask 135 (mask bool)) (define-rendering-command depth-range 174 (z-near float64) (z-far float64)) (define-rendering-command draw-buffer 126 ;; *** ENUM (mode card32)) (define-rendering-command edge-flag-v 22 (flag-0 bool)) (define-rendering-command end 23) (define-rendering-command eval-coord-1d 151 (u-0 float64)) (define-rendering-command eval-coord-1f 152 (u-0 float32)) (define-rendering-command eval-coord-2d 153 ((u-0 u-1) float64)) (define-rendering-command eval-coord-2f 154 ((u-0 u-1) float32)) (define-rendering-command eval-mesh-1 155 ;; *** ENUM (mode card32) ((i1 i2) int32)) (define-rendering-command eval-mesh-2 157 ;; *** ENUM (mode card32) ((i1 i2 j1 j2) int32)) (define-rendering-command eval-point-1 156 (i int32)) (define-rendering-command eval-point-2 158 (i int32) (j int32)) (define-rendering-command fog-f 80 ;; *** ENUM (pname card32) (param float32)) (define-rendering-command fog-fv 81 ;; *** ENUM (pname card32) (params (list float32 (ecase pname ((#.+fog-index+ #.+fog-density+ #.+fog-start+ #.+fog-end+ #.+fog-mode+) 1) ((#.+fog-color+) 4))))) (define-rendering-command fog-i 82 ;; *** ENUM (pname card32) (param int32)) (define-rendering-command fog-iv 83 ;; *** ENUM (pname card32) (params (list int32 (ecase pname ((#.+fog-index+ #.+fog-density+ #.+fog-start+ #.+fog-end+ #.+fog-mode+) 1) ((#.+fog-color+) 4))))) (define-rendering-command front-face 84 ;; *** ENUM (mode card32)) (define-rendering-command frustum 175 (left float64) (right float64) (bottom float64) (top float64) (z-near float64) (z-far float64)) (define-rendering-command hint 85 ;; *** ENUM (target card32) ;; *** ENUM (mode card32)) (define-rendering-command histogram 4110 ;; *** ENUM (target card32) (width int32) ;; *** ENUM (internalformat card32) (sink bool)) (define-rendering-command index-mask 136 (mask card32)) (define-rendering-command index-d 24 (c-0 float64)) (define-rendering-command index-f 25 (c-0 float32)) (define-rendering-command index-i 26 (c-0 int32)) (define-rendering-command index-s 27 (c-0 int16)) (define-rendering-command index-ub 194 (c-0 card8)) (define-rendering-command init-names 121) (define-rendering-command light-model-f 90 ;; *** ENUM (pname card32) (param float32)) (define-rendering-command light-model-fv 91 ;; *** ENUM (pname card32) (params (list float32 (ecase pname ((#.+light-model-color-control+ #.+light-model-local-viewer+ #.+light-model-two-side+) 1) ((#.+light-model-ambient+) 4))))) (define-rendering-command light-model-i 92 ;; *** ENUM (pname card32) (param int32)) (define-rendering-command light-model-iv 93 ;; *** ENUM (pname card32) (params (list int32 (ecase pname ((#.+light-model-color-control+ #.+light-model-local-viewer+ #.+light-model-two-side+) 1) ((#.+light-model-ambient+) 4))))) (define-rendering-command light-f 86 ;; *** ENUM (light card32) ;; *** ENUM (pname card32) (param float32)) (define-rendering-command light-fv 87 ;; *** ENUM (light card32) ;; *** ENUM (pname card32) (params (list float32 (ecase pname ((#.+ambient+ #.+diffuse+ #.+specular+ #.+position+) 4) ((#.+spot-direction+) 3) ((#.+spot-exponent+ #.+spot-cutoff+ #.+constant-attenuation+ #.+linear-attenuation+ #.+quadratic-attenuation+) 1))))) (define-rendering-command light-i 88 ;; *** ENUM (light card32) ;; *** ENUM (pname card32) (param int32)) (define-rendering-command light-iv 89 ;; *** ENUM (light card32) ;; *** ENUM (pname card32) (params (list int32 (ecase pname ((#.+ambient+ #.+diffuse+ #.+specular+ #.+position+) 4) ((#.+spot-direction+) 3) ((#.+spot-exponent+ #.+spot-cutoff+ #.+constant-attenuation+ #.+linear-attenuation+ #.+quadratic-attenuation+) 1))))) (define-rendering-command line-stipple 94 (factor int32) (pattern card16)) (define-rendering-command line-width 95 (width float32)) (define-rendering-command list-base 3 (base card32)) (define-rendering-command load-identity 176) (define-rendering-command load-matrix-d 178 (m (list float64 16))) (define-rendering-command load-matrix-f 177 (m (list float32 16))) (define-rendering-command load-name 122 (name card32)) (define-rendering-command logic-op 161 ;; *** ENUM (name card32)) (define-rendering-command map-grid-1d 147 (u1 float64) (u2 float64) (un int32)) (define-rendering-command map-grid-1f 148 (un int32) (u1 float32) (u2 float32)) (define-rendering-command map-grid-2d 149 (u1 float64) (u2 float64) (v1 float64) (v2 float64) (un int32) (vn int32)) (define-rendering-command map-grid-2f 150 (un int32) (u1 float32) (u2 float32) (vn int32) (v1 float32) (v2 float32)) (define-rendering-command material-f 96 ;; *** ENUM (face card32) ;; *** ENUM (pname card32) (param float32)) (define-rendering-command material-fv 97 ;; *** ENUM (face card32) ;; *** ENUM (pname card32) (params (list float32 (ecase pname ((#.+ambient+ #.+diffuse+ #.+specular+ #.+emission+ #.+ambient-and-diffuse+) 4) ((#.+shininess+) 1) ((#.+color-index+) 3))))) (define-rendering-command material-i 98 ;; *** ENUM (face card32) ;; *** ENUM (pname card32) (param int32)) (define-rendering-command material-iv 99 ;; *** ENUM (face card32) ;; *** ENUM (pname card32) (params (list int32 (ecase pname ((#.+ambient+ #.+diffuse+ #.+specular+ #.+emission+ #.+ambient-and-diffuse+) 4) ((#.+shininess+) 1) ((#.+color-index+) 3))))) (define-rendering-command matrix-mode 179 ;; *** ENUM (mode card32)) (define-rendering-command minmax 4111 ;; *** ENUM (target card32) ;; *** ENUM (internalformat card32) (sink bool)) (define-rendering-command mult-matrix-d 181 (m (list float64 16))) (define-rendering-command mult-matrix-f 180 (m (list float32 16))) ;;; *** Note that TARGET is placed last for FLOAT64 versions. (define-rendering-command multi-tex-coord-1d-arb 198 (v-0 float64) ;; *** ENUM (target card32)) (define-rendering-command multi-tex-coord-1f-arb 199 ;; *** ENUM (target card32) (v-0 float32)) (define-rendering-command multi-tex-coord-1i-arb 200 ;; *** ENUM (target card32) (v-0 int32)) (define-rendering-command multi-tex-coord-1s-arb 201 ;; *** ENUM (target card32) (v-0 int16)) (define-rendering-command multi-tex-coord-2d-arb 202 ((v-0 v-1) float64) ;; *** ENUM (target card32)) (define-rendering-command multi-tex-coord-2f-arb 203 ;; *** ENUM (target card32) ((v-0 v-1) float32)) (define-rendering-command multi-tex-coord-2i-arb 204 ;; *** ENUM (target card32) ((v-0 v-1) int32)) (define-rendering-command multi-tex-coord-2s-arb 205 ;; *** ENUM (target card32) ((v-0 v-1) int16)) (define-rendering-command multi-tex-coord-3d-arb 206 ((v-0 v-1 v-2) float64) ;; *** ENUM (target card32)) (define-rendering-command multi-tex-coord-3f-arb 207 ;; *** ENUM (target card32) ((v-0 v-1 v-2) float32)) (define-rendering-command multi-tex-coord-3i-arb 208 ;; *** ENUM (target card32) ((v-0 v-1 v-2) int32)) (define-rendering-command multi-tex-coord-3s-arb 209 ;; *** ENUM (target card32) ((v-0 v-1 v-2) int16)) (define-rendering-command multi-tex-coord-4d-arb 210 ((v-0 v-1 v-2 v-3) float64) ;; *** ENUM (target card32)) (define-rendering-command multi-tex-coord-4f-arb 211 ;; *** ENUM (target card32) ((v-0 v-1 v-2 v-3) float32)) (define-rendering-command multi-tex-coord-4i-arb 212 ;; *** ENUM (target card32) ((v-0 v-1 v-2 v-3) int32)) (define-rendering-command multi-tex-coord-4s-arb 213 ;; *** ENUM (target card32) ((v-0 v-1 v-2 v-3) int16)) (define-rendering-command normal-3b 28 ((v-0 v-1 v-2) int8)) (define-rendering-command normal-3d 29 ((v-0 v-1 v-2) float64)) (define-rendering-command normal-3f 30 ((v-0 v-1 v-2) float32)) (define-rendering-command normal-3i 31 ((v-0 v-1 v-2) int32)) (define-rendering-command normal-3s 32 ((v-0 v-1 v-2) int16)) (define-rendering-command ortho 182 (left float64) (right float64) (bottom float64) (top float64) (z-near float64) (z-far float64)) (define-rendering-command pass-through 123 (token float32)) (define-rendering-command pixel-transfer-f 166 ;; *** ENUM (pname card32) (param float32)) (define-rendering-command pixel-transfer-i 167 ;; *** ENUM (pname card32) (param int32)) (define-rendering-command pixel-zoom 165 (xfactor float32) (yfactor float32)) (define-rendering-command point-size 100 (size float32)) (define-rendering-command polygon-mode 101 ;; *** ENUM (face card32) ;; *** ENUM (mode card32)) (define-rendering-command polygon-offset 192 (factor float32) (units float32)) (define-rendering-command pop-attrib 141) (define-rendering-command pop-matrix 183) (define-rendering-command pop-name 124) (define-rendering-command prioritize-textures 4118 (n int32) (textures (list card32 n)) (priorities (list float32 n))) (define-rendering-command push-attrib 142 ;; *** BITFIELD (mask card32)) (define-rendering-command push-matrix 184) (define-rendering-command push-name 125 (name card32)) (define-rendering-command raster-pos-2d 33 ((v-0 v-1) float64)) (define-rendering-command raster-pos-2f 34 ((v-0 v-1) float32)) (define-rendering-command raster-pos-2i 35 ((v-0 v-1) int32)) (define-rendering-command raster-pos-2s 36 ((v-0 v-1) int16)) (define-rendering-command raster-pos-3d 37 ((v-0 v-1 v-2) float64)) (define-rendering-command raster-pos-3f 38 ((v-0 v-1 v-2) float32)) (define-rendering-command raster-pos-3i 39 ((v-0 v-1 v-2) int32)) (define-rendering-command raster-pos-3s 40 ((v-0 v-1 v-2) int16)) (define-rendering-command raster-pos-4d 41 ((v-0 v-1 v-2 v-3) float64)) (define-rendering-command raster-pos-4f 42 ((v-0 v-1 v-2 v-3) float32)) (define-rendering-command raster-pos-4i 43 ((v-0 v-1 v-2 v-3) int32)) (define-rendering-command raster-pos-4s 44 ((v-0 v-1 v-2 v-3) int16)) (define-rendering-command read-buffer 171 ;; *** ENUM (mode card32)) (define-rendering-command rect-d 45 ((v1-0 v1-1 v2-0 v2-1) float64)) (define-rendering-command rect-f 46 ((v1-0 v1-1 v2-0 v2-1) float32)) (define-rendering-command rect-i 47 ((v1-0 v1-1 v2-0 v2-1) int32)) (define-rendering-command rect-s 48 ((v1-0 v1-1 v2-0 v2-1) int16)) (define-rendering-command reset-histogram 4112 ;; *** ENUM (target card32)) (define-rendering-command reset-minmax 4113 ;; *** ENUM (target card32)) (define-rendering-command rotate-d 185 ((angle x y z) float64)) (define-rendering-command rotate-f 186 ((angle x y z) float32)) (define-rendering-command scale-d 187 ((x y z) float64)) (define-rendering-command scale-f 188 ((x y z) float32)) (define-rendering-command scissor 103 ((x y width height) int32)) (define-rendering-command shade-model 104 ;; *** ENUM (mode card32)) (define-rendering-command stencil-func 162 ;; *** ENUM (func card32) (ref int32) (mask card32)) (define-rendering-command stencil-mask 133 (mask card32)) (define-rendering-command stencil-op 163 ;; *** ENUM (fail card32) ;; *** ENUM (zfail card32) ;; *** ENUM (zpass card32)) (define-rendering-command tex-env-f 111 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (param float32)) (define-rendering-command tex-env-fv 112 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (param (list float32 (ecase pname (#.+texture-env-mode+ 1) (#.+texture-env-color+ 4))))) (define-rendering-command tex-env-i 113 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (param int32)) (define-rendering-command tex-env-iv 114 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (param (list int32 (ecase pname (#.+texture-env-mode+ 1) (#.+texture-env-color+ 4))))) ;;; *** ;;; last there. (define-rendering-command tex-gen-d 115 (param float64) ;; *** ENUM (coord card32) ;; *** ENUM (pname card32)) (define-rendering-command tex-gen-dv 116 ;; *** ENUM (coord card32) ;; *** ENUM (pname card32) ;; +texture-gen-mode+ n=1 ;; +object-plane+ n=4 ;; +eye-plane+ n=1 (params (list float64 (ecase pname ((#.+texture-gen-mode+ #.+eye-plane+) 1) (#.+object-plane+ 4))))) (define-rendering-command tex-gen-f 117 ;; *** ENUM (coord card32) ;; *** ENUM (pname card32) (param float32)) (define-rendering-command tex-gen-fv 118 ;; *** ENUM (coord card32) ;; *** ENUM (pname card32) (params (list float32 (ecase pname ((#.+texture-gen-mode+ #.+eye-plane+) 1) (#.+object-plane+ 4))))) (define-rendering-command tex-gen-i 119 ;; *** ENUM (coord card32) ;; *** ENUM (pname card32) (param int32)) (define-rendering-command tex-gen-iv 120 ;; *** ENUM (coord card32) ;; *** ENUM (pname card32) (params (list int32 (ecase pname ((#.+texture-gen-mode+ #.+eye-plane+) 1) (#.+object-plane+ 4))))) (define-rendering-command tex-parameter-f 105 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (param float32)) (define-rendering-command tex-parameter-fv 106 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (params (list float32 (ecase pname ((#.+texture-border-color+) 4) ((#.+texture-mag-filter+ #.+texture-min-filter+ #.+texture-wrap-s+ #.+texture-wrap-t+) 1))))) (define-rendering-command tex-parameter-i 107 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (param int32)) (define-rendering-command tex-parameter-iv 108 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (params (list int32 (ecase pname ((#.+texture-border-color+) 4) ((#.+texture-mag-filter+ #.+texture-min-filter+ #.+texture-wrap-s+ #.+texture-wrap-t+) 1))))) (define-rendering-command translate-d 189 ((x y z) float64)) (define-rendering-command translate-f 190 ((x y z) float32)) (define-rendering-command vertex-2d 65 ((x y) float64)) (define-rendering-command vertex-2f 66 ((x y) float32)) (define-rendering-command vertex-2i 67 ((x y) int32)) (define-rendering-command vertex-2s 68 ((x y) int16)) (define-rendering-command vertex-3d 69 ((x y z) float64)) (define-rendering-command vertex-3f 70 ((x y z) float32)) (define-rendering-command vertex-3i 71 ((x y z) int32)) (define-rendering-command vertex-3s 72 ((x y z) int16)) (define-rendering-command vertex-4d 73 ((x y z w) float64)) (define-rendering-command vertex-4f 74 ((x y z w) float32)) (define-rendering-command vertex-4i 75 ((x y z w) int32)) (define-rendering-command vertex-4s 76 ((x y z w) int16)) (define-rendering-command viewport 191 ((x y width height) int32)) ;;; Potentially lerge rendering commands. #-(and) (define-large-rendering-command call-lists 2 (n int32) ;; *** ENUM (type card32) (lists (list type n))) ;;; Requests for GL non-rendering commands. (defun new-list (list mode) (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request (display (extension-opcode display "GLX")) (data +new-list+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx)) (card32 list) ;; *** ENUM (card32 mode)))) (defun gen-lists (range) (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +gen-lists+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx)) (integer range)) (card32-get 8)))) (defun end-list () (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request (display (extension-opcode display "GLX")) (data +end-list+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx))))) (defun enable (cap) (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +enable+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx)) ;; *** ENUM? (card32 cap))))) ;;; FIXME: FLUSH and FINISH should send *all* buffered data, including ;;; buffered rendering commands. (defun flush () (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request (display (extension-opcode display "GLX")) (data +flush+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx))))) (defun finish () (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +finish+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx)))))) cl-clx-sbcl-0.7.4.20160323.orig/xtest.lisp0000644000175000017500000001077112715665273015671 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- ;;; ;;; Implementation of the XTest extension as described by ;;; http://www.x.org/docs/Xext/xtest.pdf ;;; ;;; Written by Lionel Flandrin in july ;;; 2008 and placed in the public domain. ;;; ;;; TODO: ;;; * Implement XTestSetVisualIDOfVisual and XTestDiscard ;;; * Add the missing (declare (type ... (defpackage :xtest (:use :common-lisp :xlib) (:import-from :xlib #:data #:card8 #:card8-get #:card16 #:card16-get #:card32 #:card32-get #:extension-opcode #:define-extension #:gcontext #:resource-id #:window-id #:cursor #:make-cursor #:with-buffer-request-and-reply #:with-buffer-request #:display) (:export ;; Constants #:+major-version+ #:+minor-version+ ;; Functions #:set-gc-context-of-gc #:get-version #:compare-cursor #:fake-motion-event #:fake-button-event #:fake-key-event #:grab-control)) (in-package :xtest) (define-extension "XTEST") (defmacro opcode (display) `(extension-opcode ,display "XTEST")) ;;; The version we implement (defconstant +major-version+ 2) (defconstant +minor-version+ 2) (defconstant +none+ 0) (defconstant +current-cursor+ 1) ;;; XTest opcodes (defconstant +get-version+ 0) (defconstant +compare-cursor+ 1) (defconstant +fake-input+ 2) (defconstant +grab-control+ 3) ;;; Fake events (defconstant +fake-key-press+ 2) (defconstant +fake-key-release+ 3) (defconstant +fake-button-press+ 4) (defconstant +fake-button-release+ 5) (defconstant +fake-motion-notify+ 6) ;;; Client operations (defun set-gc-context-of-gc (gcontext gcontext-id) (declare (type gcontext gcontext) (type resource-id gcontext-id)) (setf (gcontext-id gcontext) gcontext-id)) ;;; Server requests (defun get-version (display &optional (major +major-version+) (minor +minor-version+)) "Returns the major and minor version of the server's XTest implementation" (declare (type display display)) (with-buffer-request-and-reply (display (opcode display) nil) ((data +get-version+) (card8 major) (card16 minor)) (values (card8-get 1) (card16-get 8)))) (defun compare-cursor (display window &optional (cursor-id +current-cursor+)) (declare (type display display) (type resource-id cursor-id) (type window window)) (with-buffer-request-and-reply (display (opcode display) nil) ((data +compare-cursor+) (resource-id (window-id window)) (resource-id cursor-id)) (values (card8-get 1)))) (defun fake-motion-event (display x y &key (delay 0) relative (root-window-id 0)) "Move the mouse pointer at coordinates (x, y). If :relative is t, the movement is relative to the pointer's current position" (declare (type display display)) (with-buffer-request (display (opcode display)) (data +fake-input+) (card8 +fake-motion-notify+) (card8 (if relative 1 0)) (pad16 0) (card32 delay) (card32 root-window-id) (pad32 0 0) (card16 x) (card16 y) (pad32 0 0))) (defun fake-button-event (display button pressed &key (delay 0)) "Send a fake button event (button pressed or released) to the server. Most of the time, button 1 is the left one, 2 the middle and 3 the right one but it's not always the case." (declare (type display display)) (with-buffer-request (display (opcode display)) (data +fake-input+) (card8 (if pressed +fake-button-press+ +fake-button-release+)) (card8 button) (pad16 0) (card32 delay) (pad32 0 0 0 0 0 0))) (defun fake-key-event (display keycode pressed &key (delay 0)) "Send a fake key event (key pressed or released) to the server based on its keycode." (declare (type display display)) (with-buffer-request (display (opcode display)) (data +fake-input+) (card8 (if pressed +fake-key-press+ +fake-key-release+)) (card8 keycode) (pad16 0) (card32 delay) (pad32 0 0 0 0 0 0))) (defun grab-control (display grab?) "Make the client grab the server, that is allow it to make requests even when another client grabs the server." (declare (type display display)) (with-buffer-request (display (opcode display)) (data +grab-control+) (card8 (if grab? 1 0)) (pad8 0) (pad16 0))) ;;; Local Variables: ;;; indent-tabs-mode: nil ;;; End: cl-clx-sbcl-0.7.4.20160323.orig/buffer.lisp0000644000175000017500000014610412715665272015772 0ustar pdmpdm;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; This file contains definitions for the BUFFER object for Common-Lisp X ;;; windows version 11 ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; ;; A few notes: ;; ;; 1. The BUFFER implements a two-way buffered byte / half-word ;; / word stream. Hooks are left for implementing this with a ;; shared memory buffer, or with effenciency hooks to the network ;; code. ;; ;; 2. The BUFFER object uses overlapping displaced arrays for ;; inserting and removing bytes half-words and words. ;; ;; 3. The BYTE component of these arrays is written to a STREAM ;; associated with the BUFFER. The stream has its own buffer. ;; This may be made more efficient by using the Zetalisp ;; :Send-Output-Buffer operation. ;; ;; 4. The BUFFER object is INCLUDED in the DISPLAY object. ;; This was done to reduce access time when sending requests, ;; while maintaing some code modularity. ;; Several buffer functions are duplicated (with-buffer, ;; buffer-force-output, close-buffer) to keep the naming ;; conventions consistent. ;; ;; 5. A nother layer of software is built on top of this for generating ;; both client and server interface routines, given a specification ;; of the protocol. (see the INTERFACE file) ;; ;; 6. Care is taken to leave the buffer pointer (buffer-bbuf) set to ;; a point after a complete request. This is to ensure that a partial ;; request won't be left after aborts (e.g. control-abort on a lispm). (in-package :xlib) (defconstant +requestsize+ 160) ;; Max request size (excluding variable length requests) ;;; This is here instead of in bufmac so that with-display can be ;;; compiled without macros and bufmac being loaded. (defmacro with-buffer ((buffer &key timeout inline) &body body &environment env) ;; This macro is for use in a multi-process environment. It provides ;; exclusive access to the local buffer object for request generation and ;; reply processing. `(macrolet ((with-buffer ((buffer &key timeout) &body body) ;; Speedup hack for lexically nested with-buffers `(progn (progn ,buffer ,@(and timeout `(,timeout)) nil) ,@body))) ,(if (and (null inline) (macroexpand '(use-closures) env)) `(flet ((.with-buffer-body. () ,@body)) #+clx-ansi-common-lisp (declare (dynamic-extent #'.with-buffer-body.)) (with-buffer-function ,buffer ,timeout #'.with-buffer-body.)) (let ((buf (if (or (symbolp buffer) (constantp buffer)) buffer '.buffer.))) `(let (,@(unless (eq buf buffer) `((,buf ,buffer)))) ,@(unless (eq buf buffer) `((declare (type buffer ,buf)))) ,(declare-bufmac) (when (buffer-dead ,buf) (x-error 'closed-display :display ,buf)) (holding-lock ((buffer-lock ,buf) ,buf "CLX Display Lock" ,@(and timeout `(:timeout ,timeout))) ,@body)))))) (defun with-buffer-function (buffer timeout function) (declare (type display buffer) (type (or null number) timeout) (type function function) #+clx-ansi-common-lisp (dynamic-extent function) ;; FIXME: This is probably more a bug in SBCL (logged as ;; bug #243) (ignorable timeout) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg function)) (with-buffer (buffer :timeout timeout :inline t) (funcall function))) ;;; The following are here instead of in bufmac so that event-case can ;;; be compiled without macros and bufmac being loaded. (defmacro read-card8 (byte-index) `(aref-card8 buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro read-int8 (byte-index) `(aref-int8 buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro read-card16 (byte-index) #+clx-overlapping-arrays `(aref-card16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1))) #-clx-overlapping-arrays `(aref-card16 buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro read-int16 (byte-index) #+clx-overlapping-arrays `(aref-int16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1))) #-clx-overlapping-arrays `(aref-int16 buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro read-card32 (byte-index) #+clx-overlapping-arrays `(aref-card32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) #-clx-overlapping-arrays `(aref-card32 buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro read-int32 (byte-index) #+clx-overlapping-arrays `(aref-int32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) #-clx-overlapping-arrays `(aref-int32 buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro read-card29 (byte-index) #+clx-overlapping-arrays `(aref-card29 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) #-clx-overlapping-arrays `(aref-card29 buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro event-code (reply-buffer) ;; The reply-buffer structure is used for events. ;; The size slot is used for the event code. `(reply-size ,reply-buffer)) (defmacro reading-event ((event &rest options) &body body) (declare (arglist (buffer &key sizes) &body body)) ;; BODY may contain calls to (READ32 &optional index) etc. ;; These calls will read from the input buffer at byte ;; offset INDEX. If INDEX is not supplied, then the next ;; word, half-word or byte is returned. `(with-buffer-input (,event ,@options) ,@body)) (defmacro with-buffer-input ((reply-buffer &key display (sizes '(8 16 32)) index) &body body) (unless (listp sizes) (setq sizes (list sizes))) ;; 160 is a special hack for client-message-events (when (set-difference sizes '(0 8 16 32 160 256)) (error "Illegal sizes in ~a" sizes)) `(let ((%reply-buffer ,reply-buffer) ,@(and display `((%buffer ,display)))) (declare (type reply-buffer %reply-buffer) ,@(and display '((type display %buffer)))) ,(declare-bufmac) ,@(and display '(%buffer)) (let* ((buffer-boffset (the array-index ,(or index 0))) #-clx-overlapping-arrays (buffer-bbuf (reply-ibuf8 %reply-buffer)) #+clx-overlapping-arrays ,@(append (when (member 8 sizes) `((buffer-bbuf (reply-ibuf8 %reply-buffer)))) (when (or (member 16 sizes) (member 160 sizes)) `((buffer-woffset (index-ash buffer-boffset -1)) (buffer-wbuf (reply-ibuf16 %reply-buffer)))) (when (member 32 sizes) `((buffer-loffset (index-ash buffer-boffset -2)) (buffer-lbuf (reply-ibuf32 %reply-buffer)))))) (declare (type array-index buffer-boffset)) #-clx-overlapping-arrays (declare (type buffer-bytes buffer-bbuf)) #+clx-overlapping-arrays ,@(append (when (member 8 sizes) '((declare (type buffer-bytes buffer-bbuf)))) (when (member 16 sizes) '((declare (type array-index buffer-woffset)) (declare (type buffer-words buffer-wbuf)))) (when (member 32 sizes) '((declare (type array-index buffer-loffset)) (declare (type buffer-longs buffer-lbuf))))) buffer-boffset #-clx-overlapping-arrays buffer-bbuf #+clx-overlapping-arrays ,@(append (when (member 8 sizes) '(buffer-bbuf)) (when (member 16 sizes) '(buffer-woffset buffer-wbuf)) (when (member 32 sizes) '(buffer-loffset buffer-lbuf))) #+clx-overlapping-arrays (macrolet ((%buffer-sizes () ',sizes)) ,@body) #-clx-overlapping-arrays ,@body))) (defun make-buffer (output-size constructor &rest options) (declare (dynamic-extent options)) ;; Output-Size is the output-buffer size in bytes. (let ((byte-output (make-array output-size :element-type 'card8 :initial-element 0))) (apply constructor :size output-size :obuf8 byte-output #+clx-overlapping-arrays :obuf16 #+clx-overlapping-arrays (make-array (index-ash output-size -1) :element-type 'overlap16 :displaced-to byte-output) #+clx-overlapping-arrays :obuf32 #+clx-overlapping-arrays (make-array (index-ash output-size -2) :element-type 'overlap32 :displaced-to byte-output) options))) (defun make-reply-buffer (size) ;; Size is the buffer size in bytes (let ((byte-input (make-array size :element-type 'card8 :initial-element 0))) (make-reply-buffer-internal :size size :ibuf8 byte-input #+clx-overlapping-arrays :ibuf16 #+clx-overlapping-arrays (make-array (index-ash size -1) :element-type 'overlap16 :displaced-to byte-input) #+clx-overlapping-arrays :ibuf32 #+clx-overlapping-arrays (make-array (index-ash size -2) :element-type 'overlap32 :displaced-to byte-input)))) (defun buffer-ensure-size (buffer size) (declare (type buffer buffer) (type array-index size)) (when (index> size (buffer-size buffer)) (with-buffer (buffer) (buffer-flush buffer) (let* ((new-buffer-size (index-ash 1 (integer-length (index1- size)))) (new-buffer (make-array new-buffer-size :element-type 'card8 :initial-element 0))) (setf (buffer-obuf8 buffer) new-buffer) #+clx-overlapping-arrays (setf (buffer-obuf16 buffer) (make-array (index-ash new-buffer-size -1) :element-type 'overlap16 :displaced-to new-buffer) (buffer-obuf32 buffer) (make-array (index-ash new-buffer-size -2) :element-type 'overlap32 :displaced-to new-buffer)))))) (defun buffer-pad-request (buffer pad) (declare (type buffer buffer) (type array-index pad)) (unless (index-zerop pad) (when (index> (index+ (buffer-boffset buffer) pad) (buffer-size buffer)) (buffer-flush buffer)) (incf (buffer-boffset buffer) pad) (unless (index-zerop (index-mod (buffer-boffset buffer) 4)) (buffer-flush buffer)))) (declaim (inline buffer-new-request-number)) (defun buffer-new-request-number (buffer) (declare (type buffer buffer)) (setf (buffer-request-number buffer) (ldb (byte 16 0) (1+ (buffer-request-number buffer))))) (defun with-buffer-request-function (display gc-force request-function) (declare (type display display) (type (or null gcontext) gc-force)) (declare (type function request-function) #+clx-ansi-common-lisp (dynamic-extent request-function) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg request-function)) (with-buffer (display :inline t) (multiple-value-prog1 (progn (when gc-force (force-gcontext-changes-internal gc-force)) (without-aborts (funcall request-function display))) (display-invoke-after-function display)))) (defun with-buffer-request-function-nolock (display gc-force request-function) (declare (type display display) (type (or null gcontext) gc-force)) (declare (type function request-function) #+clx-ansi-common-lisp (dynamic-extent request-function) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg request-function)) (multiple-value-prog1 (progn (when gc-force (force-gcontext-changes-internal gc-force)) (without-aborts (funcall request-function display))) (display-invoke-after-function display))) (defstruct (pending-command (:copier nil) (:predicate nil)) (sequence 0 :type card16) (reply-buffer nil :type (or null reply-buffer)) (process nil) (next nil #-explorer :type #-explorer (or null pending-command))) (defun with-buffer-request-and-reply-function (display multiple-reply request-function reply-function) (declare (type display display) (type generalized-boolean multiple-reply)) (declare (type function request-function reply-function) #+clx-ansi-common-lisp (dynamic-extent request-function reply-function) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg request-function reply-function)) (let ((pending-command nil) (reply-buffer nil)) (declare (type (or null pending-command) pending-command) (type (or null reply-buffer) reply-buffer)) (unwind-protect (progn (with-buffer (display :inline t) (setq pending-command (start-pending-command display)) (without-aborts (funcall request-function display)) (buffer-force-output display) (display-invoke-after-function display)) (cond (multiple-reply (loop (setq reply-buffer (read-reply display pending-command)) (when (funcall reply-function display reply-buffer) (return nil)) (deallocate-reply-buffer (shiftf reply-buffer nil)))) (t (setq reply-buffer (read-reply display pending-command)) (funcall reply-function display reply-buffer)))) (when reply-buffer (deallocate-reply-buffer reply-buffer)) (when pending-command (stop-pending-command display pending-command))))) ;; ;; Buffer stream operations ;; (defun buffer-write (vector buffer start end) ;; Write out VECTOR from START to END into BUFFER ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER (declare (type buffer buffer) (type array-index start end)) (when (buffer-dead buffer) (x-error 'closed-display :display buffer)) (wrap-buf-output (buffer) (funcall (buffer-write-function buffer) vector buffer start end)) nil) (defun buffer-flush (buffer) ;; Write the buffer contents to the server stream - doesn't force-output the stream ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER (declare (type buffer buffer)) (unless (buffer-flush-inhibit buffer) (let ((boffset (buffer-boffset buffer))) (declare (type array-index boffset)) (when (index-plusp boffset) (buffer-write (buffer-obuf8 buffer) buffer 0 boffset) (setf (buffer-boffset buffer) 0) (setf (buffer-last-request buffer) nil)))) nil) (defmacro with-buffer-flush-inhibited ((buffer) &body body) (let ((buf (if (or (symbolp buffer) (constantp buffer)) buffer '.buffer.))) `(let* (,@(and (not (eq buf buffer)) `((,buf ,buffer))) (.saved-buffer-flush-inhibit. (buffer-flush-inhibit ,buf))) (unwind-protect (progn (setf (buffer-flush-inhibit ,buf) t) ,@body) (setf (buffer-flush-inhibit ,buf) .saved-buffer-flush-inhibit.))))) (defun buffer-force-output (buffer) ;; Output is normally buffered, this forces any buffered output to the server. (declare (type buffer buffer)) (when (buffer-dead buffer) (x-error 'closed-display :display buffer)) (buffer-flush buffer) (wrap-buf-output (buffer) (without-aborts (funcall (buffer-force-output-function buffer) buffer))) nil) (defun close-buffer (buffer &key abort) ;; Close the host connection in BUFFER (declare (type buffer buffer)) (unless (null (buffer-output-stream buffer)) (wrap-buf-output (buffer) (funcall (buffer-close-function buffer) buffer :abort abort)) (setf (buffer-dead buffer) t) ;; Zap pointers to the streams, to ensure they're GC'd (setf (buffer-output-stream buffer) nil) (setf (buffer-input-stream buffer) nil) ) nil) (defun buffer-input (buffer vector start end &optional timeout) ;; Read into VECTOR from the buffer stream ;; Timeout, when non-nil, is in seconds ;; Returns non-nil if EOF encountered ;; Returns :TIMEOUT when timeout exceeded (declare (type buffer buffer) (type vector vector) (type array-index start end) (type (or null number) timeout)) (declare (clx-values eof-p)) (when (buffer-dead buffer) (x-error 'closed-display :display buffer)) (unless (= start end) (let ((result (wrap-buf-input (buffer) (funcall (buffer-input-function buffer) buffer vector start end timeout)))) (unless (or (null result) (eq result :timeout)) (close-buffer buffer)) result))) (defun buffer-input-wait (buffer timeout) ;; Timeout, when non-nil, is in seconds ;; Returns non-nil if EOF encountered ;; Returns :TIMEOUT when timeout exceeded (declare (type buffer buffer) (type (or null number) timeout)) (declare (clx-values timeout)) (when (buffer-dead buffer) (x-error 'closed-display :display buffer)) (let ((result (wrap-buf-input (buffer) (funcall (buffer-input-wait-function buffer) buffer timeout)))) (unless (or (null result) (eq result :timeout)) (close-buffer buffer)) result)) (defun buffer-listen (buffer) ;; Returns T if there is input available for the buffer. This should never ;; block, so it can be called from the scheduler. (declare (type buffer buffer)) (declare (clx-values input-available)) (or (not (null (buffer-dead buffer))) (wrap-buf-input (buffer) (funcall (buffer-listen-function buffer) buffer)))) ;;; Reading sequences of strings ;;; a list of pascal-strings with card8 lengths, no padding in between ;;; can't use read-sequence-char (defun read-sequence-string (buffer-bbuf length nitems result-type &optional (buffer-boffset 0)) (declare (type buffer-bytes buffer-bbuf) (type array-index length nitems buffer-boffset)) length (with-vector (buffer-bbuf buffer-bytes) (let ((result (make-sequence result-type nitems))) (do* ((index 0 (index+ index 1 string-length)) (count 0 (index1+ count)) (string-length 0) (string "")) ((index>= count nitems) result) (declare (type array-index index count string-length) (type string string)) (setq string-length (read-card8 index) string (make-sequence 'string string-length)) (do ((i (index1+ index) (index1+ i)) (j 0 (index1+ j))) ((index>= j string-length) (setf (elt result count) string)) (declare (type array-index i j)) (setf (aref string j) (card8->char (read-card8 i)))))))) ;;; Reading sequences of chars (defmacro define-transformed-sequence-reader (name totype transformer reader) (let ((ntrans (gensym))) `(defun ,name (reply-buffer result-type nitems &optional transform data (start 0) (index 0)) (declare (type reply-buffer reply-buffer) (type t result-type) (type array-index nitems start index) (type (or null sequence) data) (type (or null (function (,totype) t)) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (if transform (flet ((,ntrans (v) (funcall transform (,transformer v)))) #+clx-ansi-common-lisp (declare (dynamic-extent #',ntrans)) (,reader reply-buffer result-type nitems #',ntrans data start index)) (,reader reply-buffer result-type nitems #',transformer data start index))))) (define-transformed-sequence-reader read-sequence-char character card8->char read-sequence-card8) ;;; Reading sequences of card8's (defmacro define-list-readers ((name tname) type size step reader) `(progn (defun ,name (reply-buffer nitems data start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type list data)) (with-buffer-input (reply-buffer :sizes (,size) :index index) (do* ((j nitems (index- j 1)) (list (nthcdr start data) (cdr list)) (index 0 (index+ index ,step))) ((index-zerop j)) (declare (type array-index index j) (type list list)) (setf (car list) (,reader index))))) (defun ,tname (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type list data) (type (function (,type) t) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-buffer-input (reply-buffer :sizes (,size) :index index) (do* ((j nitems (index- j 1)) (list (nthcdr start data) (cdr list)) (index 0 (index+ index ,step))) ((index-zerop j)) (declare (type array-index index j) (type list list)) (setf (car list) (funcall transform (,reader index)))))))) (define-list-readers (read-list-card8 read-list-card8-with-transform) card8 8 1 read-card8) #-lispm (defun read-simple-array-card8 (reply-buffer nitems data start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type (simple-array card8 (*)) data)) (with-vector (data (simple-array card8 (*))) (with-buffer-input (reply-buffer :sizes (8)) (buffer-replace data buffer-bbuf start (index+ start nitems) index)))) #-lispm (defun read-simple-array-card8-with-transform (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type (simple-array card8 (*)) data)) (declare (type (function (card8) card8) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data (simple-array card8 (*))) (with-buffer-input (reply-buffer :sizes (8) :index index) (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 1))) ((index>= j end)) (declare (type array-index j end index)) (setf (aref data j) (the card8 (funcall transform (read-card8 index)))))))) (defun read-vector-card8 (reply-buffer nitems data start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type vector data) (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (8) :index index) (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 1))) ((index>= j end)) (declare (type array-index j end index)) (setf (aref data j) (read-card8 index)))))) (defun read-vector-card8-with-transform (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type vector data) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (card8) t) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (8) :index index) (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 1))) ((index>= j end)) (declare (type array-index j end index)) (setf (aref data j) (funcall transform (read-card8 index))))))) (defmacro define-sequence-reader (name type (list tlist) (sa tsa) (vec tvec)) `(defun ,name (reply-buffer result-type nitems &optional transform data (start 0) (index 0)) (declare (type reply-buffer reply-buffer) (type t result-type) (type array-index nitems start index) (type (or null sequence) data) (type (or null (function (,type) t)) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (let ((result (or data (make-sequence result-type nitems)))) (typecase result (list (if transform (,tlist reply-buffer nitems result transform start index) (,list reply-buffer nitems result start index))) #-lispm ((simple-array ,type (*)) (if transform (,tsa reply-buffer nitems result transform start index) (,sa reply-buffer nitems result start index))) ;; FIXME: general sequences (t (if transform (,tvec reply-buffer nitems result transform start index) (,vec reply-buffer nitems result start index)))) result))) (define-sequence-reader read-sequence-card8 card8 (read-list-card8 read-list-card8-with-transform) (read-simple-array-card8 read-simple-array-card8-with-transform) (read-vector-card8 read-vector-card8-with-transform)) (define-transformed-sequence-reader read-sequence-int8 int8 card8->int8 read-sequence-card8) ;;; Reading sequences of card16's (define-list-readers (read-list-card16 read-list-card16-with-transform) card16 16 2 read-card16) #-lispm (defun read-simple-array-card16 (reply-buffer nitems data start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type (simple-array card16 (*)) data)) (with-vector (data (simple-array card16 (*))) (with-buffer-input (reply-buffer :sizes (16) :index index) #-clx-overlapping-arrays (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 2))) ((index>= j end)) (declare (type array-index j end index)) (setf (aref data j) (the card16 (read-card16 index)))) #+clx-overlapping-arrays (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2))))) #-lispm (defun read-simple-array-card16-with-transform (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type (simple-array card16 (*)) data)) (declare (type (function (card16) card16) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data (simple-array card16 (*))) (with-buffer-input (reply-buffer :sizes (16) :index index) (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 2))) ((index>= j end)) (declare (type array-index j end index)) (setf (aref data j) (the card16 (funcall transform (read-card16 index)))))))) (defun read-vector-card16 (reply-buffer nitems data start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type vector data) (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (16) :index index) #-clx-overlapping-arrays (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 2))) ((index>= j end)) (declare (type array-index j end index)) (setf (aref data j) (read-card16 index))) #+clx-overlapping-arrays (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2))))) (defun read-vector-card16-with-transform (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type vector data) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (card16) t) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (16) :index index) (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 2))) ((index>= j end)) (declare (type array-index j end index)) (setf (aref data j) (funcall transform (read-card16 index))))))) (define-sequence-reader read-sequence-card16 card16 (read-list-card16 read-list-card16-with-transform) (read-simple-array-card16 read-simple-array-card16-with-transform) (read-vector-card16 read-vector-card16-with-transform)) (define-transformed-sequence-reader read-sequence-int16 int16 card16->int16 read-sequence-card16) ;;; Reading sequences of card32's (define-list-readers (read-list-card32 read-list-card32-with-transform) card32 32 4 read-card32) #-lispm (defun read-simple-array-card32 (reply-buffer nitems data start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type (simple-array card32 (*)) data)) (with-vector (data (simple-array card32 (*))) (with-buffer-input (reply-buffer :sizes (32) :index index) #-clx-overlapping-arrays (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 4))) ((index>= j end)) (declare (type array-index j end index)) (setf (aref data j) (the card32 (read-card32 index)))) #+clx-overlapping-arrays (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4))))) #-lispm (defun read-simple-array-card32-with-transform (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type (simple-array card32 (*)) data)) (declare (type (function (card32) card32) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data (simple-array card32 (*))) (with-buffer-input (reply-buffer :sizes (32) :index index) (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 4))) ((index>= j end)) (declare (type array-index j end index)) (setf (aref data j) (the card32 (funcall transform (read-card32 index)))))))) (defun read-vector-card32 (reply-buffer nitems data start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type vector data) (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (32) :index index) #-clx-overlapping-arrays (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 4))) ((index>= j end)) (declare (type array-index j end index)) (setf (aref data j) (read-card32 index))) #+clx-overlapping-arrays (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4))))) (defun read-vector-card32-with-transform (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type vector data) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (card32) t) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (32) :index index) (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 4))) ((index>= j end)) (declare (type array-index j end index)) (setf (aref data j) (funcall transform (read-card32 index))))))) (define-sequence-reader read-sequence-card32 card32 (read-list-card32 read-list-card32-with-transform) (read-simple-array-card32 read-simple-array-card32-with-transform) (read-vector-card32 read-vector-card32-with-transform)) (define-transformed-sequence-reader read-sequence-int32 int32 card32->int32 read-sequence-card32) ;;; Writing sequences of chars (defmacro define-transformed-sequence-writer (name fromtype transformer writer) (let ((ntrans (gensym))) `(defun ,name (buffer boffset data &optional (start 0) (end (length data)) transform) (declare (type buffer buffer) (type sequence data) (type array-index boffset start end) (type (or null (function (t) ,fromtype)) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (if transform (flet ((,ntrans (x) (,transformer (the ,fromtype (funcall transform x))))) #+clx-ansi-common-lisp (declare (dynamic-extent #',ntrans)) (,writer buffer boffset data start end #',ntrans)) (,writer buffer boffset data start end #',transformer))))) (define-transformed-sequence-writer write-sequence-char character char->card8 write-sequence-card8) ;;; Writing sequences of card8's (defmacro define-list-writers ((name tname) type step writer) `(progn (defun ,name (buffer boffset data start end) (declare (type buffer buffer) (type list data) (type array-index boffset start end)) (writing-buffer-chunks ,type ((list (nthcdr start data))) ((type list list)) (do ((j 0 (index+ j ,step))) ((index>= j chunk)) (declare (type array-index j)) (,writer j (pop list))))) (defun ,tname (buffer boffset data start end transform) (declare (type buffer buffer) (type list data) (type array-index boffset start end) (type (function (t) ,type) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (writing-buffer-chunks ,type ((list (nthcdr start data))) ((type list list)) (do ((j 0 (index+ j ,step))) ((index>= j chunk)) (declare (type array-index j)) (,writer j (funcall transform (pop list)))))))) ;;; original CLX comment: "TI Compiler bug", in WRITE-LIST-CARD8 #+ti (progn (defun write-list-card8 (buffer boffset data start end) (writing-buffer-chunks card8 ((list (nthcdr start data))) ((type list list)) (dotimes (j chunk) (setf (aref buffer-bbuf (index+ buffer-boffset j)) (pop list))))) (defun write-list-card8-with-transform (buffer boffset data start end transform) (writing-buffer-chunks card8 ((list (nthcdr start data))) ((type list lst)) (dotimes (j chunk) (declare (type array-index j)) (write-card8 j (funcall transform (pop lst))))))) #-ti (define-list-writers (write-list-card8 write-list-card8-with-transform) card8 1 write-card8) ;;; Should really write directly from data, instead of into the buffer first #-lispm (defun write-simple-array-card8 (buffer boffset data start end) (declare (type buffer buffer) (type (simple-array card8 (*)) data) (type array-index boffset start end)) (with-vector (data (simple-array card8 (*))) (writing-buffer-chunks card8 ((index start (index+ index chunk))) ((type array-index index)) (buffer-replace buffer-bbuf data buffer-boffset (index+ buffer-boffset chunk) index))) nil) #-lispm (defun write-simple-array-card8-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type (simple-array card8 (*)) data) (type array-index boffset start end)) (declare (type (function (card8) card8) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data (simple-array card8 (*))) (writing-buffer-chunks card8 ((index start)) ((type array-index index)) (dotimes (j chunk) (declare (type array-index j)) (write-card8 j (funcall transform (aref data index))) (setq index (index+ index 1))))) nil) (defun write-vector-card8 (buffer boffset data start end) (declare (type buffer buffer) (type vector data) (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (writing-buffer-chunks card8 ((index start)) ((type array-index index)) (dotimes (j chunk) (declare (type array-index j)) (write-card8 j (aref data index)) (setq index (index+ index 1))))) nil) (defun write-vector-card8-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type vector data) (type array-index boffset start end)) (declare (type (function (t) card8) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data vector) (writing-buffer-chunks card8 ((index start)) ((type array-index index)) (dotimes (j chunk) (declare (type array-index j)) (write-card8 j (funcall transform (aref data index))) (setq index (index+ index 1))))) nil) (defmacro define-sequence-writer (name type (list tlist) (sa tsa) (vec tvec)) `(defun ,name (buffer boffset data &optional (start 0) (end (length data)) transform) (declare (type buffer buffer) (type sequence data) (type array-index boffset start end) (type (or null (function (t) ,type)) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (typecase data (list (if transform (,tlist buffer boffset data start end transform) (,list buffer boffset data start end))) #-lispm ((simple-array ,type (*)) (if transform (,tsa buffer boffset data start end transform) (,sa buffer boffset data start end))) (t ; FIXME: general sequences (if transform (,tvec buffer boffset data start end transform) (,vec buffer boffset data start end)))))) (define-sequence-writer write-sequence-card8 card8 (write-list-card8 write-list-card8-with-transform) (write-simple-array-card8 write-simple-array-card8-with-transform) (write-vector-card8 write-vector-card8-with-transform)) (define-transformed-sequence-writer write-sequence-int8 int8 int8->card8 write-sequence-card8) ;;; Writing sequences of card16's (define-list-writers (write-list-card16 write-list-card16-with-transform) card16 2 write-card16) #-lispm (defun write-simple-array-card16 (buffer boffset data start end) (declare (type buffer buffer) (type (simple-array card16 (*)) data) (type array-index boffset start end)) (with-vector (data (simple-array card16 (*))) (writing-buffer-chunks card16 ((index start)) ((type array-index index)) ;; Depends upon the chunks being an even multiple of card16's big (do ((j 0 (index+ j 2))) ((index>= j chunk)) (declare (type array-index j)) (write-card16 j (aref data index)) (setq index (index+ index 1))) ;; overlapping case (let ((length (floor chunk 2))) (buffer-replace buffer-wbuf data buffer-woffset (index+ buffer-woffset length) index) (setq index (index+ index length))))) nil) #-lispm (defun write-simple-array-card16-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type (simple-array card16 (*)) data) (type array-index boffset start end)) (declare (type (function (card16) card16) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data (simple-array card16 (*))) (writing-buffer-chunks card16 ((index start)) ((type array-index index)) ;; Depends upon the chunks being an even multiple of card16's big (do ((j 0 (index+ j 2))) ((index>= j chunk)) (declare (type array-index j)) (write-card16 j (funcall transform (aref data index))) (setq index (index+ index 1))))) nil) (defun write-vector-card16 (buffer boffset data start end) (declare (type buffer buffer) (type vector data) (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (writing-buffer-chunks card16 ((index start)) ((type array-index index)) ;; Depends upon the chunks being an even multiple of card16's big (do ((j 0 (index+ j 2))) ((index>= j chunk)) (declare (type array-index j)) (write-card16 j (aref data index)) (setq index (index+ index 1))) ;; overlapping case (let ((length (floor chunk 2))) (buffer-replace buffer-wbuf data buffer-woffset (index+ buffer-woffset length) index) (setq index (index+ index length))))) nil) (defun write-vector-card16-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type vector data) (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (t) card16) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data vector) (writing-buffer-chunks card16 ((index start)) ((type array-index index)) ;; Depends upon the chunks being an even multiple of card16's big (do ((j 0 (index+ j 2))) ((index>= j chunk)) (declare (type array-index j)) (write-card16 j (funcall transform (aref data index))) (setq index (index+ index 1))))) nil) (define-sequence-writer write-sequence-card16 card16 (write-list-card16 write-list-card16-with-transform) (write-simple-array-card16 write-simple-array-card16-with-transform) (write-vector-card16 write-vector-card16-with-transform)) ;;; Writing sequences of int16's (define-list-writers (write-list-int16 write-list-int16-with-transform) int16 2 write-int16) #-lispm (defun write-simple-array-int16 (buffer boffset data start end) (declare (type buffer buffer) (type (simple-array int16 (*)) data) (type array-index boffset start end)) (with-vector (data (simple-array int16 (*))) (writing-buffer-chunks int16 ((index start)) ((type array-index index)) ;; Depends upon the chunks being an even multiple of int16's big (do ((j 0 (index+ j 2))) ((index>= j chunk)) (declare (type array-index j)) (write-int16 j (aref data index)) (setq index (index+ index 1))) ;; overlapping case (let ((length (floor chunk 2))) (buffer-replace buffer-wbuf data buffer-woffset (index+ buffer-woffset length) index) (setq index (index+ index length))))) nil) #-lispm (defun write-simple-array-int16-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type (simple-array int16 (*)) data) (type array-index boffset start end)) (declare (type (function (int16) int16) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data (simple-array int16 (*))) (writing-buffer-chunks int16 ((index start)) ((type array-index index)) ;; Depends upon the chunks being an even multiple of int16's big (do ((j 0 (index+ j 2))) ((index>= j chunk)) (declare (type array-index j)) (write-int16 j (funcall transform (aref data index))) (setq index (index+ index 1))))) nil) (defun write-vector-int16 (buffer boffset data start end) (declare (type buffer buffer) (type vector data) (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (writing-buffer-chunks int16 ((index start)) ((type array-index index)) ;; Depends upon the chunks being an even multiple of int16's big (do ((j 0 (index+ j 2))) ((index>= j chunk)) (declare (type array-index j)) (write-int16 j (aref data index)) (setq index (index+ index 1))) ;; overlapping case (let ((length (floor chunk 2))) (buffer-replace buffer-wbuf data buffer-woffset (index+ buffer-woffset length) index) (setq index (index+ index length))))) nil) (defun write-vector-int16-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type vector data) (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (t) int16) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data vector) (writing-buffer-chunks int16 ((index start)) ((type array-index index)) ;; Depends upon the chunks being an even multiple of int16's big (do ((j 0 (index+ j 2))) ((index>= j chunk)) (declare (type array-index j)) (write-int16 j (funcall transform (aref data index))) (setq index (index+ index 1))))) nil) (define-sequence-writer write-sequence-int16 int16 (write-list-int16 write-list-int16-with-transform) (write-simple-array-int16 write-simple-array-int16-with-transform) (write-vector-int16 write-vector-int16-with-transform)) ;;; Writing sequences of card32's (define-list-writers (write-list-card32 write-list-card32-with-transform) card32 4 write-card32) #-lispm (defun write-simple-array-card32 (buffer boffset data start end) (declare (type buffer buffer) (type (simple-array card32 (*)) data) (type array-index boffset start end)) (with-vector (data (simple-array card32 (*))) (writing-buffer-chunks card32 ((index start)) ((type array-index index)) ;; Depends upon the chunks being an even multiple of card32's big (do ((j 0 (index+ j 4))) ((index>= j chunk)) (declare (type array-index j)) (write-card32 j (aref data index)) (setq index (index+ index 1))) ;; overlapping case (let ((length (floor chunk 4))) (buffer-replace buffer-lbuf data buffer-loffset (index+ buffer-loffset length) index) (setq index (index+ index length))))) nil) #-lispm (defun write-simple-array-card32-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type (simple-array card32 (*)) data) (type array-index boffset start end)) (declare (type (function (card32) card32) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data (simple-array card32 (*))) (writing-buffer-chunks card32 ((index start)) ((type array-index index)) ;; Depends upon the chunks being an even multiple of card32's big (do ((j 0 (index+ j 4))) ((index>= j chunk)) (declare (type array-index j)) (write-card32 j (funcall transform (aref data index))) (setq index (index+ index 1))))) nil) (defun write-vector-card32 (buffer boffset data start end) (declare (type buffer buffer) (type vector data) (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (writing-buffer-chunks card32 ((index start)) ((type array-index index)) ;; Depends upon the chunks being an even multiple of card32's big (do ((j 0 (index+ j 4))) ((index>= j chunk)) (declare (type array-index j)) (write-card32 j (aref data index)) (setq index (index+ index 1))) ;; overlapping case (let ((length (floor chunk 4))) (buffer-replace buffer-lbuf data buffer-loffset (index+ buffer-loffset length) index) (setq index (index+ index length))))) nil) (defun write-vector-card32-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type vector data) (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (t) card32) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data vector) (writing-buffer-chunks card32 ((index start)) ((type array-index index)) ;; Depends upon the chunks being an even multiple of card32's big (do ((j 0 (index+ j 4))) ((index>= j chunk)) (declare (type array-index j)) (write-card32 j (funcall transform (aref data index))) (setq index (index+ index 1))))) nil) (define-sequence-writer write-sequence-card32 card32 (write-list-card32 write-list-card32-with-transform) (write-simple-array-card32 write-simple-array-card32-with-transform) (write-vector-card32 write-vector-card32-with-transform)) (define-transformed-sequence-writer write-sequence-int32 int32 int32->card32 write-sequence-card32) (defun read-bitvector256 (buffer-bbuf boffset data) (declare (type buffer-bytes buffer-bbuf) (type array-index boffset) (type (or null (simple-bit-vector 256)) data)) (let ((result (or data (make-array 256 :element-type 'bit :initial-element 0)))) (declare (type (simple-bit-vector 256) result)) (do ((i (index+ boffset 1) (index+ i 1)) ;; Skip first byte (j 8 (index+ j 8))) ((index>= j 256)) (declare (type array-index i j)) (do ((byte (aref-card8 buffer-bbuf i) (index-ash byte -1)) (k j (index+ k 1))) ((zerop byte) (when data ;; Clear uninitialized bits in data (do ((end (index+ j 8))) ((index= k end)) (declare (type array-index end)) (setf (aref result k) 0) (index-incf k)))) (declare (type array-index k) (type card8 byte)) (setf (aref result k) (the bit (logand byte 1))))) result)) (defun write-bitvector256 (buffer boffset map) (declare (type buffer buffer) (type array-index boffset) (type (simple-array bit (*)) map)) (with-buffer-output (buffer :index boffset :sizes 8) (do* ((i (index+ buffer-boffset 1) (index+ i 1)) ; Skip first byte (j 8 (index+ j 8))) ((index>= j 256)) (declare (type array-index i j)) (do ((byte 0) (bit (index+ j 7) (index- bit 1))) ((index< bit j) (aset-card8 byte buffer-bbuf i)) (declare (type array-index bit) (type card8 byte)) (setq byte (the card8 (logior (the card8 (ash byte 1)) (aref map bit)))))))) ;;; Writing sequences of char2b's (define-list-writers (write-list-char2b write-list-char2b-with-transform) card16 2 write-char2b) #-lispm (defun write-simple-array-char2b (buffer boffset data start end) (declare (type buffer buffer) (type (simple-array card16 (*)) data) (type array-index boffset start end)) (with-vector (data (simple-array card16 (*))) (writing-buffer-chunks card16 ((index start)) ((type array-index index)) (do ((j 0 (index+ j 2))) ((index>= j (1- chunk)) (setf chunk j)) (declare (type array-index j)) (write-char2b j (aref data index)) (setq index (index+ index 1))))) nil) #-lispm (defun write-simple-array-char2b-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type (simple-array card16 (*)) data) (type array-index boffset start end)) (declare (type (function (card16) card16) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data (simple-array card16 (*))) (writing-buffer-chunks card16 ((index start)) ((type array-index index)) (do ((j 0 (index+ j 2))) ((index>= j (1- chunk)) (setf chunk j)) (declare (type array-index j)) (write-char2b j (funcall transform (aref data index))) (setq index (index+ index 1))))) nil) (defun write-vector-char2b (buffer boffset data start end) (declare (type buffer buffer) (type vector data) (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (writing-buffer-chunks card16 ((index start)) ((type array-index index)) (do ((j 0 (index+ j 2))) ((index>= j (1- chunk)) (setf chunk j)) (declare (type array-index j)) (write-char2b j (aref data index)) (setq index (index+ index 1))))) nil) (defun write-vector-char2b-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type vector data) (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (t) card16) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data vector) (writing-buffer-chunks card16 ((index start)) ((type array-index index)) (do ((j 0 (index+ j 2))) ((index>= j (1- chunk)) (setf chunk j)) (declare (type array-index j)) (write-char2b j (funcall transform (aref data index))) (setq index (index+ index 1))))) nil) (define-sequence-writer write-sequence-char2b card16 (write-list-char2b write-list-char2b-with-transform) (write-simple-array-char2b write-simple-array-char2b-with-transform) (write-vector-char2b write-vector-char2b-with-transform)) cl-clx-sbcl-0.7.4.20160323.orig/NEWS0000644000175000017500000001334712715665271014330 0ustar pdmpdm-*- Text -*- -- Changes in telent CLX 0.7.3, Tue Mar 28 2006 --- Support for Allegro CL (6.2 and later) (Mikel Evins) Latin 1 keysyms (Christophe Rhodes) Some protocol fixes (Douglas Crosher) Define a RENDER-OP typ (Douglas Crosher) --- Changes in SBCL CLX 0.7.2, Tue Jan 10 2006 --- OpenMCL fixes DPMS extension support Xauthority ipv6 parsing fixes Thanks to Bryan O'Connor, Matthew Kennedy, Christophe Rhodes --- Changes in SBCL CLX 0.7.1, Wed Aug 24 2005 --- Works in SBCL 0.9.2 and newer. --- Changes in SBCL CLX 0.7.0, Sun May 1 2005 --- The SBCL support now depends on version 0.9.0 or greater. --- Changes in SBCL CLX 0.6.1, Mon Mar 28 2005 --- experimental GLX extension support (from Janis Dzerins) The ICCCM-compliant selection handling in demo/clipboard.lisp is now more ICCCM-compliant. The implementation of the RENDER client protocol has been enhanced. (Gilbert Baumann) Bug fix: CIRCULATE-NOTIFY, CIRCULATE-REQUEST and PROPERTY-NOTIFY input event descriptions have been fixed. --- Changes in SBCL CLX 0.6, Tue Nov 16 2004 --- A port to ECL has been merged (Juan Jose Garcia Ripoll) With the addition of an implementation of DYNAMIC-EXTENT &REST lists to SBCL, various functions (e.g. READ-INPUT, QUEUE-EVENT) in CLX should cons less. A Texinfo version of the CLX manual has been added (in manual/), thanks to the work of Gilbert Baumann and Shawn Betts. The portable-clx mailing list has been created for development discussion and bug reports. See http://lists.metacircles.com/cgi-bin/mailman/listinfo/portable-clx A demonstration of ICCCM-compliant selection handling for select and paste has been included in demo/clipboard.lisp Bug fix: change the sizes of certain fields in a WM-SIZE-HINT to be 32 bits wide, as per the ICCCM specifications. Fixes a problem seen with the MacOS X11 window manger, that uses very large hint values. (Patch from Eric Marsden) Bug fix: +POINTER-EVENT-MASK-VECTOR+ is supposed to be a vector of keywords. It wasn't, but it is now. (Milan Zamazal) Bug fix: xrender now compiles properly when *DEF-CLX-CLASS-USE-DEFCLASS* (Milan again) --- Changes in SBCL CLX 0.5.4, Tue Nov 11 00:02:43 2003 --- A change in the implementation of PROCESS-BLOCK and PROCESS-WAKEUP under multithreaded SBCL. Previous versions used queues and condition variables, but this seems to have undesireable performance characteristics; the newer version uses a polling loop calling sched_yield() inside, which greatly improves responsiveness, but is more CPU-hungry (as perceived by top(1), at least; in theory it only hogs the CPU when nobody else wants it). --- Changes in SBCL CLX 0.5.3, Sat Sep 6 12:14:39 UTC 2003 --- We allow a PIXMAP-DEPTH of 12 in clx.lisp, despite not having any image routines for it, to allow clx to load when running under eXceed. Image routines are unlikely to work in such circumstances. Bug fixes * ERROR idiom (xvidmode.lisp) * Add timestamp in NEWS file --- Changes in SBCL CLX 0.5.2, about twenty minutes before 0.5.3 --- OPEN-DEFAULT-DISPLAY now takes an optional argument for the display name, which has the same "protocol/host:display.screen" format as used by the C libX11 (XOpenDisplay). OPEN-DISPLAY is not actively deprecated, but is much less useful by comparison Inclusion of two new tests/demos (from Ingvar Mattson): * demo/clclock: a simple clock application; * demo/mandel: a Mandelbrot set viewer. Bug fixes * Fix bad type declarations in TEXT-EXTENTS-SERVER and TEXT-WIDTH-SERVER (text.lisp) * Fix FORMAT argument mismatch error in WRITE-BITMAP-FILE (image.lisp) --- Changes in SBCL CLX 0.5.1, Wed Jun 25 14:20:31 BST 2003 --- experimental RENDER extension support (from Gilbert Baumann) note: the API to this is as yet unfinalized, as indeed the protocol and specification appear to be in flux. Nevertheless, feedback is welcome to the portable-clx-devel mailing list. Bug fixes * fix bugs in the image test: always draw glyphs in white on black (not 1 on 0 -- i.e. dark red/blue on black in 24 bit truecolour); don't abuse the X-HOT and Y-HOT slots for communicating persistent information any more. * Disable the "optimized" pixarray read/write routines, on the basis that the newly fixed image test reveals that they are broken. * fix type bugs in DEFINE-GCONTEXT-ACCESSOR, which previously signalled a type error if :COPY-FUNCTION was not provided, and a different type error if it was. Other notes * we use the SBCL extensions to the condition system to customize compiler behaviour. As such, the system will only build without breaking into the debugger using the supplied .asd, as we inhibit error signalling from DEFCONSTANT; the benefits of this are easier code sharing, as we minimize divergence within the clx source proper from other implementations. * we also use an SBCL extension to maximize efficiency: we set SB-EXT:*DERIVE-FUNCTION-TYPES* to true for the duration of the compilation of the clx library. Should functions in CLX be redefined in a type-incompatible way, their callers in CLX (but not outside) will need to be recompiled. --- Changes in SBCL CLX 0.5, Fri May 30 01:16:34 BST 2003 --- XFree86-VidModeExtension extension support (courtesy of Iban Hatchondo) OPEN-DEFAULT-DISPLAY (opens display in $DISPLAY environment variable) exported Implement CLX MP dependencies for SBCL: HOLDING-LOCK, PROCESS-BLOCK, etc Many bug fixes * asking for text extents on unchached fonts could potentially deadlock http://article.gmane.org/gmane.lisp.clx.devel/16 * lots of compiler warnings, style-warnings, notes cleared up Style and ANSI cleanups * Much renaming of constants from *foo* to +foo+ * Change old-style COMPILE LOAD EVAL to new-style :COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE in EVAL-WHENs. cl-clx-sbcl-0.7.4.20160323.orig/image.lisp0000644000175000017500000031062612715665272015605 0ustar pdmpdm;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- ;;; CLX Image functions ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (in-package :xlib) (defmacro with-image-data-buffer ((buffer size) &body body) (declare (indentation 0 4 1 1)) `(let ((.reply-buffer. (allocate-reply-buffer ,size))) (declare (type reply-buffer .reply-buffer.)) (unwind-protect (let ((,buffer (reply-ibuf8 .reply-buffer.))) (declare (type buffer-bytes ,buffer)) (with-vector (,buffer buffer-bytes) ,@body)) (deallocate-reply-buffer .reply-buffer.)))) (def-clx-class (image (:constructor nil) (:copier nil) (:predicate nil)) ;; Public structure (width 0 :type card16 :read-only t) (height 0 :type card16 :read-only t) (depth 1 :type card8 :read-only t) (plist nil :type list)) ;; Image-Plist accessors: (defmacro image-name (image) `(getf (image-plist ,image) :name)) (defmacro image-x-hot (image) `(getf (image-plist ,image) :x-hot)) (defmacro image-y-hot (image) `(getf (image-plist ,image) :y-hot)) (defmacro image-red-mask (image) `(getf (image-plist ,image) :red-mask)) (defmacro image-blue-mask (image) `(getf (image-plist ,image) :blue-mask)) (defmacro image-green-mask (image) `(getf (image-plist ,image) :green-mask)) (defun print-image (image stream depth) (declare (type image image) (ignore depth)) (print-unreadable-object (image stream :type t) (when (image-name image) (write-string (string (image-name image)) stream) (write-string " " stream)) (prin1 (image-width image) stream) (write-string "x" stream) (prin1 (image-height image) stream) (write-string "x" stream) (prin1 (image-depth image) stream))) (defconstant +empty-data-x+ '#.(make-sequence '(array card8 (*)) 0)) (defconstant +empty-data-z+ '#.(make-array '(0 0) :element-type 'pixarray-1-element-type)) (def-clx-class (image-x (:include image) (:copier nil) (:print-function print-image)) ;; Use this format for shoveling image data ;; Private structure. Accessors for these NOT exported. (format :z-pixmap :type (member :bitmap :xy-pixmap :z-pixmap)) (bytes-per-line 0 :type card16) (bits-per-pixel 1 :type (member 1 4 8 16 24 32)) (bit-lsb-first-p +image-bit-lsb-first-p+ :type generalized-boolean) ; Bit order (byte-lsb-first-p +image-byte-lsb-first-p+ :type generalized-boolean) ; Byte order (data +empty-data-x+ :type (array card8 (*))) ; row-major (unit +image-unit+ :type (member 8 16 32)) ; Bitmap unit (pad +image-pad+ :type (member 8 16 32)) ; Scanline pad (left-pad 0 :type card8)) ; Left pad (def-clx-class (image-xy (:include image) (:copier nil) (:print-function print-image)) ;; Public structure ;; Use this format for image processing (bitmap-list nil :type list)) ;; list of bitmaps (def-clx-class (image-z (:include image) (:copier nil) (:print-function print-image)) ;; Public structure ;; Use this format for image processing (bits-per-pixel 1 :type (member 1 4 8 16 24 32)) (pixarray +empty-data-z+ :type pixarray)) (defun create-image (&key width height depth (data (required-arg data)) plist name x-hot y-hot red-mask blue-mask green-mask bits-per-pixel format bytes-per-line (byte-lsb-first-p #+clx-little-endian t #-clx-little-endian nil) (bit-lsb-first-p #+clx-little-endian t #-clx-little-endian nil) unit pad left-pad) ;; Returns an image-x image-xy or image-z structure, depending on the ;; type of the :DATA parameter. (declare (type (or null card16) width height) ; Required (type (or null card8) depth) ; Defualts to 1 (type (or buffer-bytes ; Returns image-x list ; Returns image-xy pixarray) data) ; Returns image-z (type list plist) (type (or null stringable) name) (type (or null card16) x-hot y-hot) (type (or null pixel) red-mask blue-mask green-mask) (type (or null (member 1 4 8 16 24 32)) bits-per-pixel) ;; The following parameters are ignored for image-xy and image-z: (type (or null (member :bitmap :xy-pixmap :z-pixmap)) format) ; defaults to :z-pixmap (type (or null card16) bytes-per-line) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) (type (or null (member 8 16 32)) unit pad) (type (or null card8) left-pad)) (declare (clx-values image)) (let ((image (etypecase data (buffer-bytes ; image-x (let ((data data)) (declare (type buffer-bytes data)) (unless depth (setq depth (or bits-per-pixel 1))) (unless format (setq format (if (= depth 1) :xy-pixmap :z-pixmap))) (unless bits-per-pixel (setq bits-per-pixel (cond ((eq format :xy-pixmap) 1) ((index> depth 24) 32) ((index> depth 16) 24) ((index> depth 8) 16) ((index> depth 4) 8) ((index> depth 1) 4) (t 1)))) (unless width (required-arg width)) (unless height (required-arg height)) (unless bytes-per-line (let* ((pad (or pad 8)) (bits-per-line (index* width bits-per-pixel)) (padded-bits-per-line (index* (index-ceiling bits-per-line pad) pad))) (declare (type array-index pad bits-per-line padded-bits-per-line)) (setq bytes-per-line (index-ceiling padded-bits-per-line 8)))) (unless unit (setq unit +image-unit+)) (unless pad (setq pad (dolist (pad '(32 16 8)) (when (and (index<= pad +image-pad+) (zerop (index-mod (index* bytes-per-line 8) pad))) (return pad))))) (unless left-pad (setq left-pad 0)) (make-image-x :width width :height height :depth depth :plist plist :format format :data data :bits-per-pixel bits-per-pixel :bytes-per-line bytes-per-line :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p :unit unit :pad pad :left-pad left-pad))) (list ; image-xy (let ((data data)) (declare (type list data)) (unless depth (setq depth (length data))) (when data (unless width (setq width (array-dimension (car data) 1))) (unless height (setq height (array-dimension (car data) 0)))) (make-image-xy :width width :height height :plist plist :depth depth :bitmap-list data))) (pixarray ; image-z (let ((data data)) (declare (type pixarray data)) (unless width (setq width (array-dimension data 1))) (unless height (setq height (array-dimension data 0))) (unless bits-per-pixel (setq bits-per-pixel (etypecase data (pixarray-32 32) (pixarray-24 24) (pixarray-16 16) (pixarray-8 8) (pixarray-4 4) (pixarray-1 1))))) (unless depth (setq depth bits-per-pixel)) (make-image-z :width width :height height :depth depth :plist plist :bits-per-pixel bits-per-pixel :pixarray data))))) (declare (type image image)) (when name (setf (image-name image) name)) (when x-hot (setf (image-x-hot image) x-hot)) (when y-hot (setf (image-y-hot image) y-hot)) (when red-mask (setf (image-red-mask image) red-mask)) (when blue-mask (setf (image-blue-mask image) blue-mask)) (when green-mask (setf (image-green-mask image) green-mask)) image)) ;;;----------------------------------------------------------------------------- ;;; Swapping stuff (defun image-noswap (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) (type array-index srcoff destoff srclen srcinc destinc) (type card16 height) (type generalized-boolean lsb-first-p) (ignore lsb-first-p)) #.(declare-buffun) (if (index= srcinc destinc) (buffer-replace dest src destoff (index+ destoff (index* srcinc (index1- height)) srclen) srcoff) (do* ((h height (index1- h)) (srcstart srcoff (index+ srcstart srcinc)) (deststart destoff (index+ deststart destinc)) (destend (index+ deststart srclen) (index+ deststart srclen))) ((index-zerop h)) (declare (type array-index srcstart deststart destend) (type card16 h)) (buffer-replace dest src deststart destend srcstart)))) (defun image-swap-two-bytes (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) (type array-index srcoff destoff srclen srcinc destinc) (type card16 height) (type generalized-boolean lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (do ((length (index* (index-ceiling srclen 2) 2)) (h height (index1- h)) (srcstart srcoff (index+ srcstart srcinc)) (deststart destoff (index+ deststart destinc))) ((index-zerop h)) (declare (type array-index length srcstart deststart) (type card16 h)) (when (and (index= h 1) (not (index= srclen length))) (index-decf length 2) (if lsb-first-p (setf (aref dest (index1+ (index+ deststart length))) (the card8 (aref src (index+ srcstart length)))) (setf (aref dest (index+ deststart length)) (the card8 (aref src (index1+ (index+ srcstart length))))))) (do ((i length (index- i 2)) (srcidx srcstart (index+ srcidx 2)) (destidx deststart (index+ destidx 2))) ((index-zerop i)) (declare (type array-index i srcidx destidx)) (setf (aref dest destidx) (the card8 (aref src (index1+ srcidx)))) (setf (aref dest (index1+ destidx)) (the card8 (aref src srcidx)))))))) (defun image-swap-three-bytes (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) (type array-index srcoff destoff srclen srcinc destinc) (type card16 height) (type generalized-boolean lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (do ((length (index* (index-ceiling srclen 3) 3)) (h height (index1- h)) (srcstart srcoff (index+ srcstart srcinc)) (deststart destoff (index+ deststart destinc))) ((index-zerop h)) (declare (type array-index length srcstart deststart) (type card16 h)) (when (and (index= h 1) (not (index= srclen length))) (index-decf length 3) (when (index= (index- srclen length) 2) (setf (aref dest (index+ deststart length 1)) (the card8 (aref src (index+ srcstart length 1))))) (if lsb-first-p (setf (aref dest (index+ deststart length 2)) (the card8 (aref src (index+ srcstart length)))) (setf (aref dest (index+ deststart length)) (the card8 (aref src (index+ srcstart length 2)))))) (do ((i length (index- i 3)) (srcidx srcstart (index+ srcidx 3)) (destidx deststart (index+ destidx 3))) ((index-zerop i)) (declare (type array-index i srcidx destidx)) (setf (aref dest destidx) (the card8 (aref src (index+ srcidx 2)))) (setf (aref dest (index1+ destidx)) (the card8 (aref src (index1+ srcidx)))) (setf (aref dest (index+ destidx 2)) (the card8 (aref src srcidx)))))))) (defun image-swap-four-bytes (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) (type array-index srcoff destoff srclen srcinc destinc) (type card16 height) (type generalized-boolean lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (do ((length (index* (index-ceiling srclen 4) 4)) (h height (index1- h)) (srcstart srcoff (index+ srcstart srcinc)) (deststart destoff (index+ deststart destinc))) ((index-zerop h)) (declare (type array-index length srcstart deststart) (type card16 h)) (when (and (index= h 1) (not (index= srclen length))) (index-decf length 4) (unless lsb-first-p (setf (aref dest (index+ deststart length)) (the card8 (aref src (index+ srcstart length 3))))) (when (if lsb-first-p (index= (index- srclen length) 3) (not (index-zerop (index-logand srclen 2)))) (setf (aref dest (index+ deststart length 1)) (the card8 (aref src (index+ srcstart length 2))))) (when (if (null lsb-first-p) (index= (index- srclen length) 3) (not (index-zerop (index-logand srclen 2)))) (setf (aref dest (index+ deststart length 2)) (the card8 (aref src (index+ srcstart length 1))))) (when lsb-first-p (setf (aref dest (index+ deststart length 3)) (the card8 (aref src (index+ srcstart length)))))) (do ((i length (index- i 4)) (srcidx srcstart (index+ srcidx 4)) (destidx deststart (index+ destidx 4))) ((index-zerop i)) (declare (type array-index i srcidx destidx)) (setf (aref dest destidx) (the card8 (aref src (index+ srcidx 3)))) (setf (aref dest (index1+ destidx)) (the card8 (aref src (index+ srcidx 2)))) (setf (aref dest (index+ destidx 2)) (the card8 (aref src (index1+ srcidx)))) (setf (aref dest (index+ destidx 3)) (the card8 (aref src srcidx)))))))) (defun image-swap-words (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) (type array-index srcoff destoff srclen srcinc destinc) (type card16 height) (type generalized-boolean lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (do ((length (index* (index-ceiling srclen 4) 4)) (h height (index1- h)) (srcstart srcoff (index+ srcstart srcinc)) (deststart destoff (index+ deststart destinc))) ((index-zerop h)) (declare (type array-index length srcstart deststart) (type card16 h)) (when (and (index= h 1) (not (index= srclen length))) (index-decf length 4) (unless lsb-first-p (setf (aref dest (index+ deststart length 1)) (the card8 (aref src (index+ srcstart length 3))))) (when (if lsb-first-p (index= (index- srclen length) 3) (not (index-zerop (index-logand srclen 2)))) (setf (aref dest (index+ deststart length)) (the card8 (aref src (index+ srcstart length 2))))) (when (if (null lsb-first-p) (index= (index- srclen length) 3) (not (index-zerop (index-logand srclen 2)))) (setf (aref dest (index+ deststart length 3)) (the card8 (aref src (index+ srcstart length 1))))) (when lsb-first-p (setf (aref dest (index+ deststart length 2)) (the card8 (aref src (index+ srcstart length)))))) (do ((i length (index- i 4)) (srcidx srcstart (index+ srcidx 4)) (destidx deststart (index+ destidx 4))) ((index-zerop i)) (declare (type array-index i srcidx destidx)) (setf (aref dest destidx) (the card8 (aref src (index+ srcidx 2)))) (setf (aref dest (index1+ destidx)) (the card8 (aref src (index+ srcidx 3)))) (setf (aref dest (index+ destidx 2)) (the card8 (aref src srcidx))) (setf (aref dest (index+ destidx 3)) (the card8 (aref src (index1+ srcidx))))))))) (defun image-swap-nibbles (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) (type array-index srcoff destoff srclen srcinc destinc) (type card16 height) (type generalized-boolean lsb-first-p) (ignore lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (do ((h height (index1- h)) (srcstart srcoff (index+ srcstart srcinc)) (deststart destoff (index+ deststart destinc))) ((index-zerop h)) (declare (type array-index srcstart deststart) (type card16 h)) (do ((i srclen (index1- i)) (srcidx srcstart (index1+ srcidx)) (destidx deststart (index1+ destidx))) ((index-zerop i)) (declare (type array-index i srcidx destidx)) (setf (aref dest destidx) (the card8 (let ((byte (aref src srcidx))) (declare (type card8 byte)) (dpb (the card4 (ldb (byte 4 0) byte)) (byte 4 4) (the card4 (ldb (byte 4 4) byte))))))))))) (defun image-swap-nibbles-left (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) (type array-index srcoff destoff srclen srcinc destinc) (type card16 height) (type generalized-boolean lsb-first-p) (ignore lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (do ((h height (index1- h)) (srcstart srcoff (index+ srcstart srcinc)) (deststart destoff (index+ deststart destinc))) ((index-zerop h)) (declare (type array-index srcstart deststart) (type card16 h)) (do ((i srclen (index1- i)) (srcidx srcstart (index1+ srcidx)) (destidx deststart (index1+ destidx))) ((index= i 1) (setf (aref dest destidx) (the card8 (let ((byte1 (aref src srcidx))) (declare (type card8 byte1)) (dpb (the card4 (ldb (byte 4 0) byte1)) (byte 4 4) 0))))) (declare (type array-index i srcidx destidx)) (setf (aref dest destidx) (the card8 (let ((byte1 (aref src srcidx)) (byte2 (aref src (index1+ srcidx)))) (declare (type card8 byte1 byte2)) (dpb (the card4 (ldb (byte 4 0) byte1)) (byte 4 4) (the card4 (ldb (byte 4 4) byte2))))))))))) (defconstant +image-byte-reverse+ '#.(coerce '#( 0 128 64 192 32 160 96 224 16 144 80 208 48 176 112 240 8 136 72 200 40 168 104 232 24 152 88 216 56 184 120 248 4 132 68 196 36 164 100 228 20 148 84 212 52 180 116 244 12 140 76 204 44 172 108 236 28 156 92 220 60 188 124 252 2 130 66 194 34 162 98 226 18 146 82 210 50 178 114 242 10 138 74 202 42 170 106 234 26 154 90 218 58 186 122 250 6 134 70 198 38 166 102 230 22 150 86 214 54 182 118 246 14 142 78 206 46 174 110 238 30 158 94 222 62 190 126 254 1 129 65 193 33 161 97 225 17 145 81 209 49 177 113 241 9 137 73 201 41 169 105 233 25 153 89 217 57 185 121 249 5 133 69 197 37 165 101 229 21 149 85 213 53 181 117 245 13 141 77 205 45 173 109 237 29 157 93 221 61 189 125 253 3 131 67 195 35 163 99 227 19 147 83 211 51 179 115 243 11 139 75 203 43 171 107 235 27 155 91 219 59 187 123 251 7 135 71 199 39 167 103 231 23 151 87 215 55 183 119 247 15 143 79 207 47 175 111 239 31 159 95 223 63 191 127 255) '(vector card8))) (defun image-swap-bits (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) (type array-index srcoff destoff srclen srcinc destinc) (type card16 height) (type generalized-boolean lsb-first-p) (ignore lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (let ((byte-reverse +image-byte-reverse+)) (with-vector (byte-reverse (simple-array card8 (256))) (macrolet ((br (byte) `(the card8 (aref byte-reverse (the card8 ,byte))))) (do ((h height (index1- h)) (srcstart srcoff (index+ srcstart srcinc)) (deststart destoff (index+ deststart destinc))) ((index-zerop h)) (declare (type array-index srcstart deststart) (type card16 h)) (do ((i srclen (index1- i)) (srcidx srcstart (index1+ srcidx)) (destidx deststart (index1+ destidx))) ((index-zerop i)) (declare (type array-index i srcidx destidx)) (setf (aref dest destidx) (br (aref src srcidx))))))))))) (defun image-swap-bits-and-two-bytes (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) (type array-index srcoff destoff srclen srcinc destinc) (type card16 height) (type generalized-boolean lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (let ((byte-reverse +image-byte-reverse+)) (with-vector (byte-reverse (simple-array card8 (256))) (macrolet ((br (byte) `(the card8 (aref byte-reverse (the card8 ,byte))))) (do ((length (index* (index-ceiling srclen 2) 2)) (h height (index1- h)) (srcstart srcoff (index+ srcstart srcinc)) (deststart destoff (index+ deststart destinc))) ((index-zerop h)) (declare (type array-index length srcstart deststart) (type card16 h)) (when (and (index= h 1) (not (index= srclen length))) (index-decf length 2) (if lsb-first-p (setf (aref dest (index1+ (index+ deststart length))) (br (aref src (index+ srcstart length)))) (setf (aref dest (index+ deststart length)) (br (aref src (index1+ (index+ srcstart length))))))) (do ((i length (index- i 2)) (srcidx srcstart (index+ srcidx 2)) (destidx deststart (index+ destidx 2))) ((index-zerop i)) (declare (type array-index i srcidx destidx)) (setf (aref dest destidx) (br (aref src (index1+ srcidx)))) (setf (aref dest (index1+ destidx)) (br (aref src srcidx))))))))))) (defun image-swap-bits-and-four-bytes (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) (type array-index srcoff destoff srclen srcinc destinc) (type card16 height) (type generalized-boolean lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (let ((byte-reverse +image-byte-reverse+)) (with-vector (byte-reverse (simple-array card8 (256))) (macrolet ((br (byte) `(the card8 (aref byte-reverse (the card8 ,byte))))) (do ((length (index* (index-ceiling srclen 4) 4)) (h height (index1- h)) (srcstart srcoff (index+ srcstart srcinc)) (deststart destoff (index+ deststart destinc))) ((index-zerop h)) (declare (type array-index length srcstart deststart) (type card16 h)) (when (and (index= h 1) (not (index= srclen length))) (index-decf length 4) (unless lsb-first-p (setf (aref dest (index+ deststart length)) (br (aref src (index+ srcstart length 3))))) (when (if lsb-first-p (index= (index- srclen length) 3) (not (index-zerop (index-logand srclen 2)))) (setf (aref dest (index+ deststart length 1)) (br (aref src (index+ srcstart length 2))))) (when (if (null lsb-first-p) (index= (index- srclen length) 3) (not (index-zerop (index-logand srclen 2)))) (setf (aref dest (index+ deststart length 2)) (br (aref src (index+ srcstart length 1))))) (when lsb-first-p (setf (aref dest (index+ deststart length 3)) (br (aref src (index+ srcstart length)))))) (do ((i length (index- i 4)) (srcidx srcstart (index+ srcidx 4)) (destidx deststart (index+ destidx 4))) ((index-zerop i)) (declare (type array-index i srcidx destidx)) (setf (aref dest destidx) (br (aref src (index+ srcidx 3)))) (setf (aref dest (index1+ destidx)) (br (aref src (index+ srcidx 2)))) (setf (aref dest (index+ destidx 2)) (br (aref src (index1+ srcidx)))) (setf (aref dest (index+ destidx 3)) (br (aref src srcidx))))))))))) (defun image-swap-bits-and-words (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) (type array-index srcoff destoff srclen srcinc destinc) (type card16 height) (type generalized-boolean lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (let ((byte-reverse +image-byte-reverse+)) (with-vector (byte-reverse (simple-array card8 (256))) (macrolet ((br (byte) `(the card8 (aref byte-reverse (the card8 ,byte))))) (do ((length (index* (index-ceiling srclen 4) 4)) (h height (index1- h)) (srcstart srcoff (index+ srcstart srcinc)) (deststart destoff (index+ deststart destinc))) ((index-zerop h)) (declare (type array-index length srcstart deststart) (type card16 h)) (when (and (index= h 1) (not (index= srclen length))) (index-decf length 4) (unless lsb-first-p (setf (aref dest (index+ deststart length 1)) (br (aref src (index+ srcstart length 3))))) (when (if lsb-first-p (index= (index- srclen length) 3) (not (index-zerop (index-logand srclen 2)))) (setf (aref dest (index+ deststart length)) (br (aref src (index+ srcstart length 2))))) (when (if (null lsb-first-p) (index= (index- srclen length) 3) (not (index-zerop (index-logand srclen 2)))) (setf (aref dest (index+ deststart length 3)) (br (aref src (index+ srcstart length 1))))) (when lsb-first-p (setf (aref dest (index+ deststart length 2)) (br (aref src (index+ srcstart length)))))) (do ((i length (index- i 4)) (srcidx srcstart (index+ srcidx 4)) (destidx deststart (index+ destidx 4))) ((index-zerop i)) (declare (type array-index i srcidx destidx)) (setf (aref dest destidx) (br (aref src (index+ srcidx 2)))) (setf (aref dest (index1+ destidx)) (br (aref src (index+ srcidx 3)))) (setf (aref dest (index+ destidx 2)) (br (aref src srcidx))) (setf (aref dest (index+ destidx 3)) (br (aref src (index1+ srcidx)))))))))))) ;;; The following table gives the bit ordering within bytes (when accessed ;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to ;;; 31, where bit 0 should be leftmost on the display. For a given byte ;;; labelled A-B, A is for the most significant bit of the byte, and B is ;;; for the least significant bit. ;;; ;;; legend: ;;; 1 scanline-unit = 8 ;;; 2 scanline-unit = 16 ;;; 4 scanline-unit = 32 ;;; M byte-order = MostSignificant ;;; L byte-order = LeastSignificant ;;; m bit-order = MostSignificant ;;; l bit-order = LeastSignificant ;;; ;;; ;;; format ordering ;;; ;;; 1Mm 00-07 08-15 16-23 24-31 ;;; 2Mm 00-07 08-15 16-23 24-31 ;;; 4Mm 00-07 08-15 16-23 24-31 ;;; 1Ml 07-00 15-08 23-16 31-24 ;;; 2Ml 15-08 07-00 31-24 23-16 ;;; 4Ml 31-24 23-16 15-08 07-00 ;;; 1Lm 00-07 08-15 16-23 24-31 ;;; 2Lm 08-15 00-07 24-31 16-23 ;;; 4Lm 24-31 16-23 08-15 00-07 ;;; 1Ll 07-00 15-08 23-16 31-24 ;;; 2Ll 07-00 15-08 23-16 31-24 ;;; 4Ll 07-00 15-08 23-16 31-24 ;;; ;;; ;;; The following table gives the required conversion between any two ;;; formats. It is based strictly on the table above. If you believe one, ;;; you should believe the other. ;;; ;;; legend: ;;; n no changes ;;; s reverse 8-bit units within 16-bit units ;;; l reverse 8-bit units within 32-bit units ;;; w reverse 16-bit units within 32-bit units ;;; r reverse bits within 8-bit units ;;; sr s+R ;;; lr l+R ;;; wr w+R (defconstant +image-swap-function+ '#.(make-array '(12 12) :initial-contents (let ((n 'image-noswap) (s 'image-swap-two-bytes) (l 'image-swap-four-bytes) (w 'image-swap-words) (r 'image-swap-bits) (sr 'image-swap-bits-and-two-bytes) (lr 'image-swap-bits-and-four-bytes) (wr 'image-swap-bits-and-words)) (list #| 1Mm 2Mm 4Mm 1Ml 2Ml 4Ml 1Lm 2Lm 4Lm 1Ll 2Ll 4Ll |# (list #| 1Mm |# n n n r sr lr n s l r r r ) (list #| 2Mm |# n n n r sr lr n s l r r r ) (list #| 4Mm |# n n n r sr lr n s l r r r ) (list #| 1Ml |# r r r n s l r sr lr n n n ) (list #| 2Ml |# sr sr sr s n w sr r wr s s s ) (list #| 4Ml |# lr lr lr l w n lr wr r l l l ) (list #| 1Lm |# n n n r sr lr n s l r r r ) (list #| 2Lm |# s s s sr r wr s n w sr sr sr) (list #| 4Lm |# l l l lr wr r l w n lr lr lr) (list #| 1Ll |# r r r n s l r sr lr n n n ) (list #| 2Ll |# r r r n s l r sr lr n n n ) (list #| 4Ll |# r r r n s l r sr lr n n n ))))) ;;; Of course, the table above is a lie. We also need to factor in the ;;; order of the source data to cope with swapping half of a unit at the ;;; end of a scanline, since we are trying to avoid de-ref'ing off the ;;; end of the source. ;;; ;;; Defines whether the first half of a unit has the first half of the data (defconstant +image-swap-lsb-first-p+ '#.(make-array 12 :initial-contents (list t #| 1mm |# t #| 2mm |# t #| 4mm |# t #| 1ml |# nil #| 2ml |# nil #| 4ml |# t #| 1lm |# nil #| 2lm |# nil #| 4lm |# t #| 1ll |# t #| 2ll |# t #| 4ll |# ))) (defun image-swap-function (bits-per-pixel from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) (declare (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p to-byte-lsb-first-p to-bit-lsb-first-p) (clx-values function lsb-first-p)) (cond ((index= bits-per-pixel 1) (let ((from-index (index+ (ecase from-bitmap-unit (32 2) (16 1) (8 0)) (if from-bit-lsb-first-p 3 0) (if from-byte-lsb-first-p 6 0)))) (values (aref +image-swap-function+ from-index (index+ (ecase to-bitmap-unit (32 2) (16 1) (8 0)) (if to-bit-lsb-first-p 3 0) (if to-byte-lsb-first-p 6 0))) (aref +image-swap-lsb-first-p+ from-index)))) (t (values (if (if (index= bits-per-pixel 4) (eq from-bit-lsb-first-p to-bit-lsb-first-p) (eq from-byte-lsb-first-p to-byte-lsb-first-p)) 'image-noswap (ecase bits-per-pixel (4 'image-swap-nibbles) (8 'image-noswap) (16 'image-swap-two-bytes) (24 'image-swap-three-bytes) (32 'image-swap-four-bytes))) from-byte-lsb-first-p)))) ;;;----------------------------------------------------------------------------- ;;; GET-IMAGE (defun read-pixarray-1 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-1 array) (type card16 x y width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((start (index+ index (index* y padded-bytes-per-line) (index-ceiling x 8)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y)) (left-bits (the array-index (mod (the (integer #x-FFFF 0) (- x)) 8))) (right-bits (index-mod (index- width left-bits) 8)) (middle-bits (- width left-bits right-bits)) (middle-bytes (floor middle-bits 8))) ((index>= y height)) (declare (type array-index start y left-bits right-bits)) (declare (fixnum middle-bits middle-bytes)) (cond ((< middle-bits 0) (let ((byte (aref buffer-bbuf (index1- start))) (x left-bits)) (declare (type card8 byte) (type array-index x)) (when (index> right-bits 6) (setf (aref array y (index- x 1)) (read-image-load-byte 1 7 byte))) (when (and (index> left-bits 1) (index> right-bits 5)) (setf (aref array y (index- x 2)) (read-image-load-byte 1 6 byte))) (when (and (index> left-bits 2) (index> right-bits 4)) (setf (aref array y (index- x 3)) (read-image-load-byte 1 5 byte))) (when (and (index> left-bits 3) (index> right-bits 3)) (setf (aref array y (index- x 4)) (read-image-load-byte 1 4 byte))) (when (and (index> left-bits 4) (index> right-bits 2)) (setf (aref array y (index- x 5)) (read-image-load-byte 1 3 byte))) (when (and (index> left-bits 5) (index> right-bits 1)) (setf (aref array y (index- x 6)) (read-image-load-byte 1 2 byte))) (when (index> left-bits 6) (setf (aref array y (index- x 7)) (read-image-load-byte 1 1 byte))))) (t (unless (index-zerop left-bits) (let ((byte (aref buffer-bbuf (index1- start))) (x left-bits)) (declare (type card8 byte) (type array-index x)) (setf (aref array y (index- x 1)) (read-image-load-byte 1 7 byte)) (when (index> left-bits 1) (setf (aref array y (index- x 2)) (read-image-load-byte 1 6 byte)) (when (index> left-bits 2) (setf (aref array y (index- x 3)) (read-image-load-byte 1 5 byte)) (when (index> left-bits 3) (setf (aref array y (index- x 4)) (read-image-load-byte 1 4 byte)) (when (index> left-bits 4) (setf (aref array y (index- x 5)) (read-image-load-byte 1 3 byte)) (when (index> left-bits 5) (setf (aref array y (index- x 6)) (read-image-load-byte 1 2 byte)) (when (index> left-bits 6) (setf (aref array y (index- x 7)) (read-image-load-byte 1 1 byte)) )))))))) (do* ((end (index+ start middle-bytes)) (i start (index1+ i)) (x left-bits (index+ x 8))) ((index>= i end) (unless (index-zerop right-bits) (let ((byte (aref buffer-bbuf end)) (x (index+ left-bits middle-bits))) (declare (type card8 byte) (type array-index x)) (setf (aref array y (index+ x 0)) (read-image-load-byte 1 0 byte)) (when (index> right-bits 1) (setf (aref array y (index+ x 1)) (read-image-load-byte 1 1 byte)) (when (index> right-bits 2) (setf (aref array y (index+ x 2)) (read-image-load-byte 1 2 byte)) (when (index> right-bits 3) (setf (aref array y (index+ x 3)) (read-image-load-byte 1 3 byte)) (when (index> right-bits 4) (setf (aref array y (index+ x 4)) (read-image-load-byte 1 4 byte)) (when (index> right-bits 5) (setf (aref array y (index+ x 5)) (read-image-load-byte 1 5 byte)) (when (index> right-bits 6) (setf (aref array y (index+ x 6)) (read-image-load-byte 1 6 byte)) ))))))))) (declare (type array-index end i x)) (let ((byte (aref buffer-bbuf i))) (declare (type card8 byte)) (setf (aref array y (index+ x 0)) (read-image-load-byte 1 0 byte)) (setf (aref array y (index+ x 1)) (read-image-load-byte 1 1 byte)) (setf (aref array y (index+ x 2)) (read-image-load-byte 1 2 byte)) (setf (aref array y (index+ x 3)) (read-image-load-byte 1 3 byte)) (setf (aref array y (index+ x 4)) (read-image-load-byte 1 4 byte)) (setf (aref array y (index+ x 5)) (read-image-load-byte 1 5 byte)) (setf (aref array y (index+ x 6)) (read-image-load-byte 1 6 byte)) (setf (aref array y (index+ x 7)) (read-image-load-byte 1 7 byte)))) ))))) (defun read-pixarray-4 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-4 array) (type card16 x y width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((start (index+ index (index* y padded-bytes-per-line) (index-ceiling x 2)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y)) (left-nibbles (mod (the fixnum (- x)) 2)) (right-nibbles (index-mod (index- width left-nibbles) 2)) (middle-nibbles (index- width left-nibbles right-nibbles)) (middle-bytes (index-floor middle-nibbles 2))) ((index>= y height)) (declare (type array-index start y left-nibbles right-nibbles middle-nibbles middle-bytes)) (unless (index-zerop left-nibbles) (setf (aref array y 0) (read-image-load-byte 4 4 (aref buffer-bbuf (index1- start))))) (do* ((end (index+ start middle-bytes)) (i start (index1+ i)) (x left-nibbles (index+ x 2))) ((index>= i end) (unless (index-zerop right-nibbles) (setf (aref array y (index+ left-nibbles middle-nibbles)) (read-image-load-byte 4 0 (aref buffer-bbuf end))))) (declare (type array-index end i x)) (let ((byte (aref buffer-bbuf i))) (declare (type card8 byte)) (setf (aref array y (index+ x 0)) (read-image-load-byte 4 0 byte)) (setf (aref array y (index+ x 1)) (read-image-load-byte 4 4 byte)))) ))) (defun read-pixarray-8 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-8 array) (type card16 x y width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((start (index+ index (index* y padded-bytes-per-line) x) (index+ start padded-bytes-per-line)) (y 0 (index1+ y))) ((index>= y height)) (declare (type array-index start y)) (do* ((end (index+ start width)) (i start (index1+ i)) (x 0 (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (setf (aref array y x) (the card8 (aref buffer-bbuf i))))))) (defun read-pixarray-16 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-16 array) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((start (index+ index (index* y padded-bytes-per-line) (index* x 2)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y))) ((index>= y height)) (declare (type array-index start y)) (do* ((end (index+ start (index* width 2))) (i start (index+ i 2)) (x 0 (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (setf (aref array y x) (read-image-assemble-bytes (aref buffer-bbuf (index+ i 0)) (aref buffer-bbuf (index+ i 1)))))))) (defun read-pixarray-24 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-24 array) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((start (index+ index (index* y padded-bytes-per-line) (index* x 3)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y))) ((index>= y height)) (declare (type array-index start y)) (do* ((end (index+ start (index* width 3))) (i start (index+ i 3)) (x 0 (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (setf (aref array y x) (read-image-assemble-bytes (aref buffer-bbuf (index+ i 0)) (aref buffer-bbuf (index+ i 1)) (aref buffer-bbuf (index+ i 2)))))))) (defun read-pixarray-32 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-32 array) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((start (index+ index (index* y padded-bytes-per-line) (index* x 4)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y))) ((index>= y height)) (declare (type array-index start y)) (do* ((end (index+ start (index* width 4))) (i start (index+ i 4)) (x 0 (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (setf (aref array y x) (read-image-assemble-bytes (aref buffer-bbuf (index+ i 0)) (aref buffer-bbuf (index+ i 1)) (aref buffer-bbuf (index+ i 2)) (aref buffer-bbuf (index+ i 3)))))))) (defun read-pixarray-internal (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel read-pixarray-function from-unit from-byte-lsb-first-p from-bit-lsb-first-p to-unit to-byte-lsb-first-p to-bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type array-index boffset padded-bytes-per-line) (type pixarray pixarray) (type card16 x y width height) (type (member 1 4 8 16 24 32) bits-per-pixel) (type function read-pixarray-function) (type (member 8 16 32) from-unit to-unit) (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p to-byte-lsb-first-p to-bit-lsb-first-p)) (multiple-value-bind (image-swap-function image-swap-lsb-first-p) (image-swap-function bits-per-pixel from-unit from-byte-lsb-first-p from-bit-lsb-first-p to-unit to-byte-lsb-first-p to-bit-lsb-first-p) (if (eq image-swap-function 'image-noswap) (funcall read-pixarray-function bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel) (with-image-data-buffer (buf (index* height padded-bytes-per-line)) (funcall (symbol-function image-swap-function) bbuf buf (index+ boffset (index* y padded-bytes-per-line)) 0 (index-ceiling (index* (index+ x width) bits-per-pixel) 8) padded-bytes-per-line padded-bytes-per-line height image-swap-lsb-first-p) (funcall read-pixarray-function buf 0 pixarray x 0 width height padded-bytes-per-line bits-per-pixel))))) (defun read-pixarray (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type array-index boffset padded-bytes-per-line) (type pixarray pixarray) (type card16 x y width height) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (unless (fast-read-pixarray bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (read-pixarray-internal bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel (ecase bits-per-pixel ( 1 #'read-pixarray-1 ) ( 4 #'read-pixarray-4 ) ( 8 #'read-pixarray-8 ) (16 #'read-pixarray-16) (24 #'read-pixarray-24) (32 #'read-pixarray-32)) unit byte-lsb-first-p bit-lsb-first-p +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+))) (defun read-xy-format-image-x (buffer-bbuf index length data width height depth padded-bytes-per-line padded-bytes-per-plane unit byte-lsb-first-p bit-lsb-first-p pad) (declare (type buffer-bytes buffer-bbuf) (type card16 width height) (type array-index index length padded-bytes-per-line padded-bytes-per-plane) (type image-depth depth) (type (member 8 16 32) unit pad) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) (clx-values image-x)) (assert (index<= (index* depth padded-bytes-per-plane) length)) (let* ((bytes-per-line (index-ceiling width 8)) (data-length (index* padded-bytes-per-plane depth))) (declare (type array-index bytes-per-line data-length)) (cond (data (check-type data buffer-bytes) (assert (index>= (length data) data-length))) (t (setq data (make-array data-length :element-type 'card8)))) (do ((plane 0 (index1+ plane))) ((index>= plane depth)) (declare (type image-depth plane)) (image-noswap buffer-bbuf data (index+ index (index* plane padded-bytes-per-plane)) (index* plane padded-bytes-per-plane) bytes-per-line padded-bytes-per-line padded-bytes-per-line height byte-lsb-first-p)) (create-image :width width :height height :depth depth :data data :bits-per-pixel 1 :format :xy-pixmap :bytes-per-line padded-bytes-per-line :unit unit :pad pad :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) (defun read-z-format-image-x (buffer-bbuf index length data width height depth padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p pad bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type card16 width height) (type array-index index length padded-bytes-per-line) (type image-depth depth) (type (member 8 16 32) unit pad) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) (type (member 1 4 8 16 24 32) bits-per-pixel) (clx-values image-x)) (assert (index<= (index* height padded-bytes-per-line) length)) (let ((bytes-per-line (index-ceiling (index* width bits-per-pixel) 8)) (data-length (index* padded-bytes-per-line height))) (declare (type array-index bytes-per-line data-length)) (cond (data (check-type data buffer-bytes) (assert (index>= (length data) data-length))) (t (setq data (make-array data-length :element-type 'card8)))) (image-noswap buffer-bbuf data index 0 bytes-per-line padded-bytes-per-line padded-bytes-per-line height byte-lsb-first-p) (create-image :width width :height height :depth depth :data data :bits-per-pixel bits-per-pixel :format :z-pixmap :bytes-per-line padded-bytes-per-line :unit unit :pad pad :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) (defun read-image-xy (bbuf index length data x y width height depth padded-bytes-per-line padded-bytes-per-plane unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type card16 x y width height) (type array-index index length padded-bytes-per-line padded-bytes-per-plane) (type image-depth depth) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) (clx-values image-xy)) (check-type data list) (multiple-value-bind (dimensions element-type) (if data (values (array-dimensions (first data)) (array-element-type (first data))) (values (list height (index* (index-ceiling width +image-pad+) +image-pad+)) 'pixarray-1-element-type)) (do* ((arrays data) (result nil) (limit (index+ length index)) (plane 0 (1+ plane)) (index index (index+ index padded-bytes-per-plane))) ((or (>= plane depth) (index> (index+ index padded-bytes-per-plane) limit)) (setq data (nreverse result) depth (length data))) (declare (type array-index limit index) (type image-depth plane) (type list arrays result)) (let ((array (or (pop arrays) (make-array dimensions :element-type element-type)))) (declare (type pixarray-1 array)) (push array result) (read-pixarray bbuf index array x y width height padded-bytes-per-line 1 unit byte-lsb-first-p bit-lsb-first-p))) (create-image :width width :height height :depth depth :data data))) (defun read-image-z (bbuf index length data x y width height depth padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type card16 x y width height) (type array-index index length padded-bytes-per-line) (type image-depth depth) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) (clx-values image-z)) (assert (index<= (index* (index+ y height) padded-bytes-per-line) length)) (let* ((image-bits-per-line (index* width bits-per-pixel)) (image-pixels-per-line (index-ceiling (index* (index-ceiling image-bits-per-line +image-pad+) +image-pad+) bits-per-pixel))) (declare (type array-index image-bits-per-line image-pixels-per-line)) (unless data (setq data (make-array (list height image-pixels-per-line) :element-type (ecase bits-per-pixel (1 'pixarray-1-element-type) (4 'pixarray-4-element-type) (8 'pixarray-8-element-type) (16 'pixarray-16-element-type) (24 'pixarray-24-element-type) (32 'pixarray-32-element-type))))) (read-pixarray bbuf index data x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (create-image :width width :height height :depth depth :data data :bits-per-pixel bits-per-pixel))) (defun get-image (drawable &key data (x (required-arg x)) (y (required-arg y)) (width (required-arg width)) (height (required-arg height)) plane-mask format result-type) (declare (type drawable drawable) (type (or buffer-bytes list pixarray) data) (type int16 x y) ;; required (type card16 width height) ;; required (type (or null pixel) plane-mask) (type (or null (member :xy-pixmap :z-pixmap)) format) (type (or null (member image-xy image-x image-z)) result-type) (clx-values image visual-info)) (unless result-type (setq result-type (ecase format (:xy-pixmap 'image-xy) (:z-pixmap 'image-z) ((nil) 'image-x)))) (unless format (setq format (case result-type (image-xy :xy-pixmap) ((image-z image-x) :z-pixmap)))) (unless (ecase result-type (image-xy (eq format :xy-pixmap)) (image-z (eq format :z-pixmap)) (image-x t)) (error "Result-type ~s is incompatable with format ~s" result-type format)) (unless plane-mask (setq plane-mask #xffffffff)) (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display +x-getimage+ nil :sizes (8 32)) (((data (member error :xy-pixmap :z-pixmap)) format) (drawable drawable) (int16 x y) (card16 width height) (card32 plane-mask)) (let* ((depth (card8-get 1)) (length (index* 4 (card32-get 4))) (visual-info (visual-info display (resource-id-get 8))) (bitmap-format (display-bitmap-format display)) (unit (bitmap-format-unit bitmap-format)) (byte-lsb-first-p (display-image-lsb-first-p display)) (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) (declare (type image-depth depth) (type array-index length) (type (or null visual-info) visual-info) (type bitmap-format bitmap-format) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (multiple-value-bind (pad bits-per-pixel) (ecase format (:xy-pixmap (values (bitmap-format-pad bitmap-format) 1)) (:z-pixmap (if (= depth 1) (values (bitmap-format-pad bitmap-format) 1) (let ((pixmap-format (find depth (display-pixmap-formats display) :key #'pixmap-format-depth))) (declare (type pixmap-format pixmap-format)) (values (pixmap-format-scanline-pad pixmap-format) (pixmap-format-bits-per-pixel pixmap-format)))))) (declare (type (member 8 16 32) pad) (type (member 1 4 8 16 24 32) bits-per-pixel)) (let* ((bits-per-line (index* bits-per-pixel width)) (padded-bits-per-line (index* (index-ceiling bits-per-line pad) pad)) (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) (padded-bytes-per-plane (index* padded-bytes-per-line height)) (image (ecase result-type (image-x (ecase format (:xy-pixmap (read-xy-format-image-x buffer-bbuf +replysize+ length data width height depth padded-bytes-per-line padded-bytes-per-plane unit byte-lsb-first-p bit-lsb-first-p pad)) (:z-pixmap (read-z-format-image-x buffer-bbuf +replysize+ length data width height depth padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p pad bits-per-pixel)))) (image-xy (read-image-xy buffer-bbuf +replysize+ length data 0 0 width height depth padded-bytes-per-line padded-bytes-per-plane unit byte-lsb-first-p bit-lsb-first-p)) (image-z (read-image-z buffer-bbuf +replysize+ length data 0 0 width height depth padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p))))) (declare (type image image) (type array-index bits-per-line padded-bits-per-line padded-bytes-per-line)) (when visual-info (unless (zerop (visual-info-red-mask visual-info)) (setf (image-red-mask image) (visual-info-red-mask visual-info))) (unless (zerop (visual-info-green-mask visual-info)) (setf (image-green-mask image) (visual-info-green-mask visual-info))) (unless (zerop (visual-info-blue-mask visual-info)) (setf (image-blue-mask image) (visual-info-blue-mask visual-info)))) (values image visual-info))))))) ;;;----------------------------------------------------------------------------- ;;; PUT-IMAGE (defun write-pixarray-1 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-1 array) (type card16 x y width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (right-bits (index-mod width 8)) (middle-bits (index- width right-bits)) (middle-bytes (index-ceiling middle-bits 8)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index h y right-bits middle-bits middle-bytes start)) (do* ((end (index+ start middle-bytes)) (i start (index1+ i)) (start-x x) (x start-x (index+ x 8))) ((index>= i end) (unless (index-zerop right-bits) (let ((x (index+ start-x middle-bits))) (declare (type array-index x)) (setf (aref buffer-bbuf end) (write-image-assemble-bytes (aref array y (index+ x 0)) (if (index> right-bits 1) (aref array y (index+ x 1)) 0) (if (index> right-bits 2) (aref array y (index+ x 2)) 0) (if (index> right-bits 3) (aref array y (index+ x 3)) 0) (if (index> right-bits 4) (aref array y (index+ x 4)) 0) (if (index> right-bits 5) (aref array y (index+ x 5)) 0) (if (index> right-bits 6) (aref array y (index+ x 6)) 0) 0))))) (declare (type array-index end i start-x x)) (setf (aref buffer-bbuf i) (write-image-assemble-bytes (aref array y (index+ x 0)) (aref array y (index+ x 1)) (aref array y (index+ x 2)) (aref array y (index+ x 3)) (aref array y (index+ x 4)) (aref array y (index+ x 5)) (aref array y (index+ x 6)) (aref array y (index+ x 7)))))))) (defun write-pixarray-4 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-4 array) (type int16 x y) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (right-nibbles (index-mod width 2)) (middle-nibbles (index- width right-nibbles)) (middle-bytes (index-ceiling middle-nibbles 2)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index h y right-nibbles middle-nibbles middle-bytes start)) (do* ((end (index+ start middle-bytes)) (i start (index1+ i)) (start-x x) (x start-x (index+ x 2))) ((index>= i end) (unless (index-zerop right-nibbles) (setf (aref buffer-bbuf end) (write-image-assemble-bytes (aref array y (index+ start-x middle-nibbles)) 0)))) (declare (type array-index end i start-x x)) (setf (aref buffer-bbuf i) (write-image-assemble-bytes (aref array y (index+ x 0)) (aref array y (index+ x 1)))))))) (defun write-pixarray-8 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-8 array) (type int16 x y) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index h y start)) (do* ((end (index+ start width)) (i start (index1+ i)) (x x (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (setf (aref buffer-bbuf i) (the card8 (aref array y x))))))) (defun write-pixarray-16 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-16 array) (type int16 x y) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index h y start)) (do* ((end (index+ start (index* width 2))) (i start (index+ i 2)) (x x (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (let ((pixel (aref array y x))) (declare (type pixarray-16-element-type pixel)) (setf (aref buffer-bbuf (index+ i 0)) (write-image-load-byte 0 pixel 16)) (setf (aref buffer-bbuf (index+ i 1)) (write-image-load-byte 8 pixel 16))))))) (defun write-pixarray-24 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-24 array) (type int16 x y) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index y start)) (do* ((end (index+ start (index* width 3))) (i start (index+ i 3)) (x x (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (let ((pixel (aref array y x))) (declare (type pixarray-24-element-type pixel)) (setf (aref buffer-bbuf (index+ i 0)) (write-image-load-byte 0 pixel 24)) (setf (aref buffer-bbuf (index+ i 1)) (write-image-load-byte 8 pixel 24)) (setf (aref buffer-bbuf (index+ i 2)) (write-image-load-byte 16 pixel 24))))))) (defun write-pixarray-32 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-32 array) (type int16 x y) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index h y start)) (do* ((end (index+ start (index* width 4))) (i start (index+ i 4)) (x x (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (let ((pixel (aref array y x))) (declare (type pixarray-32-element-type pixel)) (setf (aref buffer-bbuf (index+ i 0)) (write-image-load-byte 0 pixel 32)) (setf (aref buffer-bbuf (index+ i 1)) (write-image-load-byte 8 pixel 32)) (setf (aref buffer-bbuf (index+ i 2)) (write-image-load-byte 16 pixel 32)) (setf (aref buffer-bbuf (index+ i 3)) (write-image-load-byte 24 pixel 32))))))) (defun write-pixarray-internal (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel write-pixarray-function from-unit from-byte-lsb-first-p from-bit-lsb-first-p to-unit to-byte-lsb-first-p to-bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type pixarray pixarray) (type card16 x y width height) (type array-index boffset padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (type function write-pixarray-function) (type (member 8 16 32) from-unit to-unit) (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p to-byte-lsb-first-p to-bit-lsb-first-p)) (multiple-value-bind (image-swap-function image-swap-lsb-first-p) (image-swap-function bits-per-pixel from-unit from-byte-lsb-first-p from-bit-lsb-first-p to-unit to-byte-lsb-first-p to-bit-lsb-first-p) (declare (type symbol image-swap-function) (type generalized-boolean image-swap-lsb-first-p)) (if (eq image-swap-function 'image-noswap) (funcall write-pixarray-function bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel) (with-image-data-buffer (buf (index* height padded-bytes-per-line)) (funcall write-pixarray-function buf 0 pixarray x y width height padded-bytes-per-line bits-per-pixel) (funcall (symbol-function image-swap-function) buf bbuf 0 boffset (index-ceiling (index* width bits-per-pixel) 8) padded-bytes-per-line padded-bytes-per-line height image-swap-lsb-first-p))))) (defun write-pixarray (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type pixarray pixarray) (type card16 x y width height) (type array-index boffset padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (unless (fast-write-pixarray bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (write-pixarray-internal bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel (ecase bits-per-pixel ( 1 #'write-pixarray-1 ) ( 4 #'write-pixarray-4 ) ( 8 #'write-pixarray-8 ) (16 #'write-pixarray-16) (24 #'write-pixarray-24) (32 #'write-pixarray-32)) +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+ unit byte-lsb-first-p bit-lsb-first-p))) (defun write-xy-format-image-x-data (data obuf data-start obuf-start x y width height from-padded-bytes-per-line to-padded-bytes-per-line from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) (declare (type buffer-bytes data obuf) (type array-index data-start obuf-start from-padded-bytes-per-line to-padded-bytes-per-line) (type card16 x y width height) (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p to-byte-lsb-first-p to-bit-lsb-first-p)) (assert (index-zerop (index-mod x 8))) (multiple-value-bind (image-swap-function image-swap-lsb-first-p) (image-swap-function 1 from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) (declare (type symbol image-swap-function) (type generalized-boolean image-swap-lsb-first-p)) (let ((x-mod-unit (index-mod x from-bitmap-unit))) (declare (type card16 x-mod-unit)) (if (and (index-plusp x-mod-unit) (not (eq from-byte-lsb-first-p from-bit-lsb-first-p))) (let* ((temp-width (index+ width x-mod-unit)) (temp-bytes-per-line (index-ceiling temp-width 8)) (temp-padded-bits-per-line (index* (index-ceiling temp-width from-bitmap-unit) from-bitmap-unit)) (temp-padded-bytes-per-line (index-ceiling temp-padded-bits-per-line 8))) (declare (type card16 temp-width temp-bytes-per-line temp-padded-bits-per-line temp-padded-bytes-per-line)) (with-image-data-buffer (buf (index* height temp-padded-bytes-per-line)) (funcall (symbol-function image-swap-function) data buf (index+ data-start (index* y from-padded-bytes-per-line) (index-floor (index- x x-mod-unit) 8)) 0 temp-bytes-per-line from-padded-bytes-per-line temp-padded-bytes-per-line height image-swap-lsb-first-p) (write-xy-format-image-x-data buf obuf 0 obuf-start x-mod-unit 0 width height temp-padded-bytes-per-line to-padded-bytes-per-line from-bitmap-unit to-byte-lsb-first-p to-byte-lsb-first-p to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p))) (funcall (symbol-function image-swap-function) data obuf (index+ data-start (index* y from-padded-bytes-per-line) (index-floor x 8)) obuf-start (index-ceiling width 8) from-padded-bytes-per-line to-padded-bytes-per-line height image-swap-lsb-first-p))))) (defun write-xy-format-image-x (display image src-x src-y width height padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p) (declare (type display display) (type image-x image) (type int16 src-x src-y) (type card16 width height) (type array-index padded-bytes-per-line) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (dotimes (plane (image-depth image)) (let ((data-start (index* (index* plane (image-height image)) (image-x-bytes-per-line image))) (src-y src-y) (height height)) (declare (type int16 src-y) (type card16 height)) (loop (when (index-zerop height) (return)) (let ((nlines (index-min (index-floor (index- (buffer-size display) (buffer-boffset display)) padded-bytes-per-line) height))) (declare (type array-index nlines)) (when (index-plusp nlines) (write-xy-format-image-x-data (image-x-data image) (buffer-obuf8 display) data-start (buffer-boffset display) src-x src-y width nlines (image-x-bytes-per-line image) padded-bytes-per-line (image-x-unit image) (image-x-byte-lsb-first-p image) (image-x-bit-lsb-first-p image) unit byte-lsb-first-p bit-lsb-first-p) (index-incf (buffer-boffset display) (index* nlines padded-bytes-per-line)) (index-incf src-y nlines) (when (index-zerop (index-decf height nlines)) (return)))) (buffer-flush display))))) (defun write-z-format-image-x-data (data obuf data-start obuf-start x y width height from-padded-bytes-per-line to-padded-bytes-per-line bits-per-pixel from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) (declare (type buffer-bytes data obuf) (type array-index data-start obuf-start from-padded-bytes-per-line to-padded-bytes-per-line) (type card16 x y width height) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p to-byte-lsb-first-p to-bit-lsb-first-p)) (if (index= bits-per-pixel 1) (write-xy-format-image-x-data data obuf data-start obuf-start x y width height from-padded-bytes-per-line to-padded-bytes-per-line from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) (let ((srcoff (index+ data-start (index* y from-padded-bytes-per-line) (index-floor (index* x bits-per-pixel) 8))) (srclen (index-ceiling (index* width bits-per-pixel) 8))) (declare (type array-index srcoff srclen)) (if (and (index= bits-per-pixel 4) (index-oddp x)) (with-image-data-buffer (buf (index* height to-padded-bytes-per-line)) (image-swap-nibbles-left data buf srcoff 0 srclen from-padded-bytes-per-line to-padded-bytes-per-line height nil) (write-z-format-image-x-data buf obuf 0 obuf-start 0 0 width height to-padded-bytes-per-line to-padded-bytes-per-line bits-per-pixel from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)) (multiple-value-bind (image-swap-function image-swap-lsb-first-p) (image-swap-function bits-per-pixel from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) (declare (type symbol image-swap-function) (type generalized-boolean image-swap-lsb-first-p)) (funcall (symbol-function image-swap-function) data obuf srcoff obuf-start srclen from-padded-bytes-per-line to-padded-bytes-per-line height image-swap-lsb-first-p)))))) (defun write-z-format-image-x (display image src-x src-y width height padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p) (declare (type display display) (type image-x image) (type int16 src-x src-y) (type card16 width height) (type array-index padded-bytes-per-line) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (loop (when (index-zerop height) (return)) (let ((nlines (index-min (index-floor (index- (buffer-size display) (buffer-boffset display)) padded-bytes-per-line) height))) (declare (type array-index nlines)) (when (index-plusp nlines) (write-z-format-image-x-data (image-x-data image) (buffer-obuf8 display) 0 (buffer-boffset display) src-x src-y width nlines (image-x-bytes-per-line image) padded-bytes-per-line (image-x-bits-per-pixel image) (image-x-unit image) (image-x-byte-lsb-first-p image) (image-x-bit-lsb-first-p image) unit byte-lsb-first-p bit-lsb-first-p) (index-incf (buffer-boffset display) (index* nlines padded-bytes-per-line)) (index-incf src-y nlines) (when (index-zerop (index-decf height nlines)) (return)))) (buffer-flush display))) (defun write-image-xy (display image src-x src-y width height padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p) (declare (type display display) (type image-xy image) (type array-index padded-bytes-per-line) (type int16 src-x src-y) (type card16 width height) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (dolist (bitmap (image-xy-bitmap-list image)) (declare (type pixarray-1 bitmap)) (let ((src-y src-y) (height height)) (declare (type int16 src-y) (type card16 height)) (loop (let ((nlines (index-min (index-floor (index- (buffer-size display) (buffer-boffset display)) padded-bytes-per-line) height))) (declare (type array-index nlines)) (when (index-plusp nlines) (write-pixarray (buffer-obuf8 display) (buffer-boffset display) bitmap src-x src-y width nlines padded-bytes-per-line 1 unit byte-lsb-first-p bit-lsb-first-p) (index-incf (buffer-boffset display) (index* nlines padded-bytes-per-line)) (index-incf src-y nlines) (when (index-zerop (index-decf height nlines)) (return)))) (buffer-flush display))))) (defun write-image-z (display image src-x src-y width height padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p) (declare (type display display) (type image-z image) (type array-index padded-bytes-per-line) (type int16 src-x src-y) (type card16 width height) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (loop (let ((bits-per-pixel (image-z-bits-per-pixel image)) (nlines (index-min (index-floor (index- (buffer-size display) (buffer-boffset display)) padded-bytes-per-line) height))) (declare (type (member 1 4 8 16 24 32) bits-per-pixel) (type array-index nlines)) (when (index-plusp nlines) (write-pixarray (buffer-obuf8 display) (buffer-boffset display) (image-z-pixarray image) src-x src-y width nlines padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (index-incf (buffer-boffset display) (index* nlines padded-bytes-per-line)) (index-incf src-y nlines) (when (index-zerop (index-decf height nlines)) (return)))) (buffer-flush display))) ;;; Note: The only difference between a format of :bitmap and :xy-pixmap ;;; of depth 1 is that when sending a :bitmap format the foreground ;;; and background in the gcontext are used. (defun put-image (drawable gcontext image &key (src-x 0) (src-y 0) ;Position within image (x (required-arg x)) ;Position within drawable (y (required-arg y)) width height bitmap-p) ;; Copy an image into a drawable. ;; WIDTH and HEIGHT default from IMAGE. ;; When BITMAP-P, force format to be :bitmap when depth=1. ;; This causes gcontext to supply foreground & background pixels. (declare (type drawable drawable) (type gcontext gcontext) (type image image) (type int16 x y) ;; required (type int16 src-x src-y) (type (or null card16) width height) (type generalized-boolean bitmap-p)) (let* ((format (etypecase image (image-x (image-x-format (the image-x image))) (image-xy :xy-pixmap) (image-z :z-pixmap))) (src-x (if (image-x-p image) (index+ src-x (image-x-left-pad (the image-x image))) src-x)) (image-width (image-width image)) (image-height (image-height image)) (width (min (or width image-width) (index- image-width src-x))) (height (min (or height image-height) (index- image-height src-y))) (depth (image-depth image)) (display (drawable-display drawable)) (bitmap-format (display-bitmap-format display)) (unit (bitmap-format-unit bitmap-format)) (byte-lsb-first-p (display-image-lsb-first-p display)) (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) (declare (type (member :bitmap :xy-pixmap :z-pixmap) format) (type fixnum src-x image-width image-height width height) (type image-depth depth) (type display display) (type bitmap-format bitmap-format) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (when (and bitmap-p (not (index= depth 1))) (error "Bitmaps must have depth 1")) (unless (<= 0 src-x (index1- (image-width image))) (error "src-x not inside image")) (unless (<= 0 src-y (index1- (image-height image))) (error "src-y not inside image")) (when (and (index> width 0) (index> height 0)) (multiple-value-bind (pad bits-per-pixel) (ecase format ((:bitmap :xy-pixmap) (values (bitmap-format-pad bitmap-format) 1)) (:z-pixmap (if (= depth 1) (values (bitmap-format-pad bitmap-format) 1) (let ((pixmap-format (find depth (display-pixmap-formats display) :key #'pixmap-format-depth))) (declare (type (or null pixmap-format) pixmap-format)) (if (null pixmap-format) (error "The depth of the image ~s does not match any server pixmap format." image)) (if (not (= (etypecase image (image-z (image-z-bits-per-pixel image)) (image-x (image-x-bits-per-pixel image))) (pixmap-format-bits-per-pixel pixmap-format))) ;; We could try to use the "/* XXX slow, but works */" ;; code in XPutImage from X11R4 here. However, that ;; would require considerable support code ;; (see XImUtil.c, etc). (error "The bits-per-pixel of the image ~s does not match any server pixmap format." image)) (values (pixmap-format-scanline-pad pixmap-format) (pixmap-format-bits-per-pixel pixmap-format)))))) (declare (type (member 8 16 32) pad) (type (member 1 4 8 16 24 32) bits-per-pixel)) (let* ((left-pad (if (or (eq format :xy-pixmap) (= depth 1)) (index-mod src-x (index-min pad +image-pad+)) 0)) (left-padded-src-x (index- src-x left-pad)) (left-padded-width (index+ width left-pad)) (bits-per-line (index* left-padded-width bits-per-pixel)) (padded-bits-per-line (index* (index-ceiling bits-per-line pad) pad)) (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) (request-bytes-per-line (ecase format ((:bitmap :xy-pixmap) (index* padded-bytes-per-line depth)) (:z-pixmap padded-bytes-per-line))) (max-bytes-per-request (index* (index- (display-max-request-length display) 6) 4)) (max-request-height (floor max-bytes-per-request request-bytes-per-line))) (declare (type card8 left-pad) (type int16 left-padded-src-x) (type card16 left-padded-width) (type array-index bits-per-line padded-bits-per-line padded-bytes-per-line request-bytes-per-line max-bytes-per-request max-request-height)) ;; Be sure that a scanline can fit in a request (when (index-zerop max-request-height) (error "Can't even fit one image scanline in a request")) ;; Be sure a scanline can fit in a buffer (buffer-ensure-size display padded-bytes-per-line) ;; Send the image in multiple requests to avoid exceeding the ;; request limit (do* ((request-src-y src-y (index+ request-src-y request-height)) (request-y y (index+ request-y request-height)) (height-remaining height (the fixnum (- height-remaining request-height))) (request-height (index-min height-remaining max-request-height) (index-min height-remaining max-request-height))) ((<= height-remaining 0)) (declare (type array-index request-src-y request-height) (fixnum height-remaining)) (let* ((request-bytes (index* request-bytes-per-line request-height)) (request-words (index-ceiling request-bytes 4)) (request-length (index+ request-words 6))) (declare (type array-index request-bytes) (type card16 request-words request-length)) (with-buffer-request (display +x-putimage+ :gc-force gcontext) ((data (member :bitmap :xy-pixmap :z-pixmap)) (cond ((or (eq format :bitmap) bitmap-p) :bitmap) ((plusp left-pad) :xy-pixmap) (t format))) (drawable drawable) (gcontext gcontext) (card16 width request-height) (int16 x request-y) (card8 left-pad depth) (pad16 nil) (progn (length-put 2 request-length) (setf (buffer-boffset display) (advance-buffer-offset 24)) (etypecase image (image-x (ecase (image-x-format (the image-x image)) ((:bitmap :xy-pixmap) (write-xy-format-image-x display image left-padded-src-x request-src-y left-padded-width request-height padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p)) (:z-pixmap (write-z-format-image-x display image left-padded-src-x request-src-y left-padded-width request-height padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p)))) (image-xy (write-image-xy display image left-padded-src-x request-src-y left-padded-width request-height padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p)) (image-z (write-image-z display image left-padded-src-x request-src-y left-padded-width request-height padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p))) ;; Be sure the request is padded to a multiple of 4 bytes (buffer-pad-request display (index- (index* request-words 4) request-bytes)) ))))))))) ;;;----------------------------------------------------------------------------- ;;; COPY-IMAGE (defun xy-format-image-x->image-x (image x y width height) (declare (type image-x image) (type card16 x y width height) (clx-values image-x)) (let* ((padded-x (index+ x (image-x-left-pad image))) (left-pad (index-mod padded-x 8)) (x (index- padded-x left-pad)) (unit (image-x-unit image)) (byte-lsb-first-p (image-x-byte-lsb-first-p image)) (bit-lsb-first-p (image-x-bit-lsb-first-p image)) (pad (image-x-pad image)) (padded-width (index* (index-ceiling (index+ width left-pad) pad) pad)) (padded-bytes-per-line (index-ceiling padded-width 8)) (padded-bytes-per-plane (index* padded-bytes-per-line height)) (length (index* padded-bytes-per-plane (image-depth image))) (obuf (make-array length :element-type 'card8))) (declare (type card16 x) (type card8 left-pad) (type (member 8 16 32) unit pad) (type array-index padded-width padded-bytes-per-line padded-bytes-per-plane length) (type buffer-bytes obuf)) (dotimes (plane (image-depth image)) (let ((data-start (index* (image-x-bytes-per-line image) (image-height image) plane)) (obuf-start (index* padded-bytes-per-plane plane))) (declare (type array-index data-start obuf-start)) (write-xy-format-image-x-data (image-x-data image) obuf data-start obuf-start x y width height (image-x-bytes-per-line image) padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p unit byte-lsb-first-p bit-lsb-first-p))) (create-image :width width :height height :depth (image-depth image) :data obuf :format (image-x-format image) :bits-per-pixel 1 :bytes-per-line padded-bytes-per-line :unit unit :pad pad :left-pad left-pad :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) (defun z-format-image-x->image-x (image x y width height) (declare (type image-x image) (type card16 x y width height) (clx-values image-x)) (let* ((padded-x (index+ x (image-x-left-pad image))) (left-pad (if (index= (image-depth image) 1) (index-mod padded-x 8) 0)) (x (index- padded-x left-pad)) (bits-per-pixel (image-x-bits-per-pixel image)) (unit (image-x-unit image)) (byte-lsb-first-p (image-x-byte-lsb-first-p image)) (bit-lsb-first-p (image-x-bit-lsb-first-p image)) (pad (image-x-pad image)) (bits-per-line (index* (index+ width left-pad) bits-per-pixel)) (padded-bits-per-line (index* (index-ceiling bits-per-line pad) pad)) (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) (padded-bytes-per-plane (index* padded-bytes-per-line height)) (length (index* padded-bytes-per-plane (image-depth image))) (obuf (make-array length :element-type 'card8))) (declare (type card16 x) (type card8 left-pad) (type (member 8 16 32) unit pad) (type array-index bits-per-pixel padded-bytes-per-line padded-bytes-per-plane length) (type buffer-bytes obuf)) (write-z-format-image-x-data (image-x-data image) obuf 0 0 x y width height (image-x-bytes-per-line image) padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p unit byte-lsb-first-p bit-lsb-first-p) (create-image :width width :height height :depth (image-depth image) :data obuf :format :z-pixmap :bits-per-pixel bits-per-pixel :bytes-per-line padded-bytes-per-line :unit unit :pad pad :left-pad left-pad :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) (defun image-x->image-x (image x y width height) (declare (type image-x image) (type card16 x y width height) (clx-values image-x)) (ecase (image-x-format image) ((:bitmap :xy-pixmap) (xy-format-image-x->image-x image x y width height)) (:z-pixmap (z-format-image-x->image-x image x y width height)))) (defun image-x->image-xy (image x y width height) (declare (type image-x image) (type card16 x y width height) (clx-values image-xy)) (unless (or (eq (image-x-format image) :bitmap) (eq (image-x-format image) :xy-pixmap) (and (eq (image-x-format image) :z-pixmap) (index= (image-depth image) 1))) (error "Format conversion from ~S to ~S not supported" (image-x-format image) :xy-pixmap)) (read-image-xy (image-x-data image) 0 (length (image-x-data image)) nil (index+ x (image-x-left-pad image)) y width height (image-depth image) (image-x-bytes-per-line image) (index* (image-x-bytes-per-line image) (image-height image)) (image-x-unit image) (image-x-byte-lsb-first-p image) (image-x-bit-lsb-first-p image))) (defun image-x->image-z (image x y width height) (declare (type image-x image) (type card16 x y width height) (clx-values image-z)) (unless (or (eq (image-x-format image) :z-pixmap) (eq (image-x-format image) :bitmap) (and (eq (image-x-format image) :xy-pixmap) (index= (image-depth image) 1))) (error "Format conversion from ~S to ~S not supported" (image-x-format image) :z-pixmap)) (read-image-z (image-x-data image) 0 (length (image-x-data image)) nil (index+ x (image-x-left-pad image)) y width height (image-depth image) (image-x-bytes-per-line image) (image-x-bits-per-pixel image) (image-x-unit image) (image-x-byte-lsb-first-p image) (image-x-bit-lsb-first-p image))) (defun copy-pixarray (array x y width height bits-per-pixel) (declare (type pixarray array) (type card16 x y width height) (type (member 1 4 8 16 24 32) bits-per-pixel)) (let* ((bits-per-line (index* bits-per-pixel width)) (padded-bits-per-line (index* (index-ceiling bits-per-line +image-pad+) +image-pad+)) (padded-width (index-ceiling padded-bits-per-line bits-per-pixel)) (copy (make-array (list height padded-width) :element-type (array-element-type array)))) (declare (type array-index bits-per-line padded-bits-per-line padded-width) (type pixarray copy)) #.(declare-buffun) (unless (fast-copy-pixarray array copy x y width height bits-per-pixel) (macrolet ((copy (array-type element-type) `(let ((array array) (copy copy)) (declare (type ,array-type array copy)) (do* ((dst-y 0 (index1+ dst-y)) (src-y y (index1+ src-y))) ((index>= dst-y height)) (declare (type card16 dst-y src-y)) (do* ((dst-x 0 (index1+ dst-x)) (src-x x (index1+ src-x))) ((index>= dst-x width)) (declare (type card16 dst-x src-x)) (setf (aref copy dst-y dst-x) (the ,element-type (aref array src-y src-x)))))))) (ecase bits-per-pixel (1 (copy pixarray-1 pixarray-1-element-type)) (4 (copy pixarray-4 pixarray-4-element-type)) (8 (copy pixarray-8 pixarray-8-element-type)) (16 (copy pixarray-16 pixarray-16-element-type)) (24 (copy pixarray-24 pixarray-24-element-type)) (32 (copy pixarray-32 pixarray-32-element-type))))) copy)) (defun image-xy->image-x (image x y width height) (declare (type image-xy image) (type card16 x y width height) (clx-values image-x)) (let* ((padded-bits-per-line (index* (index-ceiling width +image-pad+) +image-pad+)) (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) (padded-bytes-per-plane (index* padded-bytes-per-line height)) (bytes-total (index* padded-bytes-per-plane (image-depth image))) (data (make-array bytes-total :element-type 'card8))) (declare (type array-index padded-bits-per-line padded-bytes-per-line padded-bytes-per-plane bytes-total) (type buffer-bytes data)) (let ((index 0)) (declare (type array-index index)) (dolist (bitmap (image-xy-bitmap-list image)) (declare (type pixarray-1 bitmap)) (write-pixarray data index bitmap x y width height padded-bytes-per-line 1 +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+) (index-incf index padded-bytes-per-plane))) (create-image :width width :height height :depth (image-depth image) :data data :format :xy-pixmap :bits-per-pixel 1 :bytes-per-line padded-bytes-per-line :unit +image-unit+ :pad +image-pad+ :byte-lsb-first-p +image-byte-lsb-first-p+ :bit-lsb-first-p +image-bit-lsb-first-p+))) (defun image-xy->image-xy (image x y width height) (declare (type image-xy image) (type card16 x y width height) (clx-values image-xy)) (create-image :width width :height height :depth (image-depth image) :data (mapcar #'(lambda (array) (declare (type pixarray-1 array)) (copy-pixarray array x y width height 1)) (image-xy-bitmap-list image)))) (defun image-xy->image-z (image x y width height) (declare (type image-xy image) (type card16 x y width height) (ignore image x y width height)) (error "Format conversion from ~S to ~S not supported" :xy-pixmap :z-pixmap)) (defun image-z->image-x (image x y width height) (declare (type image-z image) (type card16 x y width height) (clx-values image-x)) (let* ((bits-per-line (index* width (image-z-bits-per-pixel image))) (padded-bits-per-line (index* (index-ceiling bits-per-line +image-pad+) +image-pad+)) (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) (bytes-total (index* padded-bytes-per-line height (image-depth image))) (data (make-array bytes-total :element-type 'card8)) (bits-per-pixel (image-z-bits-per-pixel image))) (declare (type array-index bits-per-line padded-bits-per-line padded-bytes-per-line bytes-total) (type buffer-bytes data) (type (member 1 4 8 16 24 32) bits-per-pixel)) (write-pixarray data 0 (image-z-pixarray image) x y width height padded-bytes-per-line (image-z-bits-per-pixel image) +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+) (create-image :width width :height height :depth (image-depth image) :data data :format :z-pixmap :bits-per-pixel bits-per-pixel :bytes-per-line padded-bytes-per-line :unit +image-unit+ :pad +image-pad+ :byte-lsb-first-p +image-byte-lsb-first-p+ :bit-lsb-first-p +image-bit-lsb-first-p+))) (defun image-z->image-xy (image x y width height) (declare (type image-z image) (type card16 x y width height) (ignore image x y width height)) (error "Format conversion from ~S to ~S not supported" :z-pixmap :xy-pixmap)) (defun image-z->image-z (image x y width height) (declare (type image-z image) (type card16 x y width height) (clx-values image-z)) (create-image :width width :height height :depth (image-depth image) :data (copy-pixarray (image-z-pixarray image) x y width height (image-z-bits-per-pixel image)))) (defun copy-image (image &key (x 0) (y 0) width height result-type) ;; Copy with optional sub-imaging and format conversion. ;; result-type defaults to (type-of image) (declare (type image image) (type card16 x y) (type (or null card16) width height) ;; Default from image (type (or null (member image-x image-xy image-z)) result-type)) (declare (clx-values image)) (let* ((image-width (image-width image)) (image-height (image-height image)) (width (or width image-width)) (height (or height image-height))) (declare (type card16 image-width image-height width height)) (unless (<= 0 x (the fixnum (1- image-width))) (error "x not inside image")) (unless (<= 0 y (the fixnum (1- image-height))) (error "y not inside image")) (setq width (index-min width (max (the fixnum (- image-width x)) 0))) (setq height (index-min height (max (the fixnum (- image-height y)) 0))) (let ((copy (etypecase image (image-x (ecase result-type ((nil image-x) (image-x->image-x image x y width height)) (image-xy (image-x->image-xy image x y width height)) (image-z (image-x->image-z image x y width height)))) (image-xy (ecase result-type (image-x (image-xy->image-x image x y width height)) ((nil image-xy) (image-xy->image-xy image x y width height)) (image-z (image-xy->image-z image x y width height)))) (image-z (ecase result-type (image-x (image-z->image-x image x y width height)) (image-xy (image-z->image-xy image x y width height)) ((nil image-z) (image-z->image-z image x y width height))))))) (declare (type image copy)) (setf (image-plist copy) (copy-list (image-plist image))) (when (and (image-x-hot image) (not (index-zerop x))) (setf (image-x-hot copy) (index- (image-x-hot image) x))) (when (and (image-y-hot image) (not (index-zerop y))) (setf (image-y-hot copy) (index- (image-y-hot image) y))) copy))) ;;;----------------------------------------------------------------------------- ;;; Image I/O functions (defun read-bitmap-file (pathname) ;; Creates an image from a C include file in standard X11 format (declare (type (or pathname string stream) pathname)) (declare (clx-values image)) (with-open-file (fstream pathname :direction :input) (let ((line "") (properties nil) (name nil) (name-end nil)) (declare (type string line) (type stringable name) (type list properties)) ;; Get properties (loop (setq line (read-line fstream)) (unless (char= (aref line 0) #\#) (return)) (flet ((read-keyword (line start end) (kintern (substitute #\- #\_ (#-excl string-upcase #+excl correct-case (subseq line start end)) :test #'char=)))) (when (null name) (setq name-end (position #\_ line :test #'char= :from-end t) name (read-keyword line 8 name-end)) (unless (eq name :image) (setf (getf properties :name) name))) (let* ((ind-start (index1+ name-end)) (ind-end (position #\Space line :test #'char= :start ind-start)) (ind (read-keyword line ind-start ind-end)) (val-start (index1+ ind-end)) (val (parse-integer line :start val-start))) (setf (getf properties ind) val)))) ;; Calculate sizes (multiple-value-bind (width height depth left-pad) (flet ((extract-property (ind &rest default) (prog1 (apply #'getf properties ind default) (remf properties ind)))) (values (extract-property :width) (extract-property :height) (extract-property :depth 1) (extract-property :left-pad 0))) (declare (type (or null card16) width height) (type image-depth depth) (type card8 left-pad)) (unless (and width height) (error "Not a BITMAP file")) (let* ((bits-per-pixel (cond ((index> depth 24) 32) ((index> depth 16) 24) ((index> depth 8) 16) ((index> depth 4) 8) ((index> depth 1) 4) (t 1))) (bits-per-line (index* width bits-per-pixel)) (bytes-per-line (index-ceiling bits-per-line 8)) (padded-bits-per-line (index* (index-ceiling bits-per-line 32) 32)) (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) (data (make-array (* padded-bytes-per-line height) :element-type 'card8)) (line-base 0) (byte 0)) (declare (type array-index bits-per-line bytes-per-line padded-bits-per-line padded-bytes-per-line line-base byte) (type buffer-bytes data)) (with-vector (data buffer-bytes) (flet ((parse-hex (char) (second (assoc char '((#\0 0) (#\1 1) (#\2 2) (#\3 3) (#\4 4) (#\5 5) (#\6 6) (#\7 7) (#\8 8) (#\9 9) (#\a 10) (#\b 11) (#\c 12) (#\d 13) (#\e 14) (#\f 15)) :test #'char-equal)))) (declare (inline parse-hex)) ;; Read data ;; Note: using read-line instead of read-char would be 20% faster, ;; but would cons a lot of garbage... (dotimes (i height) (dotimes (j bytes-per-line) (loop (when (eql (read-char fstream) #\x) (return))) (setf (aref data (index+ line-base byte)) (index+ (index-ash (parse-hex (read-char fstream)) 4) (parse-hex (read-char fstream)))) (incf byte)) (setq byte 0 line-base (index+ line-base padded-bytes-per-line))))) ;; Compensate for left-pad in width and x-hot (index-decf width left-pad) (when (and (getf properties :x-hot) (plusp (getf properties :x-hot))) (index-decf (getf properties :x-hot) left-pad)) (create-image :width width :height height :depth depth :bits-per-pixel bits-per-pixel :data data :plist properties :format :z-pixmap :bytes-per-line padded-bytes-per-line :unit 32 :pad 32 :left-pad left-pad :byte-lsb-first-p t :bit-lsb-first-p t)))))) (defun write-bitmap-file (pathname image &optional name) ;; Writes an image to a C include file in standard X11 format ;; NAME argument used for variable prefixes. Defaults to "image" (declare (type (or pathname string stream) pathname) (type image image) (type (or null stringable) name)) (unless (typep image 'image-x) (setq image (copy-image image :result-type 'image-x))) (let* ((plist (image-plist image)) (name (or name (image-name image) 'image)) (left-pad (image-x-left-pad image)) (width (index+ (image-width image) left-pad)) (height (image-height image)) (depth (if (eq (image-x-format image) :z-pixmap) (image-depth image) 1)) (bits-per-pixel (image-x-bits-per-pixel image)) (bits-per-line (index* width bits-per-pixel)) (bytes-per-line (index-ceiling bits-per-line 8)) (last (index* bytes-per-line height)) (count 0)) (declare (type list plist) (type stringable name) (type card8 left-pad) (type card16 width height) (type (member 1 4 8 16 24 32) bits-per-pixel) (type image-depth depth) (type array-index bits-per-line bytes-per-line count last)) ;; Move x-hot by left-pad, if there is an x-hot, so image readers that ;; don't know about left pad get the hot spot in the right place. We have ;; already increased width by left-pad. (when (getf plist :x-hot) (setq plist (copy-list plist)) (index-incf (getf plist :x-hot) left-pad)) (with-image-data-buffer (data last) (multiple-value-bind (image-swap-function image-swap-lsb-first-p) (image-swap-function bits-per-pixel (image-x-unit image) (image-x-byte-lsb-first-p image) (image-x-bit-lsb-first-p image) 32 t t) (declare (type symbol image-swap-function) (type generalized-boolean image-swap-lsb-first-p)) (funcall (symbol-function image-swap-function) (image-x-data image) data 0 0 bytes-per-line (image-x-bytes-per-line image) bytes-per-line height image-swap-lsb-first-p)) (with-vector (data buffer-bytes) (setq name (string-downcase (string name))) (with-open-file (fstream pathname :direction :output) (format fstream "#define ~a_width ~d~%" name width) (format fstream "#define ~a_height ~d~%" name height) (unless (= depth 1) (format fstream "#define ~a_depth ~d~%" name depth)) (unless (zerop left-pad) (format fstream "#define ~a_left_pad ~d~%" name left-pad)) (do ((prop plist (cddr prop))) ((endp prop)) (when (and (not (member (car prop) '(:width :height))) (numberp (cadr prop))) (format fstream "#define ~a_~a ~d~%" name (substitute #\_ #\- (string-downcase (string (car prop))) :test #'char=) (cadr prop)))) (format fstream "static char ~a_bits[] = {" name) (dotimes (i height) (dotimes (j bytes-per-line) (when (zerop (index-mod count 15)) (terpri fstream) (write-char #\space fstream)) (write-string "0x" fstream) ;; Faster than (format fstream "0x~2,'0x," byte) (let ((byte (aref data count)) (translate "0123456789abcdef")) (declare (type card8 byte)) (write-char (char translate (ldb (byte 4 4) byte)) fstream) (write-char (char translate (ldb (byte 4 0) byte)) fstream)) (index-incf count) (unless (index= count last) (write-char #\, fstream)))) (format fstream "};~%")))))) (defun bitmap-image (&optional plist &rest patterns) ;; Create an image containg pattern ;; PATTERNS are bit-vector constants (e.g. #*10101) ;; If the first parameter is a list, its used as the image property-list. (declare (type (or list bit-vector) plist) (type list patterns)) ;; list of bitvector (declare (clx-values image)) (unless (listp plist) (push plist patterns) (setq plist nil)) (let* ((width (length (first patterns))) (height (length patterns)) (bitarray (make-array (list height width) :element-type 'bit)) (row 0)) (declare (type card16 width height row) (type pixarray-1 bitarray)) (dolist (pattern patterns) (declare (type simple-bit-vector pattern)) (dotimes (col width) (declare (type card16 col)) (setf (aref bitarray row col) (the bit (aref pattern col)))) (incf row)) (create-image :width width :height height :plist plist :data bitarray))) (defun image-pixmap (drawable image &key gcontext width height depth) ;; Create a pixmap containing IMAGE. Size defaults from the image. ;; DEPTH is the pixmap depth. ;; GCONTEXT is used for putting the image into the pixmap. ;; If none is supplied, then one is created, used then freed. (declare (type drawable drawable) (type image image) (type (or null gcontext) gcontext) (type (or null card16) width height) (type (or null card8) depth)) (declare (clx-values pixmap)) (let* ((image-width (image-width image)) (image-height (image-height image)) (image-depth (image-depth image)) (width (or width image-width)) (height (or height image-height)) (depth (or depth image-depth)) (pixmap (create-pixmap :drawable drawable :width width :height height :depth depth)) (gc (or gcontext (create-gcontext :drawable pixmap :foreground 1 :background 0)))) (unless (= depth image-depth) (if (= image-depth 1) (unless gcontext (xlib::required-arg gcontext)) (error "Pixmap depth ~d incompatable with image depth ~d" depth image-depth))) (put-image pixmap gc image :x 0 :y 0 :bitmap-p (and (= image-depth 1) gcontext)) ;; Tile when image-width is less than the pixmap width, or ;; the image-height is less than the pixmap height. ;; ??? Would it be better to create a temporary pixmap and ;; ??? let the server do the tileing? (do ((x image-width (+ x image-width))) ((>= x width)) (copy-area pixmap gc 0 0 image-width image-height pixmap x 0) (incf image-width image-width)) (do ((y image-height (+ y image-height))) ((>= y height)) (copy-area pixmap gc 0 0 image-width image-height pixmap 0 y) (incf image-height image-height)) (unless gcontext (free-gcontext gc)) pixmap)) cl-clx-sbcl-0.7.4.20160323.orig/exclMakefile0000644000175000017500000001214412715665272016140 0ustar pdmpdm# # Makefile for CLX # (X11 R4.4 release, Franz Allegro Common Lisp version) # # ************************************************************************* # * Change the next line to point to where you have Common Lisp installed * # * (make sure the Lisp doesn't already have CLX loaded in) * # ************************************************************************* CL = /usr/local/bin/cl RM = /bin/rm SHELL = /bin/sh ECHO = /bin/echo TAGS = /usr/local/lib/emacs/etc/etags # Name of dumped lisp CLX = CLX CLOPTS = -qq # Use this one for Suns CFLAGS = -O -DUNIXCONN # Use this one for Silicon Graphics & Mips Inc MIPS based machines # CFLAGS = -O -G 0 -I/usr/include/bsd # Use this one for DEC MIPS based machines # CFLAGS = -O -G 0 -DUNIXCONN # Use this one for HP machines # CFLAGS = -O -DSYSV -DUNIXCONN # Lisp optimization for compiling SPEED = 3 SAFETY = 0 C_SRC = excldep.c socket.c C_OBJS = excldep.o socket.o L_OBJS = defsystem.fasl package.fasl excldep.fasl depdefs.fasl clx.fasl \ dependent.fasl exclcmac.fasl macros.fasl bufmac.fasl buffer.fasl \ display.fasl gcontext.fasl requests.fasl input.fasl fonts.fasl \ graphics.fasl text.fasl attributes.fasl translate.fasl keysyms.fasl \ manager.fasl image.fasl resource.fasl L_NOMACROS_OBJS = package.fasl excldep.fasl depdefs.fasl clx.fasl \ dependent.fasl buffer.fasl display.fasl gcontext.fasl \ requests.fasl input.fasl fonts.fasl graphics.fasl text.fasl \ attributes.fasl translate.fasl keysyms.fasl manager.fasl image.fasl \ resource.fasl L_SRC = defsystem.cl package.cl excldep.cl depdefs.cl clx.cl \ dependent.cl exclcmac.cl macros.cl bufmac.cl buffer.cl \ display.cl gcontext.cl requests.cl input.cl fonts.cl \ graphics.cl text.cl attributes.cl translate.cl keysyms.cl \ manager.cl image.cl resource.cl # default and aliases all: no-clos # all: partial-clos compile-CLX-for-CLUE: compile-partial-clos-CLX clue: partial-clos # # Three build rules are provided: no-clos, partial-clos, and full-clos. # The first is no-clos, which results in a CLX whose datastructures are # all defstructs. partial-clos results in xlib:window, xlib:pixmap, and # xlib:drawable being CLOS instances, all others defstructs. full-clos # makes all CLX complex datatypes into CLOS instances. # # (note that the :clos feature implies native CLOS *not* PCL). # no-clos: $(C_OBJS) compile-no-clos-CLX cat # # This rule is used to compile CLX to be used with XCW version 2, or CLUE. # partial-clos: $(C_OBJS) compile-partial-clos-CLX cat full-clos: $(C_OBJS) compile-full-clos-CLX cat c: $(C_OBJS) compile-no-clos-CLX: $(C_OBJS) $(ECHO) " \ (set-case-mode :case-sensitive-lower) \ (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ #+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \ (load \"defsystem\") \ #+allegro (compile-system :clx) \ #-allegro (compile-clx) \ #+allegro (compile-system :clx-debug)" \ | $(CL) $(CLOPTS) -batch compile-partial-clos-CLX: $(C_OBJS) $(ECHO) " \ #+clos (set-case-mode :case-sensitive-lower) \ #-clos (setq excl::*print-nickname* t) \ (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ (unless (or (find-package 'clos) (find-package 'pcl)) \ (let ((spread (sys:gsgc-parameter :generation-spread))) \ (setf (sys:gsgc-parameter :generation-spread) 1) \ (require :pcl) \ (provide :pcl) \ (gc) (gc) \ (setf (sys:gsgc-parameter :generation-spread) spread))) \ #+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \ (load \"defsystem\") \ (load \"package\") \ (setq xlib::*def-clx-class-use-defclass* '(xlib:window xlib:pixmap xlib:drawable)) \ #+allegro (compile-system :clx) \ #-allegro (compile-clx \"\" \"\" :for-clue t) \ #+allegro (compile-system :clx-debug)" \ | $(CL) $(CLOPTS) -batch compile-full-clos-CLX: $(C_OBJS) $(ECHO) " \ #+clos (set-case-mode :case-sensitive-lower) \ #-clos (setq excl::*print-nickname* t) \ (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ (unless (or (find-package 'clos) (find-package 'pcl)) \ (let ((spread (sys:gsgc-parameter :generation-spread))) \ (setf (sys:gsgc-parameter :generation-spread) 1) \ (require :pcl) \ (provide :pcl) \ (gc) (gc) \ (setf (sys:gsgc-parameter :generation-spread) spread))) \ #+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \ (load \"defsystem\") \ (load \"package\") \ (setq xlib::*def-clx-class-use-defclass* t) \ #+allegro (compile-system :clx) \ #-allegro (compile-clx \"\" \"\" :for-clue t) \ #+allegro (compile-system :clx-debug)" \ | $(CL) $(CLOPTS) -batch cat: -cat $(L_NOMACROS_OBJS) > CLX.fasl load-CLX: $(ECHO) " \ (let ((spread (sys:gsgc-parameter :generation-spread))) \ (setf (sys:gsgc-parameter :generation-spread) 1) \ (load \"defsystem\") \ #+allegro (load-system :clx) \ #-allegro (load-clx) \ (gc :tenure) \ (setf (sys:gsgc-parameter :generation-spread) spread)) \ (gc t)" \ '(dumplisp :name "$(CLX)" #+allegro :checkpoint #+allegro nil)' \ "(exit)" | $(CL) $(CLOPTS) clean: $(RM) -f *.fasl debug/*.fasl $(CLX) core $(C_OBJS) make.out install: mv CLX.fasl $(DEST)/clx.fasl mv *.o $(DEST) tags: $(TAGS) $(L_SRC) $(C_SRC) cl-clx-sbcl-0.7.4.20160323.orig/README0000644000175000017500000000654012715665271014506 0ustar pdmpdmCLX is an X11 client library for Common Lisp. The code was originally taken from a CMUCL distribution, was modified somewhat in order to make it compile and run under SBCL, then a selection of patches were added from other CLXes around the net. = Features - SHAPE extension support (Gilbert Baumann) - XFREE86-VIDMODE extension support (Iban Hatchondo) - experimental RENDER extension support (Gilbert Baumann and Christian Sunesson) - X authority support that works with ssh forwarding (Eric Marsden via CMUCL) - OPEN-DEFAULT-DISPLAY function which, as the name suggests, does that (dan) - various bug fixes (Iban Hatchondo and a cast of several) - a manual in texinfo format (Shawn Betts, Gilbert Baumann) = Compatibility This CLX distribution is intended to work under the latest released version of SBCL - please report the bug if it doesn't. It should usually also work with earlier versions back to 0.9.0, and possibly earlier still, but may need manual adjustment to the clx.asd file (to remove use of newly-introduced features). It has also been used as a basis for CLX ports on other Lisp implementations, but these instructions are only good for SBCL. If you've installed this using some non-SBCL Lisp, please send mail describing the process so that future versions can incorporate your instructions. If you are following SBCL CVS and this CLX does not run in it, please check the git repository for this CLX distribution to see if your bug has been fixed already. git clone git://github.com/sharplispers/clx.git = Building using quicklisp * (ql:quickload 'clx) = Building by hand If you don't trust quicklisp, here's how to do it manually - 1. Add a symlink to clx.asd from one of the directories listed in your asdf:*central-registry* If that makes no sense to you yet, choose one of - 1a. personal installation: $ cd $HOME/.sbcl/systems # you may have to create this directory $ ln -s /path/to/clx/source/clx.asd . 1b. systemwide installations: you need to ask SBCL where it lives $ sbcl --noinform --eval '(format t "~A~%" (posix-getenv "SBCL_HOME"))' ASDFized version by Daniel Barlow and Christophe Rhodes The sharplispers group on github have recently (November 2011) "adopted" clx and maintain the version that lives at: https://github.com/sharplispers/clx cl-clx-sbcl-0.7.4.20160323.orig/test/0000755000175000017500000000000012715665272014601 5ustar pdmpdmcl-clx-sbcl-0.7.4.20160323.orig/test/trapezoid.lisp0000644000175000017500000000451612715665272017501 0ustar pdmpdm;;; -*- 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 () ;; Display the part picture in /extensions/test/datafile (let* ((display (open-default-display)) (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 (draw-filled-trapezoids window gc '(10 20 30 40 100 200)) (setf (gcontext-trapezoid-alignment gc) :y) (draw-filled-trapezoids window gc #(10 20 30 40 100 200)) (with-gcontext (gc :trapezoid-alignment :x) (draw-filled-trapezoids window gc '(40 50 60 70 140 240))) (setf (gcontext-trapezoid-alignment gc) :x) (draw-filled-trapezoids window gc #(40 50 60 70 80 90)) (with-gcontext (gc :trapezoid-alignment :y) (draw-filled-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)))) cl-clx-sbcl-0.7.4.20160323.orig/test/image.lisp0000644000175000017500000001246712715665272016566 0ustar pdmpdm;;; -*- 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*)) (declare (ignore host)) (let* ((display nil) (abort t) (images nil)) (loop (setq images nil) (unwind-protect (progn (setq display (open-default-display)) (let* ((screen (display-default-screen display)) (window (screen-root screen)) (gcontext (create-gcontext :foreground (screen-white-pixel screen) :background (screen-black-pixel screen) :drawable window :font (open-font display "fixed")))) (dotimes (i nimages) (let ((image (image-test-get-image window get-image-result-type-choices get-image-image-x-format-choices))) (format t "~&Image=~S~%" image) (let ((copy (if copy (image-test-copy-image image copy-random-subimage) image))) (format t "~&Copy=~S~%" copy) (push (list image copy) images) (image-test-put-image screen gcontext copy (concatenate 'string (image-info image) (image-info copy)) put-random-subimage)))) (unless (y-or-n-p "More ") (return)) (setq abort nil))) (close-display (shiftf display nil) :abort abort)) (sleep 10)) (reverse images))) (defun image-test-choose (list) (nth (random (length list)) list)) (defun image-test-get-image (window result-type-choices image-x-format-choices) (let* ((x (random (floor (drawable-width window) 3))) (y (random (floor (drawable-height window) 3))) (hw (floor (- (drawable-width window) x) 3)) (hh (floor (- (drawable-height window) y) 3)) (width (+ hw hw (random hw))) (height (+ hh hh (random hh))) (result-type (image-test-choose result-type-choices)) (format (ecase result-type (image-x (image-test-choose image-x-format-choices)) (image-xy :xy-pixmap) (image-z :z-pixmap))) (image (get-image window :x x :y y :width width :height height :format format :result-type result-type))) (setf (getf (image-plist image) :root-x) x) (setf (getf (image-plist image) :root-y) 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) (incf (getf (image-plist image) :root-x) x) (incf (getf (image-plist image) :root-y) y) (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) (root-x (getf (image-plist image) :root-x)) (root-y (getf (image-plist image) :root-y)) (x (+ src-x root-x (- border-width))) (y (+ src-y root-y (- 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 "))) cl-clx-sbcl-0.7.4.20160323.orig/excldep.lisp0000644000175000017500000003333112715665272016142 0ustar pdmpdm;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*- ;;; ;;; CLX -- excldep.cl ;;; ;;; Copyright (c) 1987, 1988, 1989 Franz Inc, Berkeley, Ca. ;;; ;;; Permission is granted to any individual or institution to use, copy, ;;; modify, and distribute this software, provided that this complete ;;; copyright and permission notice is maintained, intact, in all copies and ;;; supporting documentation. ;;; ;;; Franz Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (in-package :xlib) (eval-when (compile load eval) (require :foreign) (require :process) ; Needed even if scheduler is not ; running. (Must be able to make ; a process-lock.) ) (eval-when (load) (provide :clx)) #-(or little-endian big-endian) (eval-when (eval compile load) (let ((x '#(1))) (if (not (eq 0 (sys::memref x #.(sys::mdparam 'comp::md-lvector-data0-norm) 0 :unsigned-byte))) (pushnew :little-endian *features*) (pushnew :big-endian *features*)))) (defmacro correct-case (string) ;; This macro converts the given string to the ;; current preferred case, or leaves it alone in a case-sensitive mode. (let ((str (gensym))) `(let ((,str ,string)) (case excl::*current-case-mode* (:case-insensitive-lower (string-downcase ,str)) (:case-insensitive-upper (string-upcase ,str)) ((:case-sensitive-lower :case-sensitive-upper) ,str))))) (defconstant type-pred-alist '(#-(version>= 4 1 devel 16) (card8 . card8p) #-(version>= 4 1 devel 16) (card16 . card16p) #-(version>= 4 1 devel 16) (card29 . card29p) #-(version>= 4 1 devel 16) (card32 . card32p) #-(version>= 4 1 devel 16) (int8 . int8p) #-(version>= 4 1 devel 16) (int16 . int16p) #-(version>= 4 1 devel 16) (int32 . int32p) #-(version>= 4 1 devel 16) (mask16 . card16p) #-(version>= 4 1 devel 16) (mask32 . card32p) #-(version>= 4 1 devel 16) (pixel . card32p) #-(version>= 4 1 devel 16) (resource-id . card29p) #-(version>= 4 1 devel 16) (keysym . card32p) (angle . anglep) (color . color-p) (bitmap-format . bitmap-format-p) (pixmap-format . pixmap-format-p) (display . display-p) (drawable . drawable-p) (window . window-p) (pixmap . pixmap-p) (visual-info . visual-info-p) (colormap . colormap-p) (cursor . cursor-p) (gcontext . gcontext-p) (screen . screen-p) (font . font-p) (image-x . image-x-p) (image-xy . image-xy-p) (image-z . image-z-p) (wm-hints . wm-hints-p) (wm-size-hints . wm-size-hints-p) )) ;; This (if (and ...) t nil) stuff has a purpose -- it lets the old ;; sun4 compiler opencode the `and'. #-(version>= 4 1 devel 16) (defun card8p (x) (declare (optimize (speed 3) (safety 0)) (fixnum x)) (if (and (excl:fixnump x) (> #.(expt 2 8) x) (>= x 0)) t nil)) #-(version>= 4 1 devel 16) (defun card16p (x) (declare (optimize (speed 3) (safety 0)) (fixnum x)) (if (and (excl:fixnump x) (> #.(expt 2 16) x) (>= x 0)) t nil)) #-(version>= 4 1 devel 16) (defun card29p (x) (declare (optimize (speed 3) (safety 0))) (if (or (and (excl:fixnump x) (>= (the fixnum x) 0)) (and (excl:bignump x) (> #.(expt 2 29) (the bignum x)) (>= (the bignum x) 0))) t nil)) #-(version>= 4 1 devel 16) (defun card32p (x) (declare (optimize (speed 3) (safety 0))) (if (or (and (excl:fixnump x) (>= (the fixnum x) 0)) (and (excl:bignump x) (> #.(expt 2 32) (the bignum x)) (>= (the bignum x) 0))) t nil)) #-(version>= 4 1 devel 16) (defun int8p (x) (declare (optimize (speed 3) (safety 0)) (fixnum x)) (if (and (excl:fixnump x) (> #.(expt 2 7) x) (>= x #.(expt -2 7))) t nil)) #-(version>= 4 1 devel 16) (defun int16p (x) (declare (optimize (speed 3) (safety 0)) (fixnum x)) (if (and (excl:fixnump x) (> #.(expt 2 15) x) (>= x #.(expt -2 15))) t nil)) #-(version>= 4 1 devel 16) (defun int32p (x) (declare (optimize (speed 3) (safety 0))) (if (or (excl:fixnump x) (and (excl:bignump x) (> #.(expt 2 31) (the bignum x)) (>= (the bignum x) #.(expt -2 31)))) t nil)) ;; This one can be handled better by knowing a little about what we're ;; testing for. Plus this version can handle (single-float pi), which ;; is otherwise larger than pi! (defun anglep (x) (declare (optimize (speed 3) (safety 0))) (if (or (and (excl::fixnump x) (>= (the fixnum x) #.(truncate (* -2 pi))) (<= (the fixnum x) #.(truncate (* 2 pi)))) (and (excl::single-float-p x) (>= (the single-float x) #.(float (* -2 pi) 0.0s0)) (<= (the single-float x) #.(float (* 2 pi) 0.0s0))) (and (excl::double-float-p x) (>= (the double-float x) #.(float (* -2 pi) 0.0d0)) (<= (the double-float x) #.(float (* 2 pi) 0.0d0)))) t nil)) (eval-when (load eval) #+(version>= 4 1 devel 16) (mapcar #'(lambda (elt) (excl:add-typep-transformer (car elt) (cdr elt))) type-pred-alist) #-(version>= 4 1 devel 16) (nconc excl::type-pred-alist type-pred-alist)) ;; Return t if there is a character available for reading or on error, ;; otherwise return nil. #-(version>= 6 0) (progn #-(or (version>= 4 2) mswindows) (defun fd-char-avail-p (fd) (multiple-value-bind (available-p errcode) (comp::.primcall-sargs 'sys::filesys excl::fs-char-avail fd) (excl:if* errcode then t else available-p))) #+(and (version>= 4 2) (not mswindows)) (defun fd-char-avail-p (fd) (excl::filesys-character-available-p fd)) #+mswindows (defun fd-char-avail-p (socket-stream) (listen socket-stream)) ) #+(version>= 6 0) (defun fd-char-avail-p (socket-stream) (excl::read-no-hang-p socket-stream)) (defmacro with-interrupt-checking-on (&body body) `(locally (declare (optimize (safety 1))) ,@body)) ;; Read from the given fd into 'vector', which has element type card8. ;; Start storing at index 'start-index' and read exactly 'length' bytes. ;; Return t if an error or eof occurred, nil otherwise. (defun fd-read-bytes (fd vector start-index length) ;; Read from the given stream fd into 'vector', which has element type card8. ;; Start storing at index 'start-index' and read exactly 'length' bytes. ;; Return t if an error or eof occurred, nil otherwise. (declare (fixnum next-index start-index length)) (with-interrupt-checking-on (let ((end-index (+ start-index length))) (loop (let ((next-index (excl:read-vector vector fd :start start-index :end end-index))) (excl:if* (eq next-index start-index) then ; end of file before was all filled up (return t) elseif (eq next-index end-index) then ; we're all done (return nil) else (setq start-index next-index))))))) ;; special patch for CLX (various process fixes) ;; patch1000.2 (eval-when (compile load eval) (unless (find-package :patch) (make-package :patch :use '(:lisp :excl)))) (in-package :patch) (defvar *patches* nil) #+allegro (eval-when (compile eval load) (when (and (= excl::cl-major-version-number 3) (or (= excl::cl-minor-version-number 0) (and (= excl::cl-minor-version-number 1) excl::cl-generation-number (< excl::cl-generation-number 9)))) (push :clx-r4-process-patches *features*))) #+clx-r4-process-patches (push (cons 1000.2 "special patch for CLX (various process fixes)") *patches*) (in-package :mp) #+clx-r4-process-patches (export 'wait-for-input-available) #+clx-r4-process-patches (defun with-timeout-event (seconds fnc args) (unless *scheduler-stack-group* (start-scheduler)) ;[spr670] (let ((clock-event (make-clock-event))) (when (<= seconds 0) (setq seconds 0)) (multiple-value-bind (secs msecs) (truncate seconds) ;; secs is now a nonegative integer, and msecs is either fixnum zero ;; or else something interesting. (unless (eq 0 msecs) (setq msecs (truncate (* 1000.0 msecs)))) ;; Now msecs is also a nonnegative fixnum. (multiple-value-bind (now mnow) (excl::cl-internal-real-time) (incf secs now) (incf msecs mnow) (when (>= msecs 1000) (decf msecs 1000) (incf secs)) (unless (excl:fixnump secs) (setq secs most-positive-fixnum)) (setf (clock-event-secs clock-event) secs (clock-event-msecs clock-event) msecs (clock-event-function clock-event) fnc (clock-event-args clock-event) args))) clock-event)) #+clx-r4-process-patches (defmacro with-timeout ((seconds &body timeout-body) &body body) `(let* ((clock-event (with-timeout-event ,seconds #'process-interrupt (cons *current-process* '(with-timeout-internal)))) (excl::*without-interrupts* t) ret) (unwind-protect ;; Warning: Branch tensioner better not reorder this code! (setq ret (catch 'with-timeout-internal (add-to-clock-queue clock-event) (let ((excl::*without-interrupts* nil)) (multiple-value-list (progn ,@body))))) (excl:if* (eq ret 'with-timeout-internal) then (let ((excl::*without-interrupts* nil)) (setq ret (multiple-value-list (progn ,@timeout-body)))) else (remove-from-clock-queue clock-event))) (values-list ret))) #+clx-r4-process-patches (defun process-lock (lock &optional (lock-value *current-process*) (whostate "Lock") timeout) (declare (optimize (speed 3))) (unless (process-lock-p lock) (error "First argument to PROCESS-LOCK must be a process-lock: ~s" lock)) (without-interrupts (excl:if* (null (process-lock-locker lock)) then (setf (process-lock-locker lock) lock-value) else (excl:if* timeout then (excl:if* (or (eq 0 timeout) ;for speed (zerop timeout)) then nil else (with-timeout (timeout) (process-lock-1 lock lock-value whostate))) else (process-lock-1 lock lock-value whostate))))) #+clx-r4-process-patches (defun process-lock-1 (lock lock-value whostate) (declare (type process-lock lock) (optimize (speed 3))) (let ((process *current-process*)) (declare (type process process)) (unless process (error "PROCESS-LOCK may not be called on the scheduler's stack group.")) (loop (unless (process-lock-locker lock) (return (setf (process-lock-locker lock) lock-value))) (push process (process-lock-waiting lock)) (let ((saved-whostate (process-whostate process))) (unwind-protect (progn (setf (process-whostate process) whostate) (process-add-arrest-reason process lock)) (setf (process-whostate process) saved-whostate)))))) #+clx-r4-process-patches (defun process-wait (whostate function &rest args) (declare (optimize (speed 3))) ;; Run the wait function once here both for efficiency and as a ;; first line check for errors in the function. (unless (apply function args) (process-wait-1 whostate function args))) #+clx-r4-process-patches (defun process-wait-1 (whostate function args) (declare (optimize (speed 3))) (let ((process *current-process*)) (declare (type process process)) (unless process (error "Process-wait may not be called within the scheduler's stack group.")) (let ((saved-whostate (process-whostate process))) (unwind-protect (without-scheduling-internal (without-interrupts (setf (process-whostate process) whostate (process-wait-function process) function (process-wait-args process) args) (chain-rem-q process) (chain-ins-q process *waiting-processes*)) (process-resume-scheduler nil)) (setf (process-whostate process) saved-whostate (process-wait-function process) nil (process-wait-args process) nil))))) #+clx-r4-process-patches (defun process-wait-with-timeout (whostate seconds function &rest args) ;; Now returns T upon completion, NIL upon timeout. -- 6Jun89 smh ;; [spr1135] [rfe939] Timeout won't throw out of interrupt level code. ;; -- 28Feb90 smh ;; Run the wait function once here both for efficiency and as a ;; first line check for errors in the function. (excl:if* (apply function args) then t else (let ((ret (list nil))) (without-interrupts (let ((clock-event (with-timeout-event seconds #'identity '(nil)))) (add-to-clock-queue clock-event) (process-wait-1 whostate #'(lambda (clock-event function args ret) (or (null (chain-next clock-event)) (and (apply function args) (setf (car ret) 't)))) (list clock-event function args ret)))) (car ret)))) ;; ;; Returns nil on timeout, otherwise t. ;; #+clx-r4-process-patches (defun wait-for-input-available (stream-or-fd &key (wait-function #'listen) (whostate "waiting for input") timeout) (let ((fd (excl:if* (excl:fixnump stream-or-fd) then stream-or-fd elseif (streamp stream-or-fd) then (excl::stream-input-fn stream-or-fd) else (error "wait-for-input-available expects a stream or file descriptor: ~s" stream-or-fd)))) ;; At this point fd could be nil, since stream-input-fn returns nil for ;; streams that are output only, or for certain special purpose streams. (if fd (unwind-protect (progn (mp::mpwatchfor fd) (excl:if* timeout then (mp::process-wait-with-timeout whostate timeout wait-function stream-or-fd) else (mp::process-wait whostate wait-function stream-or-fd) t)) (mp::mpunwatchfor fd)) (excl:if* timeout then (mp::process-wait-with-timeout whostate timeout wait-function stream-or-fd) else (mp::process-wait whostate wait-function stream-or-fd) t)))) cl-clx-sbcl-0.7.4.20160323.orig/resource.lisp0000644000175000017500000006323612715665272016354 0ustar pdmpdm;;; -*- Mode:Common-Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- ;; RESOURCE - Lisp version of XLIB's Xrm resource manager ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (in-package :xlib) ;; The C version of this uses a 64 entry hash table at each entry. ;; Small hash tables lose in Lisp, so we do linear searches on lists. (defstruct (resource-database (:copier nil) (:predicate nil) (:print-function print-resource-database) (:constructor make-resource-database-internal) #+explorer (:callable-constructors nil) ) (name nil :type stringable :read-only t) (value nil) (tight nil :type list) ;; List of resource-database (loose nil :type list) ;; List of resource-database ) (defun print-resource-database (database stream depth) (declare (type resource-database database) (ignore depth)) (print-unreadable-object (database stream :type t) (write-string (string (resource-database-name database)) stream) (when (resource-database-value database) (write-string " " stream) (prin1 (resource-database-value database) stream)))) ;; The value slot of the top-level resource-database structure is used for a ;; time-stamp. (defun make-resource-database () ;; Make a resource-database with initial timestamp of 0 (make-resource-database-internal :name "Top-Level" :value 0)) (defun resource-database-timestamp (database) (declare (type resource-database database)) (resource-database-value database)) (defun incf-resource-database-timestamp (database) ;; Increment the timestamp (declare (type resource-database database)) (let ((timestamp (resource-database-value database))) (setf (resource-database-value database) (if (= timestamp most-positive-fixnum) most-negative-fixnum (1+ timestamp))))) ;; DEBUG FUNCTION (not exported) (defun print-db (entry &optional (level 0) type) ;; Debug function to print a resource database (format t "~%~v@t~s~:[~; *~]~@[ Value ~s~]" level (resource-database-name entry) (eq type 'loose) (resource-database-value entry)) (when (resource-database-tight entry) (dolist (tight (resource-database-tight entry)) (print-db tight (+ 2 level) 'tight))) (when (resource-database-loose entry) (dolist (loose (resource-database-loose entry)) (print-db loose (+ 2 level) 'loose)))) ;; DEBUG FUNCTION #+comment (defun print-search-table (table) (terpri) (dolist (dbase-list table) (format t "~%~s" dbase-list) (dolist (db dbase-list) (print-db db) (dolist (dblist table) (unless (eq dblist dbase-list) (when (member db dblist) (format t " duplicate at ~s" db)))) ))) ;; ;; If this is true, resource symbols will be compared in a case-insensitive ;; manner, and converting a resource string to a keyword will uppercaseify it. ;; (defparameter *uppercase-resource-symbols* nil) (defun resource-key (stringable) ;; Ensure STRINGABLE is a keyword. (declare (type stringable stringable)) (etypecase stringable (symbol (if (keywordp (the symbol stringable)) stringable (kintern (symbol-name (the symbol stringable))))) (string (if *uppercase-resource-symbols* (setq stringable (#-allegro string-upcase #+allegro correct-case (the string stringable)))) (kintern (the string stringable))))) (defun stringable-equal (a b) ;; Compare two stringables. ;; Ignore case when comparing to a symbol. (declare (type stringable a b)) (declare (clx-values generalized-boolean)) (etypecase a (string (etypecase b (string (string= (the string a) (the string b))) (symbol (if *uppercase-resource-symbols* (string-equal (the string a) (the string (symbol-name (the symbol b)))) (string= (the string a) (the string (symbol-name (the symbol b)))))))) (symbol (etypecase b (string (if *uppercase-resource-symbols* (string-equal (the string (symbol-name (the symbol a))) (the string b)) (string= (the string (symbol-name (the symbol a))) (the string b)))) (symbol (string= (the string (symbol-name (the symbol a))) (the string (symbol-name (the symbol b))))))))) ;;;----------------------------------------------------------------------------- ;;; Add/delete resource (defun add-resource (database name-list value) ;; name-list is a list of either strings or symbols. If a symbol, ;; case-insensitive comparisons will be used, if a string, ;; case-sensitive comparisons will be used. The symbol '* or ;; string "*" are used as wildcards, matching anything or nothing. (declare (type resource-database database) (type (clx-list stringable) name-list) (type t value)) (unless value (error "Null resource values are ignored")) (incf-resource-database-timestamp database) (do* ((list name-list (cdr list)) (name (car list) (car list)) (node database) (loose-p nil)) ((endp list) (setf (resource-database-value node) value)) ;; Key is the first name that isn't * (if (stringable-equal name "*") (setq loose-p t) ;; find the entry associated with name (progn (do ((entry (if loose-p (resource-database-loose node) (resource-database-tight node)) (cdr entry))) ((endp entry) ;; Entry not found - create a new one (setq entry (make-resource-database-internal :name name)) (if loose-p (push entry (resource-database-loose node)) (push entry (resource-database-tight node))) (setq node entry)) (when (stringable-equal name (resource-database-name (car entry))) ;; Found entry - use it (return (setq node (car entry))))) (setq loose-p nil))))) (defun delete-resource (database name-list) (declare (type resource-database database) (type list name-list)) (incf-resource-database-timestamp database) (delete-resource-internal database name-list)) (defun delete-resource-internal (database name-list) (declare (type resource-database database) (type (clx-list stringable) name-list)) (do* ((list name-list (cdr list)) (string (car list) (car list)) (node database) (loose-p nil)) ((endp list) nil) ;; Key is the first name that isn't * (if (stringable-equal string "*") (setq loose-p t) ;; find the entry associated with name (progn (do* ((first-entry (if loose-p (resource-database-loose node) (resource-database-tight node))) (entry-list first-entry (cdr entry-list)) (entry (car entry-list) (car entry-list))) ((endp entry-list) ;; Entry not found - exit (return-from delete-resource-internal nil)) (when (stringable-equal string (resource-database-name entry)) (when (cdr list) (delete-resource-internal entry (cdr list))) (when (and (null (resource-database-loose entry)) (null (resource-database-tight entry))) (if loose-p (setf (resource-database-loose node) (delete entry (resource-database-loose node) :test #'eq :count 1)) (setf (resource-database-tight node) (delete entry (resource-database-tight node) :test #'eq :count 1)))) (return-from delete-resource-internal t))) (setq loose-p nil))))) ;;;----------------------------------------------------------------------------- ;;; Get Resource (defun get-resource (database value-name value-class full-name full-class) ;; Return the value of the resource in DATABASE whose partial name ;; most closely matches (append full-name (list value-name)) and ;; (append full-class (list value-class)). (declare (type resource-database database) (type stringable value-name value-class) (type (clx-list stringable) full-name full-class)) (declare (clx-values value)) (let ((names (append full-name (list value-name))) (classes (append full-class (list value-class)))) (let* ((result (get-entry (resource-database-tight database) (resource-database-loose database) names classes))) (when result (resource-database-value result))))) (defun get-entry-lookup (table name names classes) (declare (type list table names classes) (symbol name)) (dolist (entry table) (declare (type resource-database entry)) (when (stringable-equal name (resource-database-name entry)) (if (null (cdr names)) (return entry) (let ((result (get-entry (resource-database-tight entry) (resource-database-loose entry) (cdr names) (cdr classes)))) (declare (type (or null resource-database) result)) (when result (return result) )))))) (defun get-entry (tight loose names classes &aux result) (declare (type list tight loose names classes)) (let ((name (car names)) (class (car classes))) (declare (type symbol name class)) (cond ((and tight (get-entry-lookup tight name names classes))) ((and loose (get-entry-lookup loose name names classes))) ((and tight (not (stringable-equal name class)) (get-entry-lookup tight class names classes))) ((and loose (not (stringable-equal name class)) (get-entry-lookup loose class names classes))) (loose (loop (pop names) (pop classes) (unless (and names classes) (return nil)) (setq name (car names) class (car classes)) (when (setq result (get-entry-lookup loose name names classes)) (return result)) (when (and (not (stringable-equal name class)) (setq result (get-entry-lookup loose class names classes))) (return result)) ))))) ;;;----------------------------------------------------------------------------- ;;; Get-resource with search-table (defun get-search-resource (table name class) ;; (get-search-resource (get-search-table database full-name full-class) ;; value-name value-class) ;; is equivalent to ;; (get-resource database value-name value-class full-name full-class) ;; But since most of the work is done by get-search-table, ;; get-search-resource is MUCH faster when getting several resources with ;; the same full-name/full-class (declare (type list table) (type stringable name class)) (let ((do-class (and class (not (stringable-equal name class))))) (dolist (dbase-list table) (declare (type list dbase-list)) (dolist (dbase dbase-list) (declare (type resource-database dbase)) (when (stringable-equal name (resource-database-name dbase)) (return-from get-search-resource (resource-database-value dbase)))) (when do-class (dolist (dbase dbase-list) (declare (type resource-database dbase)) (when (stringable-equal class (resource-database-name dbase)) (return-from get-search-resource (resource-database-value dbase)))))))) (defvar *get-table-result*) (defun get-search-table (database full-name full-class) ;; Return a search table for use with get-search-resource. (declare (type resource-database database) (type (clx-list stringable) full-name full-class)) (declare (clx-values value)) (let* ((tight (resource-database-tight database)) (loose (resource-database-loose database)) (result (cons nil nil)) (*get-table-result* result)) (declare (type list tight loose) (type cons result)) (when (or tight loose) (when full-name (get-tables tight loose full-name full-class)) ;; Pick up bindings of the form (* name). These are the elements of ;; top-level loose without further tight/loose databases. ;; ;; (Hack: these bindings belong in ANY search table, so recomputing them ;; is a drag. True fix involves redesigning entire lookup ;; data-structure/algorithm.) ;; (let ((universal-bindings (remove nil loose :test-not #'eq :key #'(lambda (database) (or (resource-database-tight database) (resource-database-loose database)))))) (when universal-bindings (setf (cdr *get-table-result*) (list universal-bindings))))) (cdr result))) (defun get-tables-lookup (dbase name names classes) (declare (type list dbase names classes) (type symbol name)) (declare (optimize speed)) (dolist (entry dbase) (declare (type resource-database entry)) (when (stringable-equal name (resource-database-name entry)) (let ((tight (resource-database-tight entry)) (loose (resource-database-loose entry))) (declare (type list tight loose)) (when (or tight loose) (if (cdr names) (get-tables tight loose (cdr names) (cdr classes)) (when tight (let ((result *get-table-result*)) ;; Put tight at end of *get-table-result* (setf (cdr result) (setq *get-table-result* (cons tight nil)))))) (when loose (let ((result *get-table-result*)) ;; Put loose at end of *get-table-result* (setf (cdr result) (setq *get-table-result* (cons loose nil)))))))))) (defun get-tables (tight loose names classes) (declare (type list tight loose names classes)) (let ((name (car names)) (class (car classes))) (declare (type symbol name class)) (when tight (get-tables-lookup tight name names classes)) (when loose (get-tables-lookup loose name names classes)) (when (and tight (not (stringable-equal name class))) (get-tables-lookup tight class names classes)) (when (and loose (not (stringable-equal name class))) (get-tables-lookup loose class names classes)) (when loose (loop (pop names) (pop classes) (unless (and names classes) (return nil)) (setq name (car names) class (car classes)) (get-tables-lookup loose name names classes) (unless (stringable-equal name class) (get-tables-lookup loose class names classes)) )))) ;;;----------------------------------------------------------------------------- ;;; Utility functions (defun map-resource (database function &rest args) ;; Call FUNCTION on each resource in DATABASE. ;; FUNCTION is called with arguments (name-list value . args) (declare (type resource-database database) (type (function (list t &rest t) t) function) #+clx-ansi-common-lisp (dynamic-extent function) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg function) (dynamic-extent args)) (declare (clx-values nil)) (labels ((map-resource-internal (database function args name) (declare (type resource-database database) (type (function (list t &rest t) t) function) (type list name) #+clx-ansi-common-lisp (dynamic-extent function) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg function)) (let ((tight (resource-database-tight database)) (loose (resource-database-loose database))) (declare (type list tight loose)) (dolist (resource tight) (declare (type resource-database resource)) (let ((value (resource-database-value resource)) (name (append name (list (resource-database-name resource))))) (if value (apply function name value args) (map-resource-internal resource function args name)))) (dolist (resource loose) (declare (type resource-database resource)) (let ((value (resource-database-value resource)) (name (append name (list "*" (resource-database-name resource))))) (if value (apply function name value args) (map-resource-internal resource function args name))))))) (map-resource-internal database function args nil))) (defun merge-resources (database with-database) (declare (type resource-database database with-database)) (declare (clx-values resource-database)) (map-resource database #'(lambda (name value database) (add-resource database name value)) with-database) with-database) (defun char-memq (key char) ;; Used as a test function for POSITION (declare (type base-char char)) (member char key)) (defmacro resource-with-open-file ((stream pathname &rest options) &body body) ;; Private WITH-OPEN-FILE, which, when pathname is a stream, uses it as the ;; stream (let ((abortp (gensym)) (streamp (gensym))) `(let* ((,abortp t) (,streamp (streamp pathname)) (,stream (if ,streamp pathname (open ,pathname ,@options)))) (unwind-protect (multiple-value-prog1 (progn ,@body) (setq ,abortp nil)) (unless ,streamp (close stream :abort ,abortp)))))) (defun read-resources (database pathname &key key test test-not) ;; Merges resources from a file in standard X11 format with DATABASE. ;; KEY is a function used for converting value-strings, the default is ;; identity. TEST and TEST-NOT are predicates used for filtering ;; which resources to include in the database. They are called with ;; the name and results of the KEY function. (declare (type resource-database database) (type (or pathname string stream) pathname) (type (or null (function (string) t)) key) (type (or null (function (list t) generalized-boolean)) test test-not)) (declare (clx-values resource-database)) (resource-with-open-file (stream pathname) (loop (let ((string (read-line stream nil :eof))) (declare (type (or string keyword) string)) (when (eq string :eof) (return database)) (let* ((end (length string)) (i (position '(#\tab #\space) string :test-not #'char-memq :end end)) (term nil)) (declare (type array-index end) (type (or null array-index) i term)) (when i ;; else blank line (case (char string i) (#\! nil) ;; Comment - skip ;;(#.(card8->char 0) nil) ;; terminator for C strings - skip (#\# ;; Include (setq term (position '(#\tab #\space) string :test #'char-memq :start i :end end)) (when (string-equal string "#INCLUDE" :start1 i :end1 term) (let ((path (merge-pathnames (string-trim '(#\tab #\space #\") (subseq string (1+ term))) (truename stream)))) (read-resources database path :key key :test test :test-not test-not)))) (otherwise (multiple-value-bind (name-list value) (parse-resource string i end) (when name-list (when key (setq value (funcall key value))) (when (cond (test (funcall test name-list value)) (test-not (not (funcall test-not name-list value))) (t t)) (add-resource database name-list value)))))))))))) (defun parse-resource (string &optional (start 0) end) ;; Parse a resource specfication string into a list of names and a value ;; string (declare (type string string) (type array-index start) (type (or null array-index) end)) (declare (clx-values name-list value)) (do ((i start) (end (or end (length string))) (term) (name-list)) ((>= i end)) (declare (type array-index end) (type (or null array-index) i term)) (setq term (position '(#\. #\* #\:) string :test #'char-memq :start i :end end)) (case (and term (char string term)) ;; Name seperator (#\. (when (> term i) (push (subseq string i term) name-list))) ;; Wildcard seperator (#\* (when (> term i) (push (subseq string i term) name-list)) (push '* name-list)) ;; Value separator (#\: (push (subseq string i term) name-list) (return (values (nreverse name-list) (string-trim '(#\tab #\space) (subseq string (1+ term)))))) (otherwise (return (values (nreverse name-list) (subseq string i term))))) (setq i (1+ term)))) (defun write-resources (database pathname &key write test test-not) ;; Write resources to PATHNAME in the standard X11 format. ;; WRITE is a function used for writing values, the default is #'princ ;; TEST and TEST-NOT are predicates used for filtering which resources ;; to include in the database. They are called with the name and value. (declare (type resource-database database) (type (or pathname string stream) pathname) (type (or null (function (string stream) t)) write) (type (or null (function (list t) generalized-boolean)) test test-not)) (resource-with-open-file (stream pathname :direction :output) (map-resource database #'(lambda (name-list value stream write test test-not) (when (cond (test (funcall test name-list value)) (test-not (not (funcall test-not name-list value))) (t t)) (let ((previous (car name-list))) (princ previous stream) (dolist (name (cdr name-list)) (unless (or (stringable-equal name "*") (stringable-equal previous "*")) (write-char #\. stream)) (setq previous name) (princ name stream))) (write-string ": " stream) (funcall write value stream) (terpri stream))) stream (or write #'princ) test test-not)) database) (defun wm-resources (database window &key key test test-not) ;; Takes the resources associated with the RESOURCE_MANAGER property ;; of WINDOW (if any) and merges them with DATABASE. ;; KEY is a function used for converting value-strings, the default is ;; identity. TEST and TEST-NOT are predicates used for filtering ;; which resources to include in the database. They are called with ;; the name and results of the KEY function. (declare (type resource-database database) (type window window) (type (or null (function (string) t)) key) (type (or null (function (list t) generalized-boolean)) test test-not)) (declare (clx-values resource-database)) (let ((string (get-property window :RESOURCE_MANAGER :type :STRING :result-type 'string :transform #'xlib::card8->char))) (when string (with-input-from-string (stream string) (read-resources database stream :key key :test test :test-not test-not))))) (defun set-wm-resources (database window &key write test test-not) ;; Sets the resources associated with the RESOURCE_MANAGER property ;; of WINDOW. ;; WRITE is a function used for writing values, the default is #'princ ;; TEST and TEST-NOT are predicates used for filtering which resources ;; to include in the database. They are called with the name and value. (declare (type resource-database database) (type window window) (type (or null (function (string stream) t)) write) (type (or null (function (list t) generalized-boolean)) test test-not)) (xlib::set-string-property window :RESOURCE_MANAGER (with-output-to-string (stream) (write-resources database stream :write write :test test :test-not test-not)))) (defun root-resources (screen &key database key test test-not) "Returns a resource database containing the contents of the root window RESOURCE_MANAGER property for the given SCREEN. If SCREEN is a display, then its default screen is used. If an existing DATABASE is given, then resource values are merged with the DATABASE and the modified DATABASE is returned. TEST and TEST-NOT are predicates for selecting which resources are read. Arguments are a resource name list and a resource value. The KEY function, if given, is called to convert a resource value string to the value given to TEST or TEST-NOT." (declare (type (or screen display) screen) (type (or null resource-database) database) (type (or null (function (string) t)) key) (type (or null (function (list t) generalized-boolean)) test test-not) (clx-values resource-database)) (let* ((screen (if (type? screen 'display) (display-default-screen screen) screen)) (window (screen-root screen)) (database (or database (make-resource-database)))) (wm-resources database window :key key :test test :test-not test-not) database)) (defun set-root-resources (screen &key test test-not (write #'princ) database) "Changes the contents of the root window RESOURCE_MANAGER property for the given SCREEN. If SCREEN is a display, then its default screen is used. TEST and TEST-NOT are predicates for selecting which resources from the DATABASE are written. Arguments are a resource name list and a resource value. The WRITE function is used to convert a resource value into a string stored in the property." (declare (type (or screen display) screen) (type (or null resource-database) database) (type (or null (function (list t) generalized-boolean)) test test-not) (type (or null (function (string stream) t)) write) (clx-values resource-database)) (let* ((screen (if (type? screen 'display) (display-default-screen screen) screen)) (window (screen-root screen))) (set-wm-resources database window :write write :test test :test-not test-not) database)) (defsetf root-resources (screen &key test test-not (write #'princ))(database) `(set-root-resources ,screen :test ,test :test-not ,test-not :write ,write :database ,database)) (defun initialize-resource-database (display) ;; This function is (supposed to be) equivalent to the Xlib initialization ;; code. (declare (type display display)) (let ((rdb (make-resource-database)) (rootwin (screen-root (car (display-roots display))))) ;; First read the server defaults if present, otherwise from the default ;; resource file (if (get-property rootwin :RESOURCE_MANAGER) (xlib:wm-resources rdb rootwin) (let ((path (default-resources-pathname))) (when (and path (probe-file path)) (read-resources rdb path)))) ;; Next read from the resources file (let ((path (resources-pathname))) (when (and path (probe-file path)) (read-resources rdb path))) (setf (display-xdefaults display) rdb))) cl-clx-sbcl-0.7.4.20160323.orig/attributes.lisp0000644000175000017500000005705112715665271016710 0ustar pdmpdm;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; Window Attributes ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; ;;; The special variable *window-attributes* is an alist containg: ;;; (drawable attributes attribute-changes geometry geometry-changes) ;;; Where DRAWABLE is the associated window or pixmap ;;; ATTRIBUTES is NIL or a reply-buffer containing the drawable's ;;; attributes for use by the accessors. ;;; ATTRIBUTE-CHANGES is NIL or an array. The first element ;;; of the array is a "value-mask", indicating which ;;; attributes have changed. The other elements are ;;; integers associated with the changed values, ready ;;; for insertion into a server request. ;;; GEOMETRY is like ATTRIBUTES, but for window geometry ;;; GEOMETRY-CHANGES is like ATTRIBUTE-CHANGES, but for window geometry ;;; ;;; Attribute and Geometry accessors and SETF's look on the special variable ;;; *window-attributes* for the drawable. If its not there, the accessor is ;;; NOT within a WITH-STATE, and a server request is made to get or put a value. ;;; If an entry is found in *window-attributes*, the cache buffers are used ;;; for the access. ;;; ;;; All WITH-STATE has to do (re)bind *Window-attributes* to a list including ;;; the new drawable. The caches are initialized to NIL and allocated as needed. (in-package :xlib) (eval-when (:compile-toplevel :load-toplevel :execute) (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 () ;; Since drawables are not always cached, we must use drawable-equal ;; to determine equality. ''drawable-equal) (defmacro window-equal-function () ;; Since windows are not always cached, we must use window-equal ;; to determine equality. ''window-equal) (defmacro with-state ((drawable) &body body) ;; Allows a consistent view to be obtained of data returned by GetWindowAttributes ;; and GetGeometry, and allows a coherent update using ChangeWindowAttributes and ;; ConfigureWindow. The body is not surrounded by a with-display. Within the ;; indefinite scope of the body, on a per-process basis in a multi-process ;; environment, the first call within an Accessor Group on the specified drawable ;; (the object, not just the variable) causes the complete results of the protocol ;; request to be retained, and returned in any subsequent accessor calls. Calls ;; within a Setf Group are delayed, and executed in a single request on exit from ;; the body. In addition, if a call on a function within an Accessor Group follows ;; a call on a function in the corresponding Setf Group, then all delayed setfs for ;; that group are executed, any retained accessor information for that group is ;; discarded, the corresponding protocol request is (re)issued, and the results are ;; (again) retained, and returned in any subsequent accessor calls. ;; Accessor Group A (for GetWindowAttributes): ;; window-visual, window-visual-info, window-class, window-gravity, window-bit-gravity, ;; window-backing-store, window-backing-planes, window-backing-pixel, ;; window-save-under, window-colormap, window-colormap-installed-p, ;; window-map-state, window-all-event-masks, window-event-mask, ;; window-do-not-propagate-mask, window-override-redirect ;; Setf Group A (for ChangeWindowAttributes): ;; window-gravity, window-bit-gravity, window-backing-store, window-backing-planes, ;; window-backing-pixel, window-save-under, window-event-mask, ;; window-do-not-propagate-mask, window-override-redirect, window-colormap, ;; window-cursor ;; Accessor Group G (for GetGeometry): ;; drawable-root, drawable-depth, drawable-x, drawable-y, drawable-width, ;; drawable-height, drawable-border-width ;; Setf Group G (for ConfigureWindow): ;; drawable-x, drawable-y, drawable-width, drawable-height, drawable-border-width, ;; window-priority (let ((state-entry (gensym))) ;; alist of (drawable attributes attribute-changes geometry geometry-changes) `(with-stack-list (,state-entry ,drawable nil nil nil nil) (with-stack-list* (*window-attributes* ,state-entry *window-attributes*) (multiple-value-prog1 (progn ,@body) (cleanup-state-entry ,state-entry)))))) (defun cleanup-state-entry (state) ;; Return buffers to the free-list (let ((entry (state-attributes state))) (when entry (deallocate-context entry))) (let ((entry (state-attribute-changes state))) (when entry (put-window-attribute-changes (car state) entry) (deallocate-gcontext-state entry))) (let ((entry (state-geometry state))) (when entry (deallocate-context entry))) (let ((entry (state-geometry-changes state))) (when entry (put-drawable-geometry-changes (car state) entry) (deallocate-gcontext-state entry)))) (defun change-window-attribute (window number value) ;; Called from window attribute SETF's to alter an attribute value ;; number is the change-attributes request mask bit number (declare (type window window) (type card8 number) (type card32 value)) (let ((state-entry nil) (changes nil)) (if (and *window-attributes* (setq state-entry (assoc window (the list *window-attributes*) :test (window-equal-function)))) (progn ; Within a WITH-STATE - cache changes (setq changes (state-attribute-changes state-entry)) (unless changes (setq changes (allocate-gcontext-state)) (setf (state-attribute-changes state-entry) changes) (setf (aref changes 0) 0)) ;; Initialize mask to zero (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit (setf (aref changes (1+ number)) value)) ;; save value ; Send change to the server (with-buffer-request ((window-display window) +x-changewindowattributes+) (window window) (card32 (ash 1 number) value))))) ;; ;; These two are twins (change-window-attribute change-drawable-geometry) ;; If you change one, you probably need to change the other... ;; (defun change-drawable-geometry (drawable number value) ;; Called from drawable geometry SETF's to alter an attribute value ;; number is the change-attributes request mask bit number (declare (type drawable drawable) (type card8 number) (type card29 value)) (let ((state-entry nil) (changes nil)) (if (and *window-attributes* (setq state-entry (assoc drawable (the list *window-attributes*) :test (drawable-equal-function)))) (progn ; Within a WITH-STATE - cache changes (setq changes (state-geometry-changes state-entry)) (unless changes (setq changes (allocate-gcontext-state)) (setf (state-geometry-changes state-entry) changes) (setf (aref changes 0) 0)) ;; Initialize mask to zero (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit (setf (aref changes (1+ number)) value)) ;; save value ; Send change to the server (with-buffer-request ((drawable-display drawable) +x-configurewindow+) (drawable drawable) (card16 (ash 1 number)) (card29 value))))) (defun get-window-attributes-buffer (window) (declare (type window window)) (let ((state-entry nil) (changes nil)) (or (and *window-attributes* (setq state-entry (assoc window (the list *window-attributes*) :test (window-equal-function))) (null (setq changes (state-attribute-changes state-entry))) (state-attributes state-entry)) (let ((display (window-display window))) (with-display (display) ;; When SETF's have been done, flush changes to the server (when changes (put-window-attribute-changes window changes) (deallocate-gcontext-state (state-attribute-changes state-entry)) (setf (state-attribute-changes state-entry) nil)) ;; Get window attributes (with-buffer-request-and-reply (display +x-getwindowattributes+ size :sizes (8)) ((window window)) (let ((repbuf (or (state-attributes state-entry) (allocate-context)))) (declare (type reply-buffer repbuf)) ;; Copy into repbuf from reply buffer (buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size) (when state-entry (setf (state-attributes state-entry) repbuf)) repbuf))))))) ;; ;; These two are twins (get-window-attributes-buffer get-drawable-geometry-buffer) ;; If you change one, you probably need to change the other... ;; (defun get-drawable-geometry-buffer (drawable) (declare (type drawable drawable)) (let ((state-entry nil) (changes nil)) (or (and *window-attributes* (setq state-entry (assoc drawable (the list *window-attributes*) :test (drawable-equal-function))) (null (setq changes (state-geometry-changes state-entry))) (state-geometry state-entry)) (let ((display (drawable-display drawable))) (with-display (display) ;; When SETF's have been done, flush changes to the server (when changes (put-drawable-geometry-changes drawable changes) (deallocate-gcontext-state (state-geometry-changes state-entry)) (setf (state-geometry-changes state-entry) nil)) ;; Get drawable attributes (with-buffer-request-and-reply (display +x-getgeometry+ size :sizes (8)) ((drawable drawable)) (let ((repbuf (or (state-geometry state-entry) (allocate-context)))) (declare (type reply-buffer repbuf)) ;; Copy into repbuf from reply buffer (buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size) (when state-entry (setf (state-geometry state-entry) repbuf)) repbuf))))))) (defun put-window-attribute-changes (window changes) ;; change window attributes ;; Always from Called within a WITH-DISPLAY (declare (type window window) (type gcontext-state changes)) (let* ((display (window-display window)) (mask (aref changes 0))) (declare (type display display) (type mask32 mask)) (with-buffer-request (display +x-changewindowattributes+) (window window) (card32 mask) (progn ;; Insert a word in the request for each one bit in the mask (do ((bits mask (ash bits -1)) (request-size 2) ;Word count (i 1 (index+ i 1))) ;Entry count ((zerop bits) (card16-put 2 (index-incf request-size)) (index-incf (buffer-boffset display) (index* request-size 4))) (declare (type mask32 bits) (type array-index i request-size)) (when (oddp bits) (card32-put (index* (index-incf request-size) 4) (aref changes i)))))))) ;; ;; These two are twins (put-window-attribute-changes put-drawable-geometry-changes) ;; If you change one, you probably need to change the other... ;; (defun put-drawable-geometry-changes (window changes) ;; change window attributes or geometry (depending on request-number...) ;; Always from Called within a WITH-DISPLAY (declare (type window window) (type gcontext-state changes)) (let* ((display (window-display window)) (mask (aref changes 0))) (declare (type display display) (type mask16 mask)) (with-buffer-request (display +x-configurewindow+) (window window) (card16 mask) (progn ;; Insert a word in the request for each one bit in the mask (do ((bits mask (ash bits -1)) (request-size 2) ;Word count (i 1 (index+ i 1))) ;Entry count ((zerop bits) (card16-put 2 (incf request-size)) (index-incf (buffer-boffset display) (* request-size 4))) (declare (type mask16 bits) (type fixnum request-size) (type array-index i)) (when (oddp bits) (card29-put (* (incf request-size) 4) (aref changes i)))))))) (defmacro with-attributes ((window &rest options) &body body) `(let ((.with-attributes-reply-buffer. (get-window-attributes-buffer ,window))) (declare (type reply-buffer .with-attributes-reply-buffer.)) (prog1 (with-buffer-input (.with-attributes-reply-buffer. ,@options) ,@body) (unless *window-attributes* (deallocate-context .with-attributes-reply-buffer.))))) ;; ;; These two are twins (with-attributes with-geometry) ;; If you change one, you probably need to change the other... ;; (defmacro with-geometry ((window &rest options) &body body) `(let ((.with-geometry-reply-buffer. (get-drawable-geometry-buffer ,window))) (declare (type reply-buffer .with-geometry-reply-buffer.)) (prog1 (with-buffer-input (.with-geometry-reply-buffer. ,@options) ,@body) (unless *window-attributes* (deallocate-context .with-geometry-reply-buffer.))))) ;;;----------------------------------------------------------------------------- ;;; Group A: (for GetWindowAttributes) ;;;----------------------------------------------------------------------------- (defun window-visual (window) (declare (type window window)) (declare (clx-values resource-id)) (with-attributes (window :sizes 32) (resource-id-get 8))) (defun window-visual-info (window) (declare (type window window)) (declare (clx-values visual-info)) (with-attributes (window :sizes 32) (visual-info (window-display window) (resource-id-get 8)))) (defun window-class (window) (declare (type window window)) (declare (clx-values (member :input-output :input-only))) (with-attributes (window :sizes 16) (member16-get 12 :copy :input-output :input-only))) (defun set-window-background (window background) (declare (type window window) (type (or (member :none :parent-relative) pixel pixmap) background)) (cond ((eq background :none) (change-window-attribute window 0 0)) ((eq background :parent-relative) (change-window-attribute window 0 1)) ((integerp background) ;; Background pixel (change-window-attribute window 0 0) ;; pixmap :NONE (change-window-attribute window 1 background)) ((type? background 'pixmap) ;; Background pixmap (change-window-attribute window 0 (pixmap-id background))) (t (x-type-error background '(or (member :none :parent-relative) integer pixmap)))) background) #+Genera (eval-when (compile) (compiler:function-defined 'window-background)) (defsetf window-background set-window-background) (defun set-window-border (window border) (declare (type window window) (type (or (member :copy) pixel pixmap) border)) (cond ((eq border :copy) (change-window-attribute window 2 0)) ((type? border 'pixmap) ;; Border pixmap (change-window-attribute window 2 (pixmap-id border))) ((integerp border) ;; Border pixel (change-window-attribute window 3 border)) (t (x-type-error border '(or (member :copy) integer pixmap)))) border) #+Genera (eval-when (compile) (compiler:function-defined 'window-border)) (defsetf window-border set-window-border) (defun window-bit-gravity (window) ;; setf'able (declare (type window window)) (declare (clx-values bit-gravity)) (with-attributes (window :sizes 8) (member8-vector-get 14 +bit-gravity-vector+))) (defun set-window-bit-gravity (window gravity) (change-window-attribute window 4 (encode-type (member-vector +bit-gravity-vector+) gravity)) gravity) (defsetf window-bit-gravity set-window-bit-gravity) (defun window-gravity (window) ;; setf'able (declare (type window window)) (declare (clx-values win-gravity)) (with-attributes (window :sizes 8) (member8-vector-get 15 +win-gravity-vector+))) (defun set-window-gravity (window gravity) (change-window-attribute window 5 (encode-type (member-vector +win-gravity-vector+) gravity)) gravity) (defsetf window-gravity set-window-gravity) (defun window-backing-store (window) ;; setf'able (declare (type window window)) (declare (clx-values (member :not-useful :when-mapped :always))) (with-attributes (window :sizes 8) (member8-get 1 :not-useful :when-mapped :always))) (defun set-window-backing-store (window when) (change-window-attribute window 6 (encode-type (member :not-useful :when-mapped :always) when)) when) (defsetf window-backing-store set-window-backing-store) (defun window-backing-planes (window) ;; setf'able (declare (type window window)) (declare (clx-values pixel)) (with-attributes (window :sizes 32) (card32-get 16))) (defun set-window-backing-planes (window planes) (change-window-attribute window 7 (encode-type card32 planes)) planes) (defsetf window-backing-planes set-window-backing-planes) (defun window-backing-pixel (window) ;; setf'able (declare (type window window)) (declare (clx-values pixel)) (with-attributes (window :sizes 32) (card32-get 20))) (defun set-window-backing-pixel (window pixel) (change-window-attribute window 8 (encode-type card32 pixel)) pixel) (defsetf window-backing-pixel set-window-backing-pixel) (defun window-save-under (window) ;; setf'able (declare (type window window)) (declare (clx-values (member :off :on))) (with-attributes (window :sizes 8) (member8-get 24 :off :on))) (defun set-window-save-under (window when) (change-window-attribute window 10 (encode-type (member :off :on) when)) when) (defsetf window-save-under set-window-save-under) (defun window-override-redirect (window) ;; setf'able (declare (type window window)) (declare (clx-values (member :off :on))) (with-attributes (window :sizes 8) (member8-get 27 :off :on))) (defun set-window-override-redirect (window when) (change-window-attribute window 9 (encode-type (member :off :on) when)) when) (defsetf window-override-redirect set-window-override-redirect) (defun window-event-mask (window) ;; setf'able (declare (type window window)) (declare (clx-values mask32)) (with-attributes (window :sizes 32) (card32-get 36))) (defsetf window-event-mask (window) (event-mask) (let ((em (gensym))) `(let ((,em ,event-mask)) (declare (type event-mask ,em)) (change-window-attribute ,window 11 (encode-event-mask ,em)) ,em))) (defun window-do-not-propagate-mask (window) ;; setf'able (declare (type window window)) (declare (clx-values mask32)) (with-attributes (window :sizes 32) (card32-get 40))) (defsetf window-do-not-propagate-mask (window) (device-event-mask) (let ((em (gensym))) `(let ((,em ,device-event-mask)) (declare (type device-event-mask ,em)) (change-window-attribute ,window 12 (encode-device-event-mask ,em)) ,em))) (defun window-colormap (window) (declare (type window window)) (declare (clx-values (or null colormap))) (with-attributes (window :sizes 32) (let ((id (resource-id-get 28))) (if (zerop id) nil (let ((colormap (lookup-colormap (window-display window) id))) (unless (colormap-visual-info colormap) (setf (colormap-visual-info colormap) (visual-info (window-display window) (resource-id-get 8)))) colormap))))) (defun set-window-colormap (window colormap) (change-window-attribute window 13 (encode-type (or (member :copy) colormap) colormap)) colormap) (defsetf window-colormap set-window-colormap) (defun window-cursor (window) (declare (type window window)) (declare (clx-values cursor)) window (error "~S can only be set" 'window-cursor)) (defun set-window-cursor (window cursor) (change-window-attribute window 14 (encode-type (or (member :none) cursor) cursor)) cursor) (defsetf window-cursor set-window-cursor) (defun window-colormap-installed-p (window) (declare (type window window)) (declare (clx-values generalized-boolean)) (with-attributes (window :sizes 8) (boolean-get 25))) (defun window-all-event-masks (window) (declare (type window window)) (declare (clx-values mask32)) (with-attributes (window :sizes 32) (card32-get 32))) (defun window-map-state (window) (declare (type window window)) (declare (clx-values (member :unmapped :unviewable :viewable))) (with-attributes (window :sizes 8) (member8-get 26 :unmapped :unviewable :viewable))) ;;;----------------------------------------------------------------------------- ;;; Group G: (for GetGeometry) ;;;----------------------------------------------------------------------------- (defun drawable-root (drawable) (declare (type drawable drawable)) (declare (clx-values window)) (with-geometry (drawable :sizes 32) (window-get 8 (drawable-display drawable)))) (defun drawable-x (drawable) ;; setf'able (declare (type drawable drawable)) (declare (clx-values int16)) (with-geometry (drawable :sizes 16) (int16-get 12))) (defun set-drawable-x (drawable x) (change-drawable-geometry drawable 0 (encode-type int16 x)) x) (defsetf drawable-x set-drawable-x) (defun drawable-y (drawable) ;; setf'able (declare (type drawable drawable)) (declare (clx-values int16)) (with-geometry (drawable :sizes 16) (int16-get 14))) (defun set-drawable-y (drawable y) (change-drawable-geometry drawable 1 (encode-type int16 y)) y) (defsetf drawable-y set-drawable-y) (defun drawable-width (drawable) ;; setf'able ;; Inside width, excluding border. (declare (type drawable drawable)) (declare (clx-values card16)) (with-geometry (drawable :sizes 16) (card16-get 16))) (defun set-drawable-width (drawable width) (change-drawable-geometry drawable 2 (encode-type card16 width)) width) (defsetf drawable-width set-drawable-width) (defun drawable-height (drawable) ;; setf'able ;; Inside height, excluding border. (declare (type drawable drawable)) (declare (clx-values card16)) (with-geometry (drawable :sizes 16) (card16-get 18))) (defun set-drawable-height (drawable height) (change-drawable-geometry drawable 3 (encode-type card16 height)) height) (defsetf drawable-height set-drawable-height) (defun drawable-depth (drawable) (declare (type drawable drawable)) (declare (clx-values card8)) (with-geometry (drawable :sizes 8) (card8-get 1))) (defun drawable-border-width (drawable) ;; setf'able (declare (type drawable drawable)) (declare (clx-values integer)) (with-geometry (drawable :sizes 16) (card16-get 20))) (defun set-drawable-border-width (drawable width) (change-drawable-geometry drawable 4 (encode-type card16 width)) width) (defsetf drawable-border-width set-drawable-border-width) (defun set-window-priority (mode window sibling) (declare (type (member :above :below :top-if :bottom-if :opposite) mode) (type window window) (type (or null window) sibling)) (with-state (window) (change-drawable-geometry window 6 (encode-type (member :above :below :top-if :bottom-if :opposite) mode)) (when sibling (change-drawable-geometry window 5 (encode-type window sibling)))) mode) #+Genera (eval-when (compile) (compiler:function-defined 'window-priority)) (defsetf window-priority (window &optional sibling) (mode) ;; A bit strange, but retains setf form. `(set-window-priority ,mode ,window ,sibling)) cl-clx-sbcl-0.7.4.20160323.orig/xrender.lisp0000644000175000017500000014431212715665273016170 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- ;;; --------------------------------------------------------------------------- ;;; Title: The X Render Extension ;;; Created: 2002-08-03 ;;; Author: Gilbert Baumann ;;; $Id: xrender.lisp,v 1.5 2004/12/06 11:48:57 csr21 Exp $ ;;; --------------------------------------------------------------------------- ;;; ;;; (c) copyright 2002, 2003 by Gilbert Baumann ;;; (c) copyright 2002 by Christian Sunesson ;;; ;;; 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. ;;; ;;; NOTE: we need to watch maximum request sizes and somehow work ;;; around them. Sometimes e.g. in AddGlyphs this is not possible, ;;; which is a design failure. ;;; TODO ;; - some request are still to be implemented at all. ;; + Can they not wait? Xrender seems to be in flux as the specification ;; isn't even conforming to the acctual protocol. However backwards ;; wierd that sound. --noss ;; - we need to invent something for the color values of e.g. ;; fill-rectangles; I would prefer some generic functions, so that ;; we later can map CLIM design directly to colors. ;; - we want some conviencene function to turn graphics contexts into ;; render pictures. --GB 2002-08-21 ;; - also: uniform-alpha-picture display alpha-value ;; uniform-color-picture display red green blue ;; --GB 2002-08-21 ;; - maybe we should aim for a higher level interface to ;; color-trapzoids and color-triangles and offer a low level [raw] ;; interface also for high performance apps? ;; - Write tests. ;;;; API issues ;; - On one hand we want convenience functions like RENDER-TRIANGLE or ;; WITH-UNIFORM-COLOR-PICTURE. On the other hand if you are up to ;; write a full rasterization library you obviously want high ;; performance entry points as RENDER-TRIANGLES-1. ;; - We want to extend XLIB:COLOR into something with alpha channel. ;; How to name it? ;; - WITH-UNIFORM-COLOR-PICTURE (var picture r g b &optional alpha) &body body ;; ;; Example: ;; (WITH-UNIFORM-COLOR-PICTURE (color dest 1.0 1.0 0.0) ;; (RENDER-TRIANGLE dest color ...)) ;; - Pose the filter and the transform slots of a picture. ;; - Also introduce a PICTURE-DEFAULT-MASK-FORMAT? ;; - COPY-PICTURE? ;; - WITH-PICTURE-OPTIONS ? ;; ;; (WITH-PICTURE-OPTIONS (pic :repeat :on) ...) ;; - WITH-PICTURE ? ;; ;; (WITH-PICTURE (picture drawable ...) ...) ;; (in-package :xlib) ;; Beginning to collect the external interface for documentation. (export '(render-create-picture render-free-picture render-create-glyph-set render-reference-glyph-set render-free-glyph-set render-add-glyph render-add-glyph-from-picture render-free-glyph render-fill-rectangle picture-format-display picture-format-id picture-format-type picture-format-depth picture-format-red-byte picture-format-green-byte picture-format-blue-byte picture-format-alpha-byte picture-format-colormap ;; picture object picture-repeat picture-alpha-map picture-alpha-x-origin picture-alpha-y-origin picture-clip-x-origin picture-clip-y-origin picture-clip-mask picture-graphics-exposures picture-subwindow-mode picture-poly-edge picture-poly-mode picture-dither picture-component-alpha picture-drawable find-matching-picture-formats find-window-picture-format render-free-picture render-free-glyph-set render-query-version ;; render-query-picture-formats render-fill-rectangle render-triangles render-trapezoids render-composite render-create-glyph-set render-reference-glyph-set render-composite-glyphs render-add-glyph render-add-glyph-from-picture render-free-glyphs)) (pushnew :clx-ext-render *features*) (define-extension "RENDER") ;;;; Request constants ;; Note: Although version numbers are given render.h where the request ;; numbers are defined, render-query-version returns 0.0 all displays ;; i tested. --GB 2004-07-21 (defconstant +X-RenderQueryVersion+ 0) ;done (defconstant +X-RenderQueryPictFormats+ 1) (defconstant +X-RenderQueryPictIndexValues+ 2) ;0.7 (defconstant +X-RenderQueryDithers+ 3) (defconstant +X-RenderCreatePicture+ 4) ;done (defconstant +X-RenderChangePicture+ 5) ;done (defconstant +X-RenderSetPictureClipRectangles+ 6) ;done (defconstant +X-RenderFreePicture+ 7) ;done (defconstant +X-RenderComposite+ 8) ;we need better arglist (defconstant +X-RenderScale+ 9) (defconstant +X-RenderTrapezoids+ 10) ;low-level done (defconstant +X-RenderTriangles+ 11) ;low-level done (defconstant +X-RenderTriStrip+ 12) (defconstant +X-RenderTriFan+ 13) (defconstant +X-RenderColorTrapezoids+ 14) ;nyi in X server, not mentioned in renderproto.h (defconstant +X-RenderColorTriangles+ 15) ;nyi in X server, not mentioned in renderproto.h (defconstant +X-RenderTransform+ 16) ;commented out in render.h (defconstant +X-RenderCreateGlyphSet+ 17) ;done (defconstant +X-RenderReferenceGlyphSet+ 18) ;done (defconstant +X-RenderFreeGlyphSet+ 19) ;done (defconstant +X-RenderAddGlyphs+ 20) ;done, untested (defconstant +X-RenderAddGlyphsFromPicture+ 21) ;done, untested (defconstant +X-RenderFreeGlyphs+ 22) ;done, untested (defconstant +X-RenderCompositeGlyphs8+ 23) ;done (defconstant +X-RenderCompositeGlyphs16+ 24) ;done (defconstant +X-RenderCompositeGlyphs32+ 25) ;done ;; >= 0.1 (defconstant +X-RenderFillRectangles+ 26) ;single rectangle version done ;; >= 0.5 (defconstant +X-RenderCreateCursor+ 27) ;; >= 0.6 (defconstant +X-RenderSetPictureTransform+ 28) ;I don't understand what this one should do. (defconstant +X-RenderQueryFilters+ 29) ;seems to be there on server side ; some guts of its implementation there. (defconstant +X-RenderSetPictureFilter+ 30) (defconstant +X-RenderCreateAnimCursor+ 31) ;What has render to do with cursors? ;;;; ;; Sanity measures: ;; We do away with the distinction between pict-format and ;; picture-format-info. That is we cache picture-format-infos. (defstruct picture-format display (id 0 :type (unsigned-byte 29)) type depth red-byte green-byte blue-byte alpha-byte colormap) (def-clx-class (glyph-set (:copier nil) ) (id 0 :type resource-id) (display nil :type (or null display)) (plist nil :type list) ; Extension hook (format)) (defstruct render-info major-version minor-version picture-formats) (defun display-render-info (display) (getf (xlib:display-plist display) 'render-info)) (defun (setf display-render-info) (new-value display) (setf (getf (xlib:display-plist display) 'render-info) new-value)) (defun ensure-render-initialized (display) "Ensures that the RENDER extension is initialized. Should be called by every function, which attempts to generate RENDER requests." ;; xxx locking? (unless (display-render-info display) (let ((q (make-render-info))) (multiple-value-bind (maj min) (render-query-version display) (setf (render-info-major-version q) maj (render-info-minor-version q) min) (setf (render-info-picture-formats q) (make-hash-table :test #'eql)) (dolist (pf (render-query-picture-formats display)) (setf (gethash (picture-format-id pf) (render-info-picture-formats q)) pf)) (setf (display-render-info display) q))))) (defun find-matching-picture-formats (display &key depth-min depth-max depth red-min red-max red green-min green-max green blue-min blue-max blue alpha-min alpha-max alpha type colormap) ;; (ensure-render-initialized display) (let ((res nil)) (maphash (lambda (k f) (declare (ignore k)) (when (and (or (null type) (eql (picture-format-type f) type)) (or (null colormap) (eql (picture-format-colormap f) colormap)) ;; min (or (null depth-min) (>= (picture-format-depth f) depth-min)) (or (null red-min) (>= (byte-size (picture-format-red-byte f)) red-min)) (or (null green-min) (>= (byte-size (picture-format-green-byte f)) green-min)) (or (null blue-min) (>= (byte-size (picture-format-blue-byte f)) blue-min)) (or (null alpha-min) (>= (byte-size (picture-format-alpha-byte f)) alpha-min)) ;; max (or (null depth-max) (<= (picture-format-depth f) depth-max)) (or (null red-max) (<= (byte-size (picture-format-red-byte f)) red-max)) (or (null green-max) (<= (byte-size (picture-format-green-byte f)) green-max)) (or (null blue-max) (<= (byte-size (picture-format-blue-byte f)) blue-max)) (or (null alpha-max) (<= (byte-size (picture-format-alpha-byte f)) alpha-max)) ;; match (or (null depth) (= (picture-format-depth f) depth)) (or (null red) (= (byte-size (picture-format-red-byte f)) red)) (or (null green) (= (byte-size (picture-format-green-byte f)) green)) (or (null blue) (= (byte-size (picture-format-blue-byte f)) blue)) (or (null alpha) (= (byte-size (picture-format-alpha-byte f)) alpha))) (pushnew f res))) (render-info-picture-formats (display-render-info display))) res)) (defun find-window-picture-format (window) "Find the picture format which matches the given window." (let* ((vi (window-visual-info window)) (display (window-display window))) (ensure-render-initialized display) (case (visual-info-class vi) ((:true-color) (maphash (lambda (k f) (declare (ignore k)) (when (and (eql (picture-format-type f) :direct) (eql (picture-format-depth f) (drawable-depth window)) (eql (dpb -1 (picture-format-red-byte f) 0) (visual-info-red-mask vi)) (eql (dpb -1 (picture-format-green-byte f) 0) (visual-info-green-mask vi)) (eql (dpb -1 (picture-format-blue-byte f) 0) (visual-info-blue-mask vi)) (eql (byte-size (picture-format-alpha-byte f)) 0)) (return-from find-window-picture-format f))) (render-info-picture-formats (display-render-info display)))) (t )))) (eval-when (:compile-toplevel :load-toplevel :execute) (define-accessor picture (32) ((index) index :blip) ((index thing) `(resource-id-put ,index (picture-id ,thing)))) (define-accessor glyph-set (32) ((index) index :blip) ((index thing) `(resource-id-put ,index (glyph-set-id ,thing))))) ;;; picture format (defmethod print-object ((object picture-format) stream) (let ((abbrev (with-output-to-string (bag) ;; build an abbreviated representation of the format (let ((bytes (sort (list (cons "r" (picture-format-red-byte object)) (cons "g" (picture-format-green-byte object)) (cons "b" (picture-format-blue-byte object)) (cons "a" (picture-format-alpha-byte object))) #'> :key #'(lambda (x) (byte-position (cdr x)))))) (dolist (k bytes) (unless (zerop (byte-size (cdr k))) (format bag " ~A~D" (car k) (byte-size (cdr k))))))))) (print-unreadable-object (object stream :type t :identity nil) (format stream "~D ~S ~S ~S~A" (picture-format-id object) (picture-format-colormap object) (picture-format-depth object) (picture-format-type object) abbrev)))) (eval-when (:compile-toplevel :load-toplevel :execute) (define-accessor picture-format (32) ((index) `(gethash (read-card32 ,index) (render-info-picture-formats (display-render-info .display.)))) ((index thing) `(write-card32 ,index (picture-format-id ,thing)))) (define-accessor render-op (8) ((index) `(member8-get ,index :clear :src :dst :over :over-reverse :in :in-reverse :out :out-reverse :atop :atop-reverse :xor :add :saturate '#:undefined-pict-op-Eh '#:undefined-pict-op-Fh :disjoint-clear :disjoint-src :disjoint-dst :disjoint-over :disjoint-over-reverse :disjoint-in :disjoint-in-reverse :disjoint-out :disjoint-out-reverse :disjoint-atop :disjoint-atop-reverse :disjoint-xor '#:undefined-pict-op-1Ch '#:undefined-pict-op-1Dh '#:undefined-pict-op-1Eh '#:undefined-pict-op-1Fh :conjoint-clear :conjoint-src :conjoint-dst :conjoint-over :conjoint-over-reverse :conjoint-in :conjoint-in-reverse :conjoint-out :conjoint-out-reverse :conjoint-atop :conjoint-atop-reverse :conjoint-xor)) ((index thing) `(member8-put ,index ,thing :clear :src :dst :over :over-reverse :in :in-reverse :out :out-reverse :atop :atop-reverse :xor :add :saturate '#:undefined-pict-op-Eh '#:undefined-pict-op-Fh :disjoint-clear :disjoint-src :disjoint-dst :disjoint-over :disjoint-over-reverse :disjoint-in :disjoint-in-reverse :disjoint-out :disjoint-out-reverse :disjoint-atop :disjoint-atop-reverse :disjoint-xor '#:undefined-pict-op-1Ch '#:undefined-pict-op-1Dh '#:undefined-pict-op-1Eh '#:undefined-pict-op-1Fh :conjoint-clear :conjoint-src :conjoint-dst :conjoint-over :conjoint-over-reverse :conjoint-in :conjoint-in-reverse :conjoint-out :conjoint-out-reverse :conjoint-atop :conjoint-atop-reverse :conjoint-xor))) (deftype render-op () '(member :clear :src :dst :over :over-reverse :in :in-reverse :out :out-reverse :atop :atop-reverse :xor :add :saturate :disjoint-clear :disjoint-src :disjoint-dst :disjoint-over :disjoint-over-reverse :disjoint-in :disjoint-in-reverse :disjoint-out :disjoint-out-reverse :disjoint-atop :disjoint-atop-reverse :disjoint-xor :conjoint-clear :conjoint-src :conjoint-dst :conjoint-over :conjoint-over-reverse :conjoint-in :conjoint-in-reverse :conjoint-out :conjoint-out-reverse :conjoint-atop :conjoint-atop-reverse :conjoint-xor))) ;; Now these pictures objects are like graphics contexts. I was about ;; to introduce a synchronous mode, realizing that the RENDER protocol ;; provides no provision to actually query a picture object's values. ;; *sigh* (def-clx-class (picture (:copier nil)) (id 0 :type resource-id) (display nil :type (or null display)) (plist nil :type list) ; Extension hook (format) (%changed-p) (%server-values) (%values) (%drawable)) (defun picture-drawable (picture) (picture-%drawable picture)) ;; xx make id, display, format readonly (defun %render-change-picture-clip-rectangles (picture rectangles) "Dont call me, use (SETF PICTURE-CLIP-MASK) instead." (declare (optimize (speed 0))) (let ((display (picture-display picture))) (ensure-render-initialized display) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderSetPictureClipRectangles+) (picture picture) (int16 (picture-clip-x-origin picture)) (int16 (picture-clip-y-origin picture)) ((sequence :format int16) rectangles)))) (macrolet ((foo (&rest specs) `(progn ,@(loop for (type slot default) in specs for index from 0 collect `(progn (defun ,(xintern 'picture- slot) (picture) (aref (picture-%values picture) ,index)) (defun (setf ,(xintern 'picture- slot)) (new-value picture) (setf (picture-%changed-p picture) t) (setf (aref (picture-%values picture) ,index) new-value)))) (defun synchronise-picture-state (picture) (when (picture-%changed-p picture) (let ((display (picture-display picture))) (ensure-render-initialized display) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderChangePicture+) (picture picture) (mask ,@(loop for (type slot default) in specs for index from 0 collect `(,type (and ,(cond ((eql slot 'clip-mask) `(not (typep (aref (picture-%values picture) ,index) 'sequence))) (t 't)) (not (eq (aref (picture-%values picture) ,index) (aref (picture-%server-values picture) ,index))) (setf (aref (picture-%server-values picture) ,index) (aref (picture-%values picture) ,index)))))))) ,(let ((index (position 'clip-mask specs :key #'second))) `(unless (eql (aref (picture-%values picture) ,index) (aref (picture-%server-values picture) ,index)) (%render-change-picture-clip-rectangles picture (aref (picture-%values picture) ,index)) (setf (aref (picture-%server-values picture) ,index) (aref (picture-%values picture) ,index)))) (setf (picture-%changed-p picture) nil))) (defun render-create-picture (drawable &key format (picture (make-picture :display (drawable-display drawable))) ,@(loop for (type slot default-value) in specs collect (cond ((eql slot 'clip-mask) `(clip-mask :none)) (t slot))) ) ;; xxx also offer to give a colormap instead of a picture-format ;; values! (let ((display (drawable-display drawable))) (ensure-render-initialized display) (unless format ;; xxx check for drawable being a window (setf format (find-window-picture-format drawable))) (let ((pid (allocate-resource-id display picture 'picture))) (setf (picture-id picture) pid) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderCreatePicture+) (resource-id pid) (drawable drawable) (picture-format format) (mask ,@(loop for (type slot default) in specs collect (cond ((eql slot 'clip-mask) (list type `(and (not (typep clip-mask 'sequence)) clip-mask))) (t (list type slot))))))) (when (typep clip-mask 'sequence) (%render-change-picture-clip-rectangles picture clip-mask)) (setf (picture-format picture) format) (setf (picture-%server-values picture) (vector ,@(loop for (type slot default) in specs collect `(or ,slot ,default)))) (setf (picture-%values picture) (copy-seq (picture-%server-values picture))) (setf (picture-%drawable picture) drawable) picture)) (defconstant +picture-state-length+ ,(length specs)) ))) (foo ((member :off :on) repeat :off) ((or (member :none) picture) alpha-map :none) (int16 alpha-x-origin 0) (int16 alpha-y-origin 0) (int16 clip-x-origin 0) (int16 clip-y-origin 0) ;; ### Now that is not correct is it?: ((or (member :none) pixmap) clip-mask :none) ((member :off :on) graphics-exposures :on) ((member :clip-by-children :include-inferiors) subwindow-mode :clip-by-children) ((member :sharp :smooth) poly-edge :smooth) ((member :precise :imprecise) poly-mode :precise) ((or (member :none) #||xatom||#) dither :none) ((member :off :on) component-alpha :off))) (defun render-free-picture (picture) (let ((display (picture-display picture))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderFreePicture+) (picture picture)))) (defun render-free-glyph-set (glyph-set) (let ((display (glyph-set-display glyph-set))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderFreeGlyphSet+) (glyph-set glyph-set)))) (defun render-query-version (display) (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil) ((data +X-RenderQueryVersion+) (card32 0) (card32 1)) (values (card32-get 8) (card32-get 12) ))) (defun render-query-picture-formats (display) (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil) ((data +X-RenderQueryPictFormats+)) (let ((n-picture-formats (card32-get 8)) (n-screens (card32-get 12)) (n-depths (card32-get 16)) (n-visuals (card32-get 20)) (n-subpixel (card32-get 24))) (declare (ignore n-screens n-depths n-visuals n-subpixel)) (loop for i below n-picture-formats collect (let ((off (+ (* 8 4) (* i 28)))) ;size of picture-format-info (make-picture-format :display display :id (card32-get (+ off 0)) :type (member8-get (+ off 4) :indexed :direct) :depth (card8-get (+ off 5)) :red-byte (byte (integer-length (card16-get (+ off 10))) (card16-get (+ off 8))) :green-byte (byte (integer-length (card16-get (+ off 14))) (card16-get (+ off 12))) :blue-byte (byte (integer-length (card16-get (+ off 18))) (card16-get (+ off 16))) :alpha-byte (byte (integer-length (card16-get (+ off 22))) (card16-get (+ off 20))) :colormap (let ((cmid (card32-get (+ off 24)))) (unless (zerop cmid) (lookup-colormap display cmid))))))))) (defun render-fill-rectangle (picture op color x1 y1 w h) (let ((display (picture-display picture))) (ensure-render-initialized display) (synchronise-picture-state picture) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderFillRectangles+) (render-op op) (pad8 0) (pad16 0) (resource-id (picture-id picture)) (card16 (elt color 0)) (card16 (elt color 1)) (card16 (elt color 2)) (card16 (elt color 3)) (int16 x1) (int16 y1) (card16 w) (card16 h)))) ;; fill rectangles, colors. (defun render-triangles (picture op source src-x src-y format coord-sequence) ;; For performance reasons we do a special typecase on (simple-array ;; (unsigned-byte 32) (*)), so that it'll be possible to have high ;; performance rasters. (macrolet ((guts () '(let ((display (picture-display picture))) (synchronise-picture-state picture) (synchronise-picture-state source) (labels ((funk (x) (ash x 16))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderTriangles+) (render-op op) (pad8 0) (pad16 0) (resource-id (picture-id source)) (resource-id (picture-id picture)) (picture-format format) (int16 src-x) (int16 src-y) ((sequence :format int32 :transform #'funk) coord-sequence)))))) (typecase coord-sequence ((simple-array (unsigned-byte 32) (*)) (locally (declare (type (simple-array (unsigned-byte 32) (*)) coord-sequence)) (guts))) (t (guts))))) #|| (defun render-set-picture-transform (picture mxx mxy dx mxy myy dy &optional (mwx 0) (mwy 0) (dw 1)) ...) ||# (defun render-set-picture-transform (picture a b c d e f p q r) (let ((display (picture-display picture))) (ensure-render-initialized display) (synchronise-picture-state picture) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderSetPictureTransform+) #| (card8 0) ;; render-op op) ;op (card8 0) ;pad (card16 0) ;pad |# (resource-id (picture-id picture)) (card32 a) (card32 b) (card32 c) (card32 d) (card32 e) (card32 f) (card32 p) (card32 q) (card32 r)))) (defun render-query-filters (drawable) (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil) ((data +X-RenderQueryFilters+) (drawable drawable)) (let* ((len (card32-get 4)) (n-aliases (card32-get 8)) (n-filters (card32-get 12)) (off (+ (* 8 4) (* 4 (ceiling (* 2 n-aliases) 4))))) (print (list :aliases (loop for i below n-aliases collect (card16-get (+ (* 8 4) (* i 2)))))) (print (list :foo len n-aliases n-filters (loop for i below len collect (card8-get (+ off 0 (* 4 i))) collect (card8-get (+ off 1 (* 4 i))) collect (card8-get (+ off 2 (* 4 i))) collect (card8-get (+ off 3 (* 4 i)))))) (print (labels ((grab-string (j) (let ((n (card8-get j))) (incf j) (values (map 'string #'code-char (loop repeat n collect (card8-get j) do (incf j))) j)))) (loop repeat n-filters collect (multiple-value-bind (s j) (grab-string off) (setf off j) (intern (string-upcase s) :keyword))))) #+NIL (loop for i below n-picture-formats collect (let ((off (+ (* 8 4) (* i 28)))) ;size of picture-format-info (make-picture-format :display display :id (card32-get (+ off 0)) :type (member8-get (+ off 4) :indexed :direct) :depth (card8-get (+ off 5)) :red-byte (byte (integer-length (card16-get (+ off 10))) (card16-get (+ off 8))) :green-byte (byte (integer-length (card16-get (+ off 14))) (card16-get (+ off 12))) :blue-byte (byte (integer-length (card16-get (+ off 18))) (card16-get (+ off 16))) :alpha-byte (byte (integer-length (card16-get (+ off 22))) (card16-get (+ off 20))) :colormap (let ((cmid (card32-get (+ off 24)))) (unless (zerop cmid) (lookup-colormap display cmid)))))))))) (defun render-set-filter (picture filter) (let ((display (picture-display picture))) (ensure-render-initialized display) (synchronise-picture-state picture) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderSetPictureFilter+) (resource-id (picture-id picture)) (card16 (length filter)) (pad16 0) ((sequence :format card8) (map 'vector #'char-code filter))))) #|| (defun render-triangle (destination source x1 y1 x2 y2 x3 y3 &key (src-x 0) (src-y 0) (format nil) (op :over)) (render-triangles-1 destination op source ...) ) ||# (defun render-trapezoids (picture op source src-x src-y mask-format coord-sequence) ;; coord-sequence is top bottom ;; left-x1 left-y1 left-x2 left-y2 ;; right-x1 right-y1 right-x2 right-y2 ... ;; (let ((display (picture-display picture))) (synchronise-picture-state picture) (synchronise-picture-state source) (labels ((funk (x) (ash x 16))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderTrapezoids+) (render-op op) (pad8 0) (pad16 0) (resource-id (picture-id source)) (resource-id (picture-id picture)) ((or (member :none) picture-format) mask-format) (int16 src-x) (int16 src-y) ((sequence :format int32 :transform #'funk) coord-sequence))))) (defun render-composite (op source mask dest src-x src-y mask-x mask-y dst-x dst-y width height) (let ((display (picture-display source))) (synchronise-picture-state source) (when mask (synchronise-picture-state mask)) (synchronise-picture-state dest) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderComposite+) (render-op op) (pad8 0) (pad16 0) (resource-id (picture-id source)) (resource-id (if mask (picture-id mask) 0)) (resource-id (picture-id dest)) (int16 src-x) (int16 src-y) (int16 mask-x) (int16 mask-y) (int16 dst-x) (int16 dst-y) (card16 width) (card16 height)))) (defun render-create-glyph-set (format &key glyph-set) (let ((display (picture-format-display format))) (let* ((glyph-set (or glyph-set (make-glyph-set :display display))) (gsid (setf (glyph-set-id glyph-set) (allocate-resource-id display glyph-set 'glyph-set)))) (declare (ignore gsid)) (setf (glyph-set-format glyph-set) format) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderCreateGlyphSet+) (glyph-set glyph-set) (picture-format format)) glyph-set))) (defun render-reference-glyph-set (existing-glyph-set &key glyph-set) (let ((display (glyph-set-display existing-glyph-set))) (let* ((glyph-set (or glyph-set (make-glyph-set :display display))) (gsid (setf (glyph-set-id glyph-set) (allocate-resource-id display glyph-set 'glyph-set)))) (declare (ignore gsid)) (setf (glyph-set-format glyph-set) (glyph-set-format existing-glyph-set)) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderReferenceGlyphSet+) (glyph-set glyph-set) (glyph-set existing-glyph-set)) glyph-set))) (defun render-composite-glyphs-8 (dest glyph-set source dest-x dest-y sequence &key (op :over) (alu op) ;for the fun of it (src-x 0) (src-y 0) (mask-format :none) (start 0) (end (length sequence))) (let ((display (picture-display dest))) (ensure-render-initialized display) (synchronise-picture-state dest) (synchronise-picture-state source) (when (stringp sequence) ;; lazy me, but then you should not confuse glyphs with ;; characters anyway. (setf sequence (map 'vector #'char-code sequence))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderCompositeGlyphs8+) (render-op alu) (pad8 0) (pad16 0) (picture source) (picture dest) ((or (member :none) picture-format) mask-format) (glyph-set glyph-set) (int16 src-x) (int16 src-y) (card8 (- end start)) ;length of glyph elt (pad8 0) (pad16 0) (int16 dest-x) (int16 dest-y) ;dx, dy ((sequence :format card8) sequence)))) (defmacro %render-composite-glyphs (opcode type transform display dest glyph-set source dest-x dest-y sequence alu src-x src-y mask-format start end) (let ((size (ecase type (card8 1) (card16 2) (card32 4))) ;; FIXME: the last chunk for CARD8 can be 254. (chunksize (ecase type (card8 252) (card16 254) (card32 254)))) `(multiple-value-bind (nchunks leftover) (floor (- end start) ,chunksize) (let* ((payloadsize (+ (* nchunks (+ 8 (* ,chunksize ,size))) (if (> leftover 0) (+ 8 (* 4 (ceiling (* leftover ,size) 4))) 0))) (request-length (+ 7 (/ payloadsize 4)))) (declare (integer request-length)) (with-buffer-request (,display (extension-opcode ,display "RENDER") :length (* 4 request-length)) (data ,opcode) (length request-length) (render-op ,alu) (pad8 0) (pad16 0) (picture ,source) (picture ,dest) ((or (member :none) picture-format) ,mask-format) (glyph-set ,glyph-set) (int16 ,src-x) (int16 ,src-y) (progn (let ((boffset (+ buffer-boffset 28)) (start ,start) (end ,end) (dest-x ,dest-x) (dest-y ,dest-y)) (dotimes (i nchunks) (set-buffer-offset boffset) (put-items (0) (card8 ,chunksize) (card8 0) (card16 0) (int16 dest-x) (int16 dest-y) ((sequence :start start :end (+ start ,chunksize) :format ,type :transform ,transform :appending t) ,sequence)) (setq dest-x 0 dest-y 0) (incf boffset (+ 8 (* ,chunksize ,size))) (incf start ,chunksize)) (when (> leftover 0) (set-buffer-offset boffset) (put-items (0) (card8 leftover) (card8 0) (card16 0) (int16 dest-x) (int16 dest-y) ((sequence :start start :end end :format ,type :transform ,transform :appending t) ,sequence)) ;; padding? (incf boffset (+ 8 (* 4 (ceiling (* leftover ,size) 4))))) (setf (buffer-boffset ,display) boffset)))))))) (defun render-composite-glyphs (dest glyph-set source dest-x dest-y sequence &key (op :over) (alu op) ;for the fun of it (src-x 0) (src-y 0) (mask-format :none) (start 0) (end (length sequence))) ;; xxx do we want to go with some translate function as draw-glyphs? (declare (type array-index start end)) (let ((display (picture-display dest))) (ensure-render-initialized display) (synchronise-picture-state dest) (synchronise-picture-state source) ;; hmm find out the element size (typecase sequence ((array (unsigned-byte 8) (*)) (%render-composite-glyphs +X-RenderCompositeGlyphs8+ card8 nil display dest glyph-set source dest-x dest-y sequence alu src-x src-y mask-format start end)) ((array (unsigned-byte 16) (*)) (%render-composite-glyphs +X-RenderCompositeGlyphs16+ card16 nil display dest glyph-set source dest-x dest-y sequence alu src-x src-y mask-format start end)) ((array (unsigned-byte 32) (*)) (%render-composite-glyphs +X-RenderCompositeGlyphs32+ card32 nil display dest glyph-set source dest-x dest-y sequence alu src-x src-y mask-format start end)) (string (%render-composite-glyphs #.(cond ((<= char-code-limit (expt 2 8)) '+X-RenderCompositeGlyphs8+) ((<= char-code-limit (expt 2 16)) '+X-RenderCompositeGlyphs16+) ((<= char-code-limit (expt 2 32)) '+X-RenderCompositeGlyphs32+) (t (error "Wow!"))) #.(cond ((<= char-code-limit (expt 2 8)) 'card8) ((<= char-code-limit (expt 2 16)) 'card16) ((<= char-code-limit (expt 2 32)) 'card32) (t (error "Wow!"))) #'char-code display dest glyph-set source dest-x dest-y sequence alu src-x src-y mask-format start end)) (t ;; should we bother testing the array element type? (%render-composite-glyphs +X-RenderCompositeGlyphs32+ card32 #'(lambda (elt) (if (characterp elt) (char-code elt) elt)) display dest glyph-set source dest-x dest-y sequence alu src-x src-y mask-format start end))) )) ;; --- idea: Allow data to be an image to avoid unecessary consing? - noss (defun render-add-glyph (glyph-set id &key x-origin y-origin x-advance y-advance data) (let ((display (glyph-set-display glyph-set))) (ensure-render-initialized display) (let* ((w (array-dimension data 1)) (h (array-dimension data 0)) (bitmap-format (display-bitmap-format display)) (unit (bitmap-format-unit bitmap-format)) (byte-lsb-first-p (display-image-lsb-first-p display)) (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) (let* ((byte-per-line (* 4 (ceiling (* w (picture-format-depth (glyph-set-format glyph-set))) 32))) (request-length (+ 28 (* h byte-per-line)))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderAddGlyphs+) (length (ceiling request-length 4)) (glyph-set glyph-set) (card32 1) ;number glyphs (card32 id) ;id (card16 w) (card16 h) (int16 x-origin) (int16 y-origin) (int16 x-advance) (int16 y-advance) (progn (setf (buffer-boffset display) (advance-buffer-offset 28)) (let ((im (create-image :width w :height h :depth 8 :data data))) (write-image-z display im 0 0 w h byte-per-line ;padded bytes per line unit byte-lsb-first-p bit-lsb-first-p)) ))) ))) (defun render-add-glyph-from-picture (glyph-set picture &key x-origin y-origin x-advance y-advance x y width height) ;; untested, the duplication of x-origin seems bogus. ;; Still untested, but these modifications seem to be more likely, (x,y) would be the offset into the picture. ;; and orgin advance would be properties of the defined glyph. (let ((display (glyph-set-display glyph-set))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderAddGlyphsFromPicture+) (glyph-set glyph-set) (picture picture) (card16 width) (card16 height) (card16 x-origin) (card16 y-origin) (card16 x-advance) (card16 y-advance) (card16 x) (card16 y)))) ;; untested (defun render-free-glyphs (glyph-set glyphs) "This request removes glyphs from glyph-set. Each glyph must exist in glyph-set (else a Match error results)." (let ((display (glyph-set-display glyph-set))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderFreeGlyphs+) (glyph-set glyph-set) ((sequence :format card32) glyphs)))) #|| ;;; -------------------------------------------------------------------------------- ;; testing code: (defun x (op) (let ((dpy (open-display ""))) (render-query-version dpy) (unwind-protect (let* ((win (screen-root (first (display-roots dpy)))) (display dpy) (pf (find-window-picture-format win)) (pm (xlib:create-pixmap :depth (xlib:drawable-depth win) :drawable win :width 1 :height 1)) (pm.p (render-create-picture pm :format pf :repeat :on)) (win.p (render-create-picture win :format pf)) (gs (render-create-glyph-set (first (find-matching-picture-formats dpy :alpha 8 :red-max 0 :green-max 0 :blue-max 0))))) (xlib:clear-area win) (render-fill-rectangle pm.p :src (list #xFFFF 0 0 0) 0 0 100 100) (render-add-glyph gs 18 :data (make-array (list 3 3) :initial-contents '((255 000 000) (000 255 000) (000 000 255)) :element-type '(unsigned-byte 8)) :x-advance 4 :y-advance 0 :x-origin 0 :y-origin 0) (let ((w 50) (h 50)) (let ((data (make-array (list h w) :element-type '(unsigned-byte 8) :initial-element 0))) (dotimes (i w) (dotimes (j h) (setf (aref data i j) (* 3 i)))) (render-add-glyph gs 17 :data data :x-advance (+ w 2) :y-advance 0 :x-origin 0 :y-origin 0))) (render-composite-glyphs-8 win.p gs pm.p 200 330 (vector 17 18 18 17 17 17 17 17 17 17) :alu op ) ;; (display-finish-output dpy) (close-display dpy))))) (defun z (op) (let ((dpy (open-display ""))) (unwind-protect (let* ((win (screen-root (first (display-roots dpy)))) (pic (render-create-picture win)) (fmt (first (find-matching-picture-formats dpy :red-min 8 :green-min 8 :blue-min 8 :alpha-min 8))) (px (xlib:create-pixmap :width 256 :height 256 :depth (picture-format-depth fmt) :drawable win)) (px.pic (render-create-picture px :format fmt)) (px.gc (xlib:create-gcontext :drawable px))) (xlib:clear-area win) ;; (render-fill-rectangle px.pic :src (list #x8000 #x0000 #x8000 #xFFFF) 0 0 256 256) (render-composite :src pic pic px.pic 350 350 350 350 0 0 256 256) ;; (render-fill-rectangle px.pic :over (list #x8000 #x8000 #x8000 #x8000) 0 0 100 100) (render-composite :src px.pic px.pic pic 0 0 0 0 350 350 256 256) (render-fill-rectangle pic op (list #x0 #x0 #x0 #x8000) 200 200 800 800) (display-finish-output dpy)) (close-display dpy)))) ;;; ---------------------------------------------------------------------------------------------------- (defun y (op) (let ((dpy (open-display ""))) (render-query-version dpy) (unwind-protect (let* ((win (screen-root (first (display-roots dpy)))) (pic (render-create-picture win)) (px (xlib:create-pixmap :drawable win :width 256 :height 256 :depth 32)) (px.gc (xlib:create-gcontext :drawable px))) (dotimes (x 256) (dotimes (y 256) (setf (xlib:gcontext-foreground px.gc) (dpb x (byte 8 24) (dpb y (byte 8 16) (dpb y (byte 8 8) y)))) (xlib:draw-point px px.gc x y) )) (xlib:clear-area win) (let ((q (render-create-picture px :format (first (find-matching-picture-formats dpy :depth 32 :alpha 8 :red 8 :green 8 :blue 8)) :component-alpha :on :repeat :off))) (render-composite op q q pic 0 0 0 0 100 100 400 400)) (let () ;;(render-fill-rectangle pic op (list 255 255 255 255) 100 100 200 200) (display-finish-output dpy))) (close-display dpy)))) (defun zz () (let* ((dpy (xlib:open-display "")) (win (screen-root (first (display-roots dpy)))) (pic (render-create-picture win))) (xlib:clear-area win) (setf (picture-clip-mask pic) (list 100 100 200 2000)) (render-fill-rectangle pic :over (list #xFFFF 0 0 #x400) 0 0 2000 2000) (display-finish-output dpy) (close-display dpy))) ||# ;;;; Cursors (defun render-create-cursor (picture &optional (x 0) (y 0)) (let ((display (picture-display picture))) (ensure-render-initialized display) (synchronise-picture-state picture) (let* ((cursor (make-cursor :display display)) (cid (allocate-resource-id display cursor 'cursor))) (setf (cursor-id cursor) cid) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderCreateCursor+) (resource-id cid) (resource-id (picture-id picture)) (card16 x) (card16 y)) cursor))) (defun render-create-anim-cursor (cursors delays) "Create animated cursor. cursors length must be the same as delays length." (let ((display (cursor-display (first cursors)))) (ensure-render-initialized display) (let* ((cursor (make-cursor :display display)) (cid (allocate-resource-id display cursor 'cursor)) (cursors-length (length cursors)) (cursors-delays (make-list (* 2 (length cursors))))) (setf (xlib:cursor-id cursor) cid) (dotimes (i cursors-length) (setf (elt cursors-delays (* 2 i)) (cursor-id (elt cursors i)) (elt cursors-delays (1+ (* 2 i))) (elt delays i))) (xlib::with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderCreateAnimCursor+) (resource-id cid) ((sequence :format card32) cursors-delays)) cursor))) cl-clx-sbcl-0.7.4.20160323.orig/clx.lisp0000644000175000017500000010547212715665272015312 0ustar pdmpdm;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; ;; Primary Interface Author: ;; Robert W. Scheifler ;; MIT Laboratory for Computer Science ;; 545 Technology Square, Room 418 ;; Cambridge, MA 02139 ;; rws@zermatt.lcs.mit.edu ;; Design Contributors: ;; Dan Cerys, Texas Instruments ;; Scott Fahlman, CMU ;; Charles Hornig, Symbolics ;; John Irwin, Franz ;; Kerry Kimbrough, Texas Instruments ;; Chris Lindblad, MIT ;; Rob MacLachlan, CMU ;; Mike McMahon, Symbolics ;; David Moon, Symbolics ;; LaMott Oren, Texas Instruments ;; Daniel Weinreb, Symbolics ;; John Wroclawski, MIT ;; Richard Zippel, Symbolics ;; Primary Implementation Author: ;; LaMott Oren, Texas Instruments ;; Implementation Contributors: ;; Charles Hornig, Symbolics ;; John Irwin, Franz ;; Chris Lindblad, MIT ;; Robert Scheifler, MIT ;;; ;;; Change history: ;;; ;;; Date Author Description ;;; ------------------------------------------------------------------------------------- ;;; 04/07/87 R.Scheifler Created code stubs ;;; 04/08/87 L.Oren Started Implementation ;;; 05/11/87 L.Oren Included draft 3 revisions ;;; 07/07/87 L.Oren Untested alpha release to MIT ;;; 07/17/87 L.Oren Alpha release ;;; 08/**/87 C.Lindblad Rewrite of buffer code ;;; 08/**/87 et al Various random bug fixes ;;; 08/**/87 R.Scheifler General syntactic and portability cleanups ;;; 08/**/87 R.Scheifler Rewrite of gcontext caching and shadowing ;;; 09/02/87 L.Oren Change events from resource-ids to objects ;;; 12/24/87 R.Budzianowski KCL support ;;; 12/**/87 J.Irwin ExCL 2.0 support ;;; 01/20/88 L.Oren Add server extension mechanisms ;;; 01/20/88 L.Oren Only force output when blocking on input ;;; 01/20/88 L.Oren Uniform support for :event-window on events ;;; 01/28/88 L.Oren Add window manager property functions ;;; 01/28/88 L.Oren Add character translation facility ;;; 02/**/87 J.Irwin Allegro 2.2 support ;;; This is considered a somewhat changeable interface. Discussion of better ;;; integration with CLOS, support for user-specified subclassess of basic ;;; objects, and the additional functionality to match the C Xlib is still in ;;; progress. Bug reports should be addressed to bug-clx@expo.lcs.mit.edu. ;; Note: all of the following is in the package XLIB. (in-package :xlib) (pushnew :clx *features*) (pushnew :xlib *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 ;; Note: if you have read the Version 11 protocol document or C Xlib manual, most of ;; the relationships should be fairly obvious. We have no intention of writing yet ;; another moby document for this interface. ;; Types employed: display, window, pixmap, cursor, font, gcontext, colormap, color. ;; These types are defined solely by a functional interface; we do not specify ;; whether they are implemented as structures or flavors or ... Although functions ;; below are written using DEFUN, this is not an implementation requirement (although ;; it is a requirement that they be functions as opposed to macros or special forms). ;; It is unclear whether with-slots in the Common Lisp Object System must work on ;; them. ;; Windows, pixmaps, cursors, fonts, gcontexts, and colormaps are all represented as ;; compound objects, rather than as integer resource-ids. This allows applications ;; to deal with multiple displays without having an explicit display argument in the ;; most common functions. Every function uses the display object indicated by the ;; first argument that is or contains a display; it is an error if arguments contain ;; different displays, and predictable results are not guaranteed. ;; Each of window, pixmap, cursor, font, gcontext, and colormap have the following ;; five functions: ;(defun make- (display resource-id) ; ;; This function should almost never be called by applications, except in handling ; ;; events. To minimize consing in some implementations, this may use a cache in ; ;; the display. Make-gcontext creates with :cache-p nil. Make-font creates with ; ;; cache-p true. ; (declare (type display display) ; (type integer resource-id) ; (clx-values ))) ;(defun -display () ; (declare (type ) ; (clx-values display))) ;(defun -id () ; (declare (type ) ; (clx-values integer))) ;(defun -equal (-1 -2) ; (declare (type -1 -2))) ;(defun -p (-1 -2) ; (declare (type -1 -2) ; (clx-values boolean))) (deftype generalized-boolean () 't) ; (or null (not null)) (deftype card32 () '(unsigned-byte 32)) (deftype card29 () '(unsigned-byte 29)) (deftype card24 () '(unsigned-byte 24)) (deftype int32 () '(signed-byte 32)) (deftype card16 () '(unsigned-byte 16)) (deftype int16 () '(signed-byte 16)) (deftype card8 () '(unsigned-byte 8)) (deftype int8 () '(signed-byte 8)) (deftype card4 () '(unsigned-byte 4)) #-clx-ansi-common-lisp (deftype real (&optional (min '*) (max '*)) (labels ((convert (limit floatp) (typecase limit (number (if floatp (float limit 0s0) (rational limit))) (list (map 'list #'convert limit)) (otherwise limit)))) `(or (float ,(convert min t) ,(convert max t)) (rational ,(convert min nil) ,(convert max nil))))) #-clx-ansi-common-lisp (deftype base-char () 'string-char) ; Note that we are explicitly using a different rgb representation than what ; is actually transmitted in the protocol. (deftype rgb-val () '(real 0 1)) ; Note that we are explicitly using a different angle representation than what ; is actually transmitted in the protocol. (deftype angle () '(real #.(* -2 pi) #.(* 2 pi))) (deftype mask32 () 'card32) (deftype mask16 () 'card16) (deftype pixel () '(unsigned-byte 32)) (deftype image-depth () '(integer 0 32)) (deftype resource-id () 'card29) (deftype keysym () 'card32) ; The following functions are provided by color objects: ; The intention is that IHS and YIQ and CYM interfaces will also exist. ; Note that we are explicitly using a different spectrum representation ; than what is actually transmitted in the protocol. (def-clx-class (color (:constructor make-color-internal (red green blue)) (:copier nil) (:print-function print-color)) (red 0.0 :type rgb-val) (green 0.0 :type rgb-val) (blue 0.0 :type rgb-val)) (defun print-color (color stream depth) (declare (type color color) (ignore depth)) (print-unreadable-object (color stream :type t) (prin1 (color-red color) stream) (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 12 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) (extended-max-request-length 0 :type card32) ) (defun print-display-name (display stream) (declare (type (or null display) display)) (cond (display #-allegro (princ (display-host display) stream) #+allegro (write-string (string (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) (let ((*print-base* 16)) (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)) (defconstant +predefined-atoms+ '#(nil :PRIMARY :SECONDARY :ARC :ATOM :BITMAP :CARDINAL :COLORMAP :CURSOR :CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7 :DRAWABLE :FONT :INTEGER :PIXMAP :POINT :RECTANGLE :RESOURCE_MANAGER :RGB_COLOR_MAP :RGB_BEST_MAP :RGB_BLUE_MAP :RGB_DEFAULT_MAP :RGB_GRAY_MAP :RGB_GREEN_MAP :RGB_RED_MAP :STRING :VISUALID :WINDOW :WM_COMMAND :WM_HINTS :WM_CLIENT_MACHINE :WM_ICON_NAME :WM_ICON_SIZE :WM_NAME :WM_NORMAL_HINTS :WM_SIZE_HINTS :WM_ZOOM_HINTS :MIN_SPACE :NORM_SPACE :MAX_SPACE :END_SPACE :SUPERSCRIPT_X :SUPERSCRIPT_Y :SUBSCRIPT_X :SUBSCRIPT_Y :UNDERLINE_POSITION :UNDERLINE_THICKNESS :STRIKEOUT_ASCENT :STRIKEOUT_DESCENT :ITALIC_ANGLE :X_HEIGHT :QUAD_WIDTH :WEIGHT :POINT_SIZE :RESOLUTION :COPYRIGHT :NOTICE :FONT_NAME :FAMILY_NAME :FULL_NAME :CAP_HEIGHT :WM_CLASS :WM_TRANSIENT_FOR)) (deftype stringable () '(or string symbol)) (deftype fontable () '(or stringable font)) ; Nil stands for CurrentTime. (deftype timestamp () '(or null card32)) (defconstant +bit-gravity-vector+ '#(:forget :north-west :north :north-east :west :center :east :south-west :south :south-east :static)) (deftype bit-gravity () '(member :forget :north-west :north :north-east :west :center :east :south-west :south :south-east :static)) (defconstant +win-gravity-vector+ '#(:unmap :north-west :north :north-east :west :center :east :south-west :south :south-east :static)) (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))) (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 #-explorer :type #-explorer (or null gcontext)) ) (defun print-gcontext (gcontext stream depth) (declare (type gcontext gcontext) (ignore depth)) (print-unreadable-object (gcontext stream :type t) (print-display-name (gcontext-display gcontext) stream) (write-string " " stream) (prin1 (gcontext-id gcontext) stream))) (defconstant +event-mask-vector+ '#(:key-press :key-release :button-press :button-release :enter-window :leave-window :pointer-motion :pointer-motion-hint :button-1-motion :button-2-motion :button-3-motion :button-4-motion :button-5-motion :button-motion :keymap-state :exposure :visibility-change :structure-notify :resize-redirect :substructure-notify :substructure-redirect :focus-change :property-change :colormap-change :owner-grab-button)) (deftype event-mask-class () '(member :key-press :key-release :owner-grab-button :button-press :button-release :enter-window :leave-window :pointer-motion :pointer-motion-hint :button-1-motion :button-2-motion :button-3-motion :button-4-motion :button-5-motion :button-motion :exposure :visibility-change :structure-notify :resize-redirect :substructure-notify :substructure-redirect :focus-change :property-change :colormap-change :keymap-state)) (deftype event-mask () '(or mask32 (clx-list event-mask-class))) (defconstant +pointer-event-mask-vector+ ;; the first two elements used to be '%error '%error (i.e. symbols, ;; and not keywords) but the vector is supposed to contain ;; keywords, so I renamed them -dan 2004.11.13 '#(:%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))) (defconstant +device-event-mask-vector+ '#(:key-press :key-release :button-press :button-release :pointer-motion :button-1-motion :button-2-motion :button-3-motion :button-4-motion :button-5-motion :button-motion)) (deftype device-event-mask-class () '(member :key-press :key-release :button-press :button-release :pointer-motion :button-1-motion :button-2-motion :button-3-motion :button-4-motion :button-5-motion :button-motion)) (deftype device-event-mask () '(or mask32 (clx-list device-event-mask-class))) (defconstant +state-mask-vector+ '#(:shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5 :button-1 :button-2 :button-3 :button-4 :button-5)) (deftype modifier-key () '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5)) (deftype modifier-mask () '(or (member :any) mask16 (clx-list modifier-key))) (deftype state-mask-key () '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5))) (defconstant +gcontext-components+ '(:function :plane-mask :foreground :background :line-width :line-style :cap-style :join-style :fill-style :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes :arc-mode)) (deftype gcontext-key () '(member :function :plane-mask :foreground :background :line-width :line-style :cap-style :join-style :fill-style :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes :arc-mode)) (deftype event-key () '(or (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) (satisfies extension-event-key-p))) (deftype error-key () '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice :illegal-request :implementation :length :match :name :pixmap :value :window)) (deftype draw-direction () '(member :left-to-right :right-to-left)) (defconstant +boole-vector+ '#(#.boole-clr #.boole-and #.boole-andc2 #.boole-1 #.boole-andc1 #.boole-2 #.boole-xor #.boole-ior #.boole-nor #.boole-eqv #.boole-c2 #.boole-orc2 #.boole-c1 #.boole-orc1 #.boole-nand #.boole-set)) (deftype boole-constant () `(member ,boole-clr ,boole-and ,boole-andc2 ,boole-1 ,boole-andc1 ,boole-2 ,boole-xor ,boole-ior ,boole-nor ,boole-eqv ,boole-c2 ,boole-orc2 ,boole-c1 ,boole-orc1 ,boole-nand ,boole-set)) (def-clx-class (screen (:copier nil) (:print-function print-screen)) (root nil :type (or null window)) (width 0 :type card16) (height 0 :type card16) (width-in-millimeters 0 :type card16) (height-in-millimeters 0 :type card16) (depths nil :type (alist (image-depth depth) ((clx-list visual-info) visuals))) (root-depth 1 :type image-depth) (root-visual-info nil :type (or null visual-info)) (default-colormap nil :type (or null colormap)) (white-pixel 0 :type pixel) (black-pixel 1 :type pixel) (min-installed-maps 1 :type card16) (max-installed-maps 1 :type card16) (backing-stores :never :type (member :never :when-mapped :always)) (save-unders-p nil :type generalized-boolean) (event-mask-at-open 0 :type mask32) (plist nil :type list) ; Extension hook ) (defun print-screen (screen stream depth) (declare (type screen screen) (ignore depth)) (print-unreadable-object (screen stream :type t) (let ((display (drawable-display (screen-root screen)))) (print-display-name display stream) (write-string "." stream) (princ (position screen (display-roots display)) stream)) (write-string " " stream) (prin1 (screen-width screen) stream) (write-string "x" stream) (prin1 (screen-height screen) stream) (write-string "x" stream) (prin1 (screen-root-depth screen) stream) (when (screen-root-visual-info screen) (write-string " " stream) (princ (visual-info-class (screen-root-visual-info screen)) stream)))) (defun screen-root-visual (screen) (declare (type screen screen) (clx-values resource-id)) (visual-info-id (screen-root-visual-info screen))) ;; The list contains alternating keywords and integers. (deftype font-props () 'list) (def-clx-class (font-info (:copier nil) (:predicate nil)) (direction :left-to-right :type draw-direction) (min-char 0 :type card16) ;; First character in font (max-char 0 :type card16) ;; Last character in font (min-byte1 0 :type card8) ;; The following are for 16 bit fonts (max-byte1 0 :type card8) ;; and specify min&max values for (min-byte2 0 :type card8) ;; the two character bytes (max-byte2 0 :type card8) (all-chars-exist-p nil :type generalized-boolean) (default-char 0 :type card16) (min-bounds nil :type (or null vector)) (max-bounds nil :type (or null vector)) (ascent 0 :type int16) (descent 0 :type int16) (properties nil :type font-props)) (def-clx-class (font (:constructor make-font-internal) (:copier nil) (:print-function print-font)) (id-internal nil :type (or null resource-id)) ;; NIL when not opened (display nil :type (or null display)) (reference-count 0 :type fixnum) (name "" :type (or null string)) ;; NIL when ID is for a GContext (font-info-internal nil :type (or null font-info)) (char-infos-internal nil :type (or null (simple-array int16 (*)))) (local-only-p t :type generalized-boolean) ;; When T, always calculate text extents locally (plist nil :type list) ; Extension hook ) (defun print-font (font stream depth) (declare (type font font) (ignore depth)) (print-unreadable-object (font stream :type t) (if (font-name font) (princ (font-name font) stream) (write-string "(gcontext)" stream)) (write-string " " stream) (print-display-name (font-display font) stream) (when (font-id-internal font) (write-string " " stream) (prin1 (font-id font) stream)))) (defun font-id (font) ;; Get font-id, opening font if needed (or (font-id-internal font) (open-font-internal font))) (defun font-font-info (font) (or (font-font-info-internal font) (query-font font))) (defun font-char-infos (font) (or (font-char-infos-internal font) (progn (query-font font) (font-char-infos-internal font)))) (defun make-font (&key id display (reference-count 0) (name "") (local-only-p t) font-info-internal) (make-font-internal :id-internal id :display display :reference-count reference-count :name name :local-only-p local-only-p :font-info-internal font-info-internal)) ; For each component ( :type ) of font-info, ; there is a corresponding function: ;(defun font- (font) ; (declare (type font font) ; (clx-values ))) (macrolet ((make-font-info-accessors (useless-name &body fields) `(within-definition (,useless-name make-font-info-accessors) ,@(mapcar #'(lambda (field) (let* ((type (second field)) (n (string (first field))) (name (xintern 'font- n)) (accessor (xintern 'font-info- n))) `(defun ,name (font) (declare (type font font)) (declare (clx-values ,type)) (,accessor (font-font-info font))))) fields)))) (make-font-info-accessors ignore (direction draw-direction) (min-char card16) (max-char card16) (min-byte1 card8) (max-byte1 card8) (min-byte2 card8) (max-byte2 card8) (all-chars-exist-p generalized-boolean) (default-char card16) (min-bounds vector) (max-bounds vector) (ascent int16) (descent int16) (properties font-props))) (defun font-property (font name) (declare (type font font) (type keyword name)) (declare (clx-values (or null int32))) (getf (font-properties font) name)) (macrolet ((make-mumble-equal (type) ;; Since caching is only done for objects created by the ;; client, we must always compare ID and display for ;; non-identical mumbles. (let ((predicate (xintern type '-equal)) (id (xintern type '-id)) (dpy (xintern type '-display))) `(within-definition (,type make-mumble-equal) (defun ,predicate (a b) (declare (type ,type a b)) (or (eql 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))) cl-clx-sbcl-0.7.4.20160323.orig/dpms.lisp0000644000175000017500000001354512715665272015466 0ustar pdmpdm ;;;; Original Author: Matthew Kennedy ;;;; ;;;; Documentation strings derived from DPMS.txt distributed with the Xorg X11 ;;;; server implementation. DPMS.txt contains the following copyright: ;;;; ;;;; Copyright (C) Digital Equipment Corporation, 1996 ;;;; ;;;; Permission to use, copy, modify, distribute, and sell this documentation ;;;; for any purpose is hereby granted without fee, provided that the above ;;;; copyright notice and this permission notice appear in all copies. Digital ;;;; Equipment Corporation makes no representations about the suitability for ;;;; any purpose of the information in this document. This documentation is ;;;; provided ``as is'' without express or implied warranty. (defpackage :dpms (:use :common-lisp) (:import-from :xlib "DEFINE-EXTENSION" "DISPLAY" "WITH-BUFFER-REQUEST-AND-REPLY" "WITH-BUFFER-REQUEST" "EXTENSION-OPCODE" "CARD8-GET" "CARD16-GET" "BOOLEAN-GET" "CARD8" "CARD16" "DATA") (:export "DPMS-GET-VERSION" "DPMS-CAPABLE" "DPMS-GET-TIMEOUTS" "DPMS-SET-TIMEOUTS" "DPMS-ENABLE" "DPMS-DISABLE" "DPMS-FORCE-LEVEL" "DPMS-INFO")) (in-package :dpms) (define-extension "DPMS") (defmacro dpms-opcode (display) `(extension-opcode ,display "DPMS")) (defconstant +get-version+ 0) (defconstant +capable+ 1) (defconstant +get-timeouts+ 2) (defconstant +set-timeouts+ 3) (defconstant +enable+ 4) (defconstant +disable+ 5) (defconstant +force-level+ 6) (defconstant +info+ 7) (defun dpms-get-version (display &optional (major-version 1) (minor-version 1)) "Return two values: the major and minor version of the DPMS implementation the server supports. If supplied, the MAJOR-VERSION and MINOR-VERSION indicate what version of the protocol the client wants the server to implement." (declare (type display display)) (with-buffer-request-and-reply (display (dpms-opcode display) nil) ((data +get-version+) (card16 major-version) (card16 minor-version)) (values (card16-get 8) (card16-get 10)))) (defun dpms-capable (display) "True if the currently running server's devices are capable of DPMS operations. The truth value of this request is implementation defined, but is generally based on the capabilities of the graphic card and monitor combination. Also, the return value in the case of heterogeneous multi-head servers is implementation defined." (declare (type display display)) (with-buffer-request-and-reply (display (dpms-opcode display) nil) ((data +capable+)) (boolean-get 8))) (defun dpms-get-timeouts (display) "Return three values: the current values of the DPMS timeout values. The timeout values are (in order returned): standby, suspend and off. All values are in units of seconds. A value of zero for any timeout value indicates that the mode is disabled." (declare (type display display)) (with-buffer-request-and-reply (display (dpms-opcode display) nil) ((data +get-timeouts+)) (values (card16-get 8) (card16-get 10) (card16-get 12)))) (defun dpms-set-timeouts (display standby suspend off) "Set the values of the DPMS timeouts. All values are in units of seconds. A value of zero for any timeout value disables that mode." (declare (type display display)) (with-buffer-request (display (dpms-opcode display)) (data +set-timeouts+) (card16 standby) (card16 suspend) (card16 off) (card16 0)) ;unused (values)) (defun dpms-enable (display) "Enable the DPMS characteristics of the server using the server's currently stored timeouts. If DPMS is already enabled, no change is affected." (declare (type display display)) (with-buffer-request (display (dpms-opcode display)) (data +enable+)) (values)) (defun dpms-disable (display) "Disable the DPMS characteristics of the server. It does not affect the core or extension screen savers. If DPMS is already disabled, no change is effected. This request is provided so that DPMS may be disabled without damaging the server's stored timeout values." (declare (type display display)) (with-buffer-request (display (dpms-opcode display)) ((data +disable+))) (values)) (defun dpms-force-level (display power-level) "Forces a specific DPMS level on the server. Valid keyword values for POWER-LEVEL are: DPMS-MODE-ON, DPMS-MODE-STANDBY, DPMS-MODE-SUSPEND and DPMS-MODE-OFF." (declare (type display display)) (with-buffer-request (display (dpms-opcode display)) (data +force-level+) (card16 (ecase power-level (:dpms-mode-on 0) (:dpms-mode-standby 1) (:dpms-mode-suspend 2) (:dpms-mode-off 3))) (card16 0)) ;unused (values)) (defun dpms-info (display) "Returns two valus: the DPMS power-level and state value for the display. State is one of the keywords DPMS-ENABLED or DPMS-DISABLED. If state is DPMS-ENABLED, then power level is returned as one of the keywords DPMS-MODE-ON, DPMS-MODE-STANDBY, DPMS-MODE-SUSPEND or DPMS-MODE-OFF. If state is DPMS-DISABLED, then power-level is undefined and returned as NIL." (declare (type display display)) (with-buffer-request-and-reply (display (dpms-opcode display) nil) ((data +info+)) (let ((state (if (boolean-get 10) :dpms-enabled :dpms-disabled))) (values (unless (eq state :dpms-disabled) (ecase (card16-get 8) (0 :dpms-mode-on) (1 :dpms-mode-standby) (2 :dpms-mode-suspend) (3 :dpms-mode-off))) state)))) ;;; Local Variables: ;;; indent-tabs-mode: nil ;;; End: cl-clx-sbcl-0.7.4.20160323.orig/gcontext.lisp0000644000175000017500000012061012715665272016346 0ustar pdmpdm;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; GContext ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; ;;; GContext values are usually cached locally in the GContext object. ;;; This is required because the X.11 server doesn't have any requests ;;; for getting GContext values back. ;;; ;;; GContext changes are cached until force-GContext-changes is called. ;;; All the requests that use GContext (including the GContext accessors, ;;; but not the SETF's) call force-GContext-changes. ;;; In addition, the macro WITH-GCONTEXT may be used to provide a ;;; local view if a GContext. ;;; ;;; Each GContext keeps a copy of the values the server has seen, and ;;; a copy altered by SETF, called the LOCAL-STATE (bad name...). ;;; The SETF accessors increment a timestamp in the GContext. ;;; When the timestamp in a GContext isn't equal to the timestamp in ;;; the local-state, changes have been made, and force-GContext-changes ;;; loops through the GContext and local-state, sending differences to ;;; the server, and updating GContext. ;;; ;;; WITH-GCONTEXT works by BINDING the local-state slot in a GContext to ;;; a private copy. This is easy (and fast) for lisp machines, but other ;;; lisps will have problems. Fortunately, most other lisps don't care, ;;; because they don't run in a multi-processing shared-address space ;;; environment. (in-package :xlib) ;; GContext state accessors ;; The state vector contains all card32s to speed server updating (eval-when (:compile-toplevel :load-toplevel :execute) (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 (:compile-toplevel :load-toplevel :execute) (defvar *gcontext-data-length* ,index) (defvar *gcontext-indexes* ',indexes) (defvar *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) ;; FIXME: these used to have glorious, but wrong, type declarations. ;; See if we can't return them to their former glory. (set-function #'(lambda (gcontext value) (declare (ignore gcontext)) value) :type (or function symbol) :read-only t) (copy-function #'(lambda (from-gc to-gc value) (declare (ignore from-gc to-gc)) value) :type (or function symbol) :read-only t)) (defvar *gcontext-extensions* nil) ;; list of gcontext-extension ;; Gcontext state Resource (defvar *gcontext-local-state-cache* nil) ;; List of unused gcontext local states (defmacro gcontext-state-next (state) `(svref ,state 0)) (defun allocate-gcontext-state () ;; Allocate a gcontext-state ;; Loop until a local state is found that's large enough to hold ;; any extensions that may exist. (let ((length (index+ *gcontext-data-length* (length *gcontext-extensions*)))) (declare (type array-index length)) (loop (let ((state (or (threaded-atomic-pop *gcontext-local-state-cache* gcontext-state-next gcontext-state) (make-array length :initial-element nil)))) (declare (type gcontext-state state)) (when (index>= (length state) length) (return state)))))) (defun deallocate-gcontext-state (state) (declare (type gcontext-state state)) (fill state nil) (threaded-atomic-push state *gcontext-local-state-cache* gcontext-state-next gcontext-state)) ;; Temp-Gcontext Resource (defvar *temp-gcontext-cache* nil) ;; List of unused gcontexts (defun allocate-temp-gcontext () (or (threaded-atomic-pop *temp-gcontext-cache* gcontext-next gcontext) (make-gcontext :local-state '#() :server-state '#()))) (defun deallocate-temp-gcontext (gc) (declare (type gcontext gc)) (threaded-atomic-push gc *temp-gcontext-cache* gcontext-next gcontext)) ;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared ;; as (type ), there is an accessor: ;(defun gcontext- (gcontext) ; ;; The value will be nil if the last value stored is unknown (e.g., the cache was ; ;; off, or the component was copied from a gcontext with unknown state). ; (declare (type gcontext gcontext) ; (clx-values ))) ;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared ;; as (type (or null ) ), there is a setf for the corresponding accessor: ;(defsetf gcontext- (gcontext) (value) ; ) ;; Generate all the accessors and defsetf's for GContext (defmacro xgcmask->gcmask (mask) `(the gcmask (logand ,mask #.(1- (ash 1 +gcontext-fast-change-length+))))) (defmacro access-gcontext ((gcontext local-state) &body body) `(let ((,local-state (gcontext-local-state ,gcontext))) (declare (type gcontext-state ,local-state)) ,@body)) (defmacro modify-gcontext ((gcontext local-state) &body body) ;; The timestamp must be altered after the modification `(let ((,local-state (gcontext-local-state ,gcontext))) (declare (type gcontext-state ,local-state)) (prog1 (progn ,@body) (setf (gcontext-internal-timestamp ,local-state) 0)))) (defmacro def-gc-accessor (name type) (let* ((gcontext-name (xintern 'gcontext- name)) (internal-accessor (xintern 'gcontext-internal- name)) (internal-setfer (xintern 'set- gcontext-name))) `(within-definition (,name def-gc-accessor) (defun ,gcontext-name (gcontext) (declare (type gcontext gcontext)) (declare (clx-values (or null ,type))) (let ((value (,internal-accessor (gcontext-local-state gcontext)))) (declare (type (or null card32) value)) (when value ;; Don't do anything when value isn't known (let ((%buffer (gcontext-display gcontext))) (declare (type display %buffer)) %buffer (decode-type ,type value))))) (defun ,internal-setfer (gcontext value) (declare (type gcontext gcontext) (type ,type value)) (modify-gcontext (gcontext local-state) (setf (,internal-accessor local-state) (encode-type ,type value)) ,@(when (eq type 'pixmap) ;; write-through pixmaps, because the protocol allows ;; the server to copy the pixmap contents at the time ;; of the store, rather than continuing to share with ;; the pixmap. `((let ((server-state (gcontext-server-state gcontext))) (setf (,internal-accessor server-state) nil)))) value)) (defsetf ,gcontext-name ,internal-setfer)))) (defmacro incf-internal-timestamp (state) (let ((ts (gensym))) `(let ((,ts (the fixnum (gcontext-internal-timestamp ,state)))) (declare (type fixnum ,ts)) ;; the probability seems low enough (setq ,ts (if (= ,ts most-positive-fixnum) 1 (the fixnum (1+ ,ts)))) (setf (gcontext-internal-timestamp ,state) ,ts)))) (def-gc-accessor function boole-constant) (def-gc-accessor plane-mask card32) (def-gc-accessor foreground card32) (def-gc-accessor background card32) (def-gc-accessor line-width card16) (def-gc-accessor line-style (member :solid :dash :double-dash)) (def-gc-accessor cap-style (member :not-last :butt :round :projecting)) (def-gc-accessor join-style (member :miter :round :bevel)) (def-gc-accessor fill-style (member :solid :tiled :stippled :opaque-stippled)) (def-gc-accessor fill-rule (member :even-odd :winding)) (def-gc-accessor tile pixmap) (def-gc-accessor stipple pixmap) (def-gc-accessor ts-x int16) ;; Tile-Stipple-X-origin (def-gc-accessor ts-y int16) ;; Tile-Stipple-Y-origin ;; (def-GC-accessor font font) ;; See below (def-gc-accessor subwindow-mode (member :clip-by-children :include-inferiors)) (def-gc-accessor exposures (member :off :on)) (def-gc-accessor clip-x int16) (def-gc-accessor clip-y int16) ;; (def-GC-accessor clip-mask) ;; see below (def-gc-accessor dash-offset card16) ;; (def-GC-accessor dashes) ;; see below (def-gc-accessor arc-mode (member :chord :pie-slice)) (defun gcontext-clip-mask (gcontext) (declare (type gcontext gcontext)) (declare (clx-values (or null (member :none) pixmap rect-seq) (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)))) (access-gcontext (gcontext local-state) (multiple-value-bind (clip clip-mask) (without-interrupts (values (gcontext-internal-clip local-state) (gcontext-internal-clip-mask local-state))) (if (null clip) (values (let ((%buffer (gcontext-display gcontext))) (declare (type display %buffer)) (decode-type (or (member :none) pixmap) clip-mask)) nil) (values (second clip) (decode-type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) (first clip))))))) (defsetf gcontext-clip-mask (gcontext &optional ordering) (clip-mask) ;; A bit strange, but retains setf form. ;; a nil clip-mask is transformed to an empty vector `(set-gcontext-clip-mask ,gcontext ,ordering ,clip-mask)) (defun set-gcontext-clip-mask (gcontext ordering clip-mask) ;; a nil clip-mask is transformed to an empty vector (declare (type gcontext gcontext) (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) ordering) (type (or (member :none) pixmap rect-seq) clip-mask)) (unless clip-mask (x-type-error clip-mask '(or (member :none) pixmap rect-seq))) (multiple-value-bind (clip-mask clip) (typecase clip-mask (pixmap (values (pixmap-id clip-mask) nil)) ((member :none) (values 0 nil)) (sequence (values nil (list (encode-type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) ordering) (copy-seq clip-mask)))) (otherwise (x-type-error clip-mask '(or (member :none) pixmap rect-seq)))) (modify-gcontext (gcontext local-state) (let ((server-state (gcontext-server-state gcontext))) (declare (type gcontext-state server-state)) (without-interrupts (setf (gcontext-internal-clip local-state) clip (gcontext-internal-clip-mask local-state) clip-mask) (if (null clip) (setf (gcontext-internal-clip server-state) nil) (setf (gcontext-internal-clip-mask server-state) nil)) (when (and clip-mask (not (zerop clip-mask))) ;; write-through clip-mask pixmap, because the protocol allows the ;; server to copy the pixmap contents at the time of the store, ;; rather than continuing to share with the pixmap. (setf (gcontext-internal-clip-mask server-state) nil)))))) clip-mask) (defun gcontext-dashes (gcontext) (declare (type gcontext gcontext)) (declare (clx-values (or null card8 sequence))) (access-gcontext (gcontext local-state) (multiple-value-bind (dash dashes) (without-interrupts (values (gcontext-internal-dash local-state) (gcontext-internal-dashes local-state))) (if (null dash) dashes dash)))) (defsetf gcontext-dashes set-gcontext-dashes) (defun set-gcontext-dashes (gcontext dashes) (declare (type gcontext gcontext) (type (or card8 sequence) dashes)) (multiple-value-bind (dashes dash) (if (type? dashes 'sequence) (if (zerop (length dashes)) (x-type-error dashes '(or card8 sequence) "non-empty sequence") (values nil (or (copy-seq dashes) (vector)))) (values (encode-type card8 dashes) nil)) (modify-gcontext (gcontext local-state) (let ((server-state (gcontext-server-state gcontext))) (declare (type gcontext-state server-state)) (without-interrupts (setf (gcontext-internal-dash local-state) dash (gcontext-internal-dashes local-state) dashes) (if (null dash) (setf (gcontext-internal-dash server-state) nil) (setf (gcontext-internal-dashes server-state) nil)))))) dashes) (defun gcontext-font (gcontext &optional metrics-p) ;; If the stored font is known, it is returned. If it is not known and ;; metrics-p is false, then nil is returned. If it is not known and ;; metrics-p is true, then a pseudo font is returned. Full metric and ;; property information can be obtained, but the font does not have a name or ;; a resource-id, and attempts to use it where a resource-id is required will ;; result in an invalid-font error. (declare (type gcontext gcontext) (type generalized-boolean metrics-p)) (declare (clx-values (or null font))) (access-gcontext (gcontext local-state) (let ((font (gcontext-internal-font-obj local-state))) (or font (when metrics-p ;; XXX this isn't correct (make-font :display (gcontext-display gcontext) :id (gcontext-id gcontext) :name nil)))))) (defsetf gcontext-font set-gcontext-font) (defun set-gcontext-font (gcontext font) (declare (type gcontext gcontext) (type fontable font)) (let* ((font-object (if (font-p font) font (open-font (gcontext-display gcontext) font))) (font (and font-object (font-id font-object)))) ;; XXX need to check font has id (and name?) (modify-gcontext (gcontext local-state) (let ((server-state (gcontext-server-state gcontext))) (declare (type gcontext-state server-state)) (without-interrupts (setf (gcontext-internal-font-obj local-state) font-object (gcontext-internal-font local-state) font) ;; check against font, not against font-obj (if (null font) (setf (gcontext-internal-font server-state) nil) (setf (gcontext-internal-font-obj server-state) font-object)))))) font) (defun force-gcontext-changes-internal (gcontext) ;; Force any delayed changes. (declare (type gcontext gcontext)) #.(declare-buffun) (let ((display (gcontext-display gcontext)) (server-state (gcontext-server-state gcontext)) (local-state (gcontext-local-state gcontext))) (declare (type display display) (type gcontext-state server-state local-state)) ;; Update server when timestamps don't match (unless (= (the fixnum (gcontext-internal-timestamp local-state)) (the fixnum (gcontext-internal-timestamp server-state))) ;; The display is already locked. (macrolet ((with-buffer ((buffer &key timeout) &body body) `(progn (progn ,buffer ,@(and timeout `(,timeout)) nil) ,@body))) ;; Because there is no locking on the local state we have to ;; assume that state will change and set timestamps up front, ;; otherwise by the time we figured out there were no changes ;; and tried to store the server stamp as the local stamp, the ;; local stamp might have since been modified. (setf (gcontext-internal-timestamp local-state) (incf-internal-timestamp server-state)) (block no-changes (let ((last-request (buffer-last-request display))) (with-buffer-request (display +x-changegc+) (gcontext gcontext) (progn (do ((i 0 (index+ i 1)) (bit 1 (the xgcmask (ash bit 1))) (nbyte 12) (mask 0) (local 0)) ((index>= i +gcontext-fast-change-length+) (when (zerop mask) ;; If nothing changed, restore last-request and quit (setf (buffer-last-request display) (if (zerop (buffer-last-request display)) nil last-request)) (return-from no-changes nil)) (card29-put 8 mask) (card16-put 2 (index-ash nbyte -2)) (index-incf (buffer-boffset display) nbyte)) (declare (type array-index i nbyte) (type xgcmask bit) (type gcmask mask) (type (or null card32) local)) (unless (eql (the (or null card32) (svref server-state i)) (setq local (the (or null card32) (svref local-state i)))) (setf (svref server-state i) local) (card32-put nbyte local) (setq mask (the gcmask (logior mask bit))) (index-incf nbyte 4))))))) ;; Update GContext extensions (do ((extension *gcontext-extensions* (cdr extension)) (i *gcontext-data-length* (index+ i 1)) (local)) ((endp extension)) (unless (eql (svref server-state i) (setq local (svref local-state i))) (setf (svref server-state i) local) (funcall (gcontext-extension-set-function (car extension)) gcontext local))) ;; Update clipping rectangles (multiple-value-bind (local-clip server-clip) (without-interrupts (values (gcontext-internal-clip local-state) (gcontext-internal-clip server-state))) (unless (equalp local-clip server-clip) (setf (gcontext-internal-clip server-state) nil) (unless (null local-clip) (with-buffer-request (display +x-setcliprectangles+) (data (first local-clip)) (gcontext gcontext) ;; XXX treat nil correctly (card16 (or (gcontext-internal-clip-x local-state) 0) (or (gcontext-internal-clip-y local-state) 0)) ;; XXX this has both int16 and card16 values ((sequence :format int16) (second local-clip))) (setf (gcontext-internal-clip server-state) local-clip)))) ;; Update dashes (multiple-value-bind (local-dash server-dash) (without-interrupts (values (gcontext-internal-dash local-state) (gcontext-internal-dash server-state))) (unless (equalp local-dash server-dash) (setf (gcontext-internal-dash server-state) nil) (unless (null local-dash) (with-buffer-request (display +x-setdashes+) (gcontext gcontext) ;; XXX treat nil correctly (card16 (or (gcontext-internal-dash-offset local-state) 0) (length local-dash)) ((sequence :format card8) local-dash)) (setf (gcontext-internal-dash server-state) local-dash)))))))) (defun force-gcontext-changes (gcontext) ;; Force any delayed changes. (declare (type gcontext gcontext)) (let ((display (gcontext-display gcontext)) (server-state (gcontext-server-state gcontext)) (local-state (gcontext-local-state gcontext))) (declare (type gcontext-state server-state local-state)) ;; Update server when timestamps don't match (unless (= (the fixnum (gcontext-internal-timestamp local-state)) (the fixnum (gcontext-internal-timestamp server-state))) (with-display (display) (force-gcontext-changes-internal gcontext))))) ;;; WARNING: WITH-GCONTEXT WORKS MUCH MORE EFFICIENTLY WHEN THE OPTIONS BEING "BOUND" ARE ;;; SET IN THE GCONTEXT ON ENTRY. BECAUSE THERE'S NO WAY TO GET THE VALUE OF AN ;;; UNKNOWN GC COMPONENT, WITH-GCONTEXT MUST CREATE A TEMPORARY GC, COPY THE UNKNOWN ;;; COMPONENTS TO THE TEMPORARY GC, ALTER THE GC BEING USED, THEN COPY COMPOMENTS ;;; BACK. (defmacro with-gcontext ((gcontext &rest options &key clip-ordering &allow-other-keys) &body body) ;; "Binds" the gcontext components specified by options within the ;; dynamic scope of the body (i.e., indefinite scope and dynamic ;; extent), on a per-process basis in a multi-process environment. ;; The body is not surrounded by a with-display. If cache-p is nil or ;; the some component states are unknown, this will implement ;; save/restore by creating a temporary gcontext and doing ;; copy-gcontext-components to and from it. (declare (arglist (gcontext &rest options &key function plane-mask foreground background line-width line-style cap-style join-style fill-style fill-rule arc-mode tile stipple ts-x ts-y font subwindow-mode exposures clip-x clip-y clip-mask clip-ordering dash-offset dashes &allow-other-keys) &body body)) (remf options :clip-ordering) (let ((gc (gensym)) (saved-state (gensym)) (temp-gc (gensym)) (temp-mask (gensym)) (temp-vars nil) (setfs nil) (indexes nil) ; List of gcontext field indices (extension-indexes nil) ; List of gcontext extension field indices (ts-index (getf *gcontext-indexes* :timestamp))) (do* ((option options (cddr option)) (name (car option) (car option)) (value (cadr option) (cadr option))) ((endp option) (setq setfs (nreverse setfs))) (let ((index (getf *gcontext-indexes* name))) (if index (push index indexes) (let ((extension (find name *gcontext-extensions* :key #'gcontext-extension-name))) (if extension (progn (push (xintern "Internal-" 'gcontext- name "-State-Index") extension-indexes)) (x-type-error name 'gcontext-key))))) (let ((accessor `(,(xintern 'gcontext- name) ,gc ,@(when (eq name :clip-mask) `(,clip-ordering)))) (temp-var (gensym))) (when value (push `(,temp-var ,value) temp-vars) (push `(when ,temp-var (setf ,accessor ,temp-var)) setfs)))) (if setfs `(multiple-value-bind (,gc ,saved-state ,temp-mask ,temp-gc) (copy-gcontext-local-state ,gcontext ',indexes ,@extension-indexes) (declare (type gcontext ,gc) (type gcontext-state ,saved-state) (type xgcmask ,temp-mask) (type (or null gcontext) ,temp-gc)) (with-gcontext-bindings (,gc ,saved-state ,(append indexes extension-indexes) ,ts-index ,temp-mask ,temp-gc) (let ,temp-vars ,@setfs) ,@body)) `(progn ,@body)))) (defun copy-gcontext-local-state (gcontext indexes &rest extension-indices) ;; Called from WITH-GCONTEXT to save the fields in GCONTEXT indicated by MASK (declare (type gcontext gcontext) (type list indexes) (dynamic-extent extension-indices)) (let ((local-state (gcontext-local-state gcontext)) (saved-state (allocate-gcontext-state)) (cache-p (gcontext-cache-p gcontext))) (declare (type gcontext-state local-state saved-state)) (setf (gcontext-internal-timestamp saved-state) 1) (let ((temp-gc nil) (temp-mask 0) (extension-mask 0)) (declare (type xgcmask temp-mask) (type integer extension-mask)) (dolist (i indexes) (when (or (not (setf (svref saved-state i) (svref local-state i))) (not cache-p)) (setq temp-mask (the xgcmask (logior temp-mask (the xgcmask (svref *gcontext-masks* i))))))) (dolist (i extension-indices) (when (or (not (setf (svref saved-state i) (svref local-state i))) (not cache-p)) (setq extension-mask (the xgcmask (logior extension-mask (ash 1 i)))))) (when (or (plusp temp-mask) (plusp extension-mask)) ;; Copy to temporary GC when field unknown or cache-p false (let ((display (gcontext-display gcontext))) (declare (type display display)) (with-display (display) (setq temp-gc (allocate-temp-gcontext)) (setf (gcontext-id temp-gc) (allocate-resource-id display gcontext 'gcontext) (gcontext-display temp-gc) display (gcontext-drawable temp-gc) (gcontext-drawable gcontext) (gcontext-server-state temp-gc) saved-state (gcontext-local-state temp-gc) saved-state) ;; Create a new (temporary) gcontext (with-buffer-request (display +x-creategc+) (gcontext temp-gc) (drawable (gcontext-drawable gcontext)) (card29 0)) ;; Copy changed components to the temporary gcontext (when (plusp temp-mask) (with-buffer-request (display +x-copygc+) (gcontext gcontext) (gcontext temp-gc) (card29 (xgcmask->gcmask temp-mask)))) ;; Copy extension fields to the new gcontext (when (plusp extension-mask) ;; Copy extension fields from temp back to gcontext (do ((bit (ash extension-mask (- *gcontext-data-length*)) (ash bit -1)) (i 0 (index+ i 1))) ((zerop bit)) (let ((copy-function (gcontext-extension-copy-function (elt *gcontext-extensions* i)))) (funcall copy-function gcontext temp-gc (svref local-state (index+ i *gcontext-data-length*)))))) ))) (values gcontext saved-state (logior temp-mask extension-mask) temp-gc)))) (defun restore-gcontext-temp-state (gcontext temp-mask temp-gc) (declare (type gcontext gcontext temp-gc) (type xgcmask temp-mask)) (let ((display (gcontext-display gcontext))) (declare (type display display)) (with-display (display) (with-buffer-request (display +x-copygc+) (gcontext temp-gc) (gcontext gcontext) (card29 (xgcmask->gcmask temp-mask))) ;; Copy extension fields from temp back to gcontext (do ((bit (ash temp-mask (- *gcontext-data-length*)) (ash bit -1)) (extensions *gcontext-extensions* (cdr extensions)) (i *gcontext-data-length* (index+ i 1)) (local-state (gcontext-local-state temp-gc))) ((zerop bit)) (let ((copy-function (gcontext-extension-copy-function (car extensions)))) (funcall copy-function temp-gc gcontext (svref local-state i)))) ;; free gcontext (with-buffer-request (display +x-freegc+) (gcontext temp-gc)) (deallocate-resource-id display (gcontext-id temp-gc) 'gcontext) (deallocate-temp-gcontext temp-gc) ;; Copy saved state back to server state (do ((server-state (gcontext-server-state gcontext)) (bit (xgcmask->gcmask temp-mask) (the gcmask (ash bit -1))) (i 0 (index+ i 1))) ((zerop bit) (incf-internal-timestamp server-state)) (declare (type gcontext-state server-state) (type gcmask bit) (type array-index i)) (when (oddp bit) (setf (svref server-state i) nil)))))) (defun create-gcontext (&rest options &key (drawable (required-arg drawable)) function plane-mask foreground background line-width line-style cap-style join-style fill-style fill-rule arc-mode tile stipple ts-x ts-y font subwindow-mode exposures clip-x clip-y clip-mask clip-ordering dash-offset dashes (cache-p t) &allow-other-keys) ;; Only non-nil components are passed on in the request, but for effective caching ;; assumptions have to be made about what the actual protocol defaults are. For ;; all gcontext components, a value of nil causes the default gcontext value to be ;; used. For clip-mask, this implies that an empty rect-seq cannot be represented ;; as a list. Note: use of stringable as font will cause an implicit open-font. ;; Note: papers over protocol SetClipRectangles and SetDashes special cases. If ;; cache-p is true, then gcontext state is cached locally, and changing a gcontext ;; component will have no effect unless the new value differs from the cached ;; value. Component changes (setfs and with-gcontext) are always deferred ;; regardless of the cache mode, and sent over the protocol only when required by a ;; local operation or by an explicit call to force-gcontext-changes. (declare (type drawable drawable) ; Required to be non-null (type (or null boole-constant) function) (type (or null pixel) plane-mask foreground background) (type (or null card16) line-width dash-offset) (type (or null int16) ts-x ts-y clip-x clip-y) (type (or null (member :solid :dash :double-dash)) line-style) (type (or null (member :not-last :butt :round :projecting)) cap-style) (type (or null (member :miter :round :bevel)) join-style) (type (or null (member :solid :tiled :opaque-stippled :stippled)) fill-style) (type (or null (member :even-odd :winding)) fill-rule) (type (or null (member :chord :pie-slice)) arc-mode) (type (or null pixmap) tile stipple) (type (or null fontable) font) (type (or null (member :clip-by-children :include-inferiors)) subwindow-mode) (type (or null (member :on :off)) exposures) (type (or null (member :none) pixmap rect-seq) clip-mask) (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering) (type (or null card8 sequence) dashes) (dynamic-extent options) (type generalized-boolean cache-p)) (declare (clx-values gcontext)) (let* ((display (drawable-display drawable)) (gcontext (make-gcontext :display display :drawable drawable :cache-p cache-p)) (local-state (gcontext-local-state gcontext)) (server-state (gcontext-server-state gcontext)) (gcontextid (allocate-resource-id display gcontext 'gcontext))) (declare (type display display) (type gcontext gcontext) (type resource-id gcontextid) (type gcontext-state local-state server-state)) (setf (gcontext-id gcontext) gcontextid) (unless function (setf (gcontext-function gcontext) boole-1)) ;; using the depth of the drawable would be better, but ... (unless plane-mask (setf (gcontext-plane-mask gcontext) #xffffffff)) (unless foreground (setf (gcontext-foreground gcontext) 0)) (unless background (setf (gcontext-background gcontext) 1)) (unless line-width (setf (gcontext-line-width gcontext) 0)) (unless line-style (setf (gcontext-line-style gcontext) :solid)) (unless cap-style (setf (gcontext-cap-style gcontext) :butt)) (unless join-style (setf (gcontext-join-style gcontext) :miter)) (unless fill-style (setf (gcontext-fill-style gcontext) :solid)) (unless fill-rule (setf (gcontext-fill-rule gcontext) :even-odd)) (unless arc-mode (setf (gcontext-arc-mode gcontext) :pie-slice)) (unless ts-x (setf (gcontext-ts-x gcontext) 0)) (unless ts-y (setf (gcontext-ts-y gcontext) 0)) (unless subwindow-mode (setf (gcontext-subwindow-mode gcontext) :clip-by-children)) (unless exposures (setf (gcontext-exposures gcontext) :on)) (unless clip-mask (setf (gcontext-clip-mask gcontext) :none)) (unless clip-x (setf (gcontext-clip-x gcontext) 0)) (unless clip-y (setf (gcontext-clip-y gcontext) 0)) (unless dashes (setf (gcontext-dashes gcontext) 4)) (unless dash-offset (setf (gcontext-dash-offset gcontext) 0)) ;; a bit kludgy, but ... (replace server-state local-state) (when function (setf (gcontext-function gcontext) function)) (when plane-mask (setf (gcontext-plane-mask gcontext) plane-mask)) (when foreground (setf (gcontext-foreground gcontext) foreground)) (when background (setf (gcontext-background gcontext) background)) (when line-width (setf (gcontext-line-width gcontext) line-width)) (when line-style (setf (gcontext-line-style gcontext) line-style)) (when cap-style (setf (gcontext-cap-style gcontext) cap-style)) (when join-style (setf (gcontext-join-style gcontext) join-style)) (when fill-style (setf (gcontext-fill-style gcontext) fill-style)) (when fill-rule (setf (gcontext-fill-rule gcontext) fill-rule)) (when arc-mode (setf (gcontext-arc-mode gcontext) arc-mode)) (when tile (setf (gcontext-tile gcontext) tile)) (when stipple (setf (gcontext-stipple gcontext) stipple)) (when ts-x (setf (gcontext-ts-x gcontext) ts-x)) (when ts-y (setf (gcontext-ts-y gcontext) ts-y)) (when font (setf (gcontext-font gcontext) font)) (when subwindow-mode (setf (gcontext-subwindow-mode gcontext) subwindow-mode)) (when exposures (setf (gcontext-exposures gcontext) exposures)) (when clip-x (setf (gcontext-clip-x gcontext) clip-x)) (when clip-y (setf (gcontext-clip-y gcontext) clip-y)) (when clip-mask (setf (gcontext-clip-mask gcontext clip-ordering) clip-mask)) (when dash-offset (setf (gcontext-dash-offset gcontext) dash-offset)) (when dashes (setf (gcontext-dashes gcontext) dashes)) (setf (gcontext-internal-timestamp server-state) 1) (setf (gcontext-internal-timestamp local-state) ;; SetClipRectangles or SetDashes request need to be sent? (if (or (gcontext-internal-clip local-state) (gcontext-internal-dash local-state)) ;; Yes, mark local state "modified" to ensure ;; force-gcontext-changes will occur. 0 ;; No, mark local state "unmodified" 1)) (with-buffer-request (display +x-creategc+) (resource-id gcontextid) (drawable drawable) (progn (do* ((i 0 (index+ i 1)) (bit 1 (the xgcmask (ash bit 1))) (nbyte 16) (mask 0) (local (svref local-state i) (svref local-state i))) ((index>= i +gcontext-fast-change-length+) (card29-put 12 mask) (card16-put 2 (index-ash nbyte -2)) (index-incf (buffer-boffset display) nbyte)) (declare (type array-index i nbyte) (type xgcmask bit) (type gcmask mask) (type (or null card32) local)) (unless (eql local (the (or null card32) (svref server-state i))) (setf (svref server-state i) local) (card32-put nbyte local) (setq mask (the gcmask (logior mask bit))) (index-incf nbyte 4))))) ;; Initialize extensions (do ((extensions *gcontext-extensions* (cdr extensions)) (i *gcontext-data-length* (index+ i 1))) ((endp extensions)) (declare (type list extensions) (type array-index i)) (setf (svref server-state i) (setf (svref local-state i) (gcontext-extension-default (car extensions))))) ;; Set extension values (do* ((option-list options (cddr option-list)) (option (car option-list) (car option-list)) (extension)) ((endp option-list)) (declare (type list option-list)) (cond ((getf *gcontext-indexes* option)) ; Gcontext field ((member option '(:drawable :clip-ordering :cache-p))) ; Optional parameter ((setq extension (find option *gcontext-extensions* :key #'gcontext-extension-name)) (funcall (gcontext-extension-set-function extension) gcontext (second option-list))) (t (x-type-error option 'gcontext-key)))) gcontext)) (defun copy-gcontext-components (src dst &rest keys) (declare (type gcontext src dst) (dynamic-extent keys)) ;; you might ask why this isn't just a bunch of ;; (setf (gcontext- dst) (gcontext- src)) ;; the answer is that you can do that yourself if you want, what we are ;; providing here is access to the protocol request, which will generally ;; be more efficient (particularly for things like clip and dash lists). (when keys (let ((display (gcontext-display src)) (mask 0)) (declare (type xgcmask mask)) (with-display (display) (force-gcontext-changes-internal src) (force-gcontext-changes-internal dst) ;; collect entire mask and handle extensions (dolist (key keys) (let ((i (getf *gcontext-indexes* key))) (declare (type (or null array-index) i)) (if i (setq mask (the xgcmask (logior mask (the xgcmask (svref *gcontext-masks* i))))) (let ((extension (find key *gcontext-extensions* :key #'gcontext-extension-name))) (if extension (funcall (gcontext-extension-copy-function extension) src dst (svref (gcontext-local-state src) (index+ (position extension *gcontext-extensions*) *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 (or symbol list) 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 (or function symbol) set-function) (type (or function symbol) 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*))) cl-clx-sbcl-0.7.4.20160323.orig/package.lisp0000644000175000017500000005212312715665272016111 0ustar pdmpdm;;; -*- 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. ;;; The CLtL way #-clx-ansi-common-lisp (lisp:in-package :xlib :use '(:lisp)) #+(and (or kcl ibcl) (not clx-ansi-common-lisp)) (shadow '( rational )) #+(and CMU (not clx-ansi-common-lisp)) (shadow '(define-condition)) #+(and lispm (not clx-ansi-common-lisp)) (import '( sys:arglist sys:with-stack-list sys:with-stack-list* )) #+(and Genera (not clx-ansi-common-lisp)) (import '( future-common-lisp:print-unreadable-object future-common-lisp:with-standard-io-syntax zwei:indentation )) #+(and lcl3.0 (not clx-ansi-common-lisp)) (import '( lcl:arglist lcl:dynamic-extent lcl:type-error lucid::type-error-datum lucid::type-error-expected-type )) #+(and excl (not clx-ansi-common-lisp)) (import '( excl::arglist excl::dynamic-extent excl::type-error excl::type-error-datum excl::type-error-expected-type )) #+(and allegro (not clx-ansi-common-lisp)) (import '( excl::without-interrupts )) #-clx-ansi-common-lisp (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-extended-max-request-length display-finish-output display-force-output display-host display-image-lsb-first-p display-invoke-after-function display-keycode-range display-max-keycode display-max-request-length display-min-keycode display-motion-buffer-size display-nscreens display-p display-pixmap-formats display-plist display-protocol-major-version display-protocol-minor-version display-protocol-version display-release-number display-report-asynchronous-errors display-resource-id-base display-resource-id-mask display-roots display-vendor display-vendor-name display-xdefaults display-xid draw-arc draw-arcs draw-direction draw-glyph draw-glyphs draw-image-glyph draw-image-glyphs draw-line draw-lines draw-point draw-points draw-rectangle draw-rectangles draw-segments drawable drawable-border-width drawable-depth drawable-display drawable-equal drawable-error drawable-height drawable-id drawable-p drawable-plist drawable-root drawable-width drawable-x drawable-y error-key event-case event-cond event-handler event-key event-listen event-mask event-mask-class extension-opcode find-atom font font-all-chars-exist-p font-ascent font-default-char font-descent font-direction font-display font-equal font-error font-id font-max-byte1 font-max-byte2 font-max-char font-min-byte1 font-min-byte2 font-min-char font-name font-p font-path font-plist font-properties font-property fontable force-gcontext-changes free-colormap free-colors free-cursor free-gcontext free-pixmap gcontext gcontext-arc-mode gcontext-background gcontext-cache-p gcontext-cap-style gcontext-clip-mask gcontext-clip-ordering gcontext-clip-x gcontext-clip-y gcontext-dash-offset gcontext-dashes gcontext-display gcontext-equal gcontext-error gcontext-exposures gcontext-fill-rule gcontext-fill-style gcontext-font gcontext-foreground gcontext-function gcontext-id gcontext-join-style gcontext-key gcontext-line-style gcontext-line-width gcontext-p gcontext-plane-mask gcontext-plist gcontext-stipple gcontext-subwindow-mode gcontext-tile gcontext-ts-x gcontext-ts-y generalized-boolean get-external-event-code get-image get-property get-raw-image get-resource get-search-resource get-search-table get-standard-colormap get-wm-class global-pointer-position grab-button grab-key grab-keyboard grab-pointer grab-server grab-status icon-sizes iconify-window id-choice-error illegal-request-error image image-blue-mask image-depth image-green-mask image-height image-name image-pixmap image-plist image-red-mask image-width image-x image-x-hot image-x-p image-xy image-xy-bitmap-list image-xy-p image-y-hot image-z image-z-bits-per-pixel image-z-p image-z-pixarray implementation-error input-focus install-colormap installed-colormaps int16 int32 int8 intern-atom invalid-font keyboard-control keyboard-mapping keycode->character keycode->keysym keysym keysym->character keysym->keycodes keysym-in-map-p keysym-set kill-client kill-temporary-clients length-error list-extensions list-font-names list-fonts list-properties lookup-color lookup-error make-color make-event-handlers make-event-keys make-event-mask make-resource-database make-state-keys make-state-mask make-wm-hints make-wm-size-hints map-resource map-subwindows map-window mapping-notify mask16 mask32 match-error max-char-ascent max-char-attributes max-char-descent max-char-left-bearing max-char-right-bearing max-char-width merge-resources min-char-ascent min-char-attributes min-char-descent min-char-left-bearing min-char-right-bearing min-char-width missing-parameter modifier-key modifier-mapping modifier-mask motion-events name-error no-operation open-display open-font pixarray pixel pixmap pixmap-display pixmap-equal pixmap-error pixmap-format pixmap-format-bits-per-pixel pixmap-format-depth pixmap-format-p pixmap-format-scanline-pad pixmap-id pixmap-p pixmap-plist point-seq pointer-control pointer-event-mask pointer-event-mask-class pointer-mapping pointer-position process-event put-image put-raw-image query-best-cursor query-best-stipple query-best-tile query-colors query-extension query-keymap query-pointer query-tree queue-event read-bitmap-file read-resources recolor-cursor rect-seq remove-access-host remove-from-save-set reparent-window repeat-seq reply-length-error reply-timeout request-error reset-screen-saver resource-database resource-database-timestamp resource-error resource-id resource-key rgb-colormaps rgb-val root-resources rotate-cut-buffers rotate-properties screen screen-backing-stores screen-black-pixel screen-default-colormap screen-depths screen-event-mask-at-open screen-height screen-height-in-millimeters screen-max-installed-maps screen-min-installed-maps screen-p screen-plist screen-root screen-root-depth screen-root-visual screen-root-visual-info screen-save-unders-p screen-saver screen-white-pixel screen-width screen-width-in-millimeters seg-seq selection-owner send-event sequence-error set-access-control set-close-down-mode set-input-focus set-modifier-mapping set-pointer-mapping set-screen-saver set-selection-owner set-standard-colormap set-standard-properties set-wm-class set-wm-properties set-wm-resources state-keysym-p state-mask-key store-color store-colors stringable text-extents text-width timestamp transient-for translate-coordinates translate-default translation-function type-error undefine-keysym unexpected-reply ungrab-button ungrab-key ungrab-keyboard ungrab-pointer ungrab-server uninstall-colormap unknown-error unmap-subwindows unmap-window value-error visual-info visual-info-bits-per-rgb visual-info-blue-mask visual-info-class visual-info-colormap-entries visual-info-display visual-info-green-mask visual-info-id visual-info-p visual-info-plist visual-info-red-mask warp-pointer warp-pointer-if-inside warp-pointer-relative warp-pointer-relative-if-inside win-gravity window window-all-event-masks window-background window-backing-pixel window-backing-planes window-backing-store window-bit-gravity window-border window-class window-colormap window-colormap-installed-p window-cursor window-display window-do-not-propagate-mask window-equal window-error window-event-mask window-gravity window-id window-map-state window-override-redirect window-p window-plist window-priority window-save-under window-visual window-visual-info with-display with-event-queue with-gcontext with-server-grabbed with-state withdraw-window wm-client-machine wm-colormap-windows wm-command wm-hints wm-hints-flags wm-hints-icon-mask wm-hints-icon-pixmap wm-hints-icon-window wm-hints-icon-x wm-hints-icon-y wm-hints-initial-state wm-hints-input wm-hints-p wm-hints-window-group wm-icon-name wm-name wm-normal-hints wm-protocols wm-resources wm-size-hints wm-size-hints-base-height wm-size-hints-base-width wm-size-hints-height wm-size-hints-height-inc wm-size-hints-max-aspect wm-size-hints-max-height wm-size-hints-max-width wm-size-hints-min-aspect wm-size-hints-min-height wm-size-hints-min-width wm-size-hints-p wm-size-hints-user-specified-position-p wm-size-hints-user-specified-size-p wm-size-hints-width wm-size-hints-width-inc wm-size-hints-win-gravity wm-size-hints-x wm-size-hints-y wm-zoom-hints write-bitmap-file write-resources xatom )) ;;; The ANSI Common Lisp way #+(and Genera clx-ansi-common-lisp) (eval-when (:compile-toplevel :load-toplevel :execute) (setf *readtable* si:*ansi-common-lisp-readtable*)) #+clx-ansi-common-lisp (common-lisp:in-package :common-lisp-user) #+clx-ansi-common-lisp (defpackage xlib (:use common-lisp) (:size 3000) #+(or kcl ibcl) (:shadow rational) #+allegro (:use cltl1) #+allegro (:import-from excl without-interrupts) #+excl (:import-from excl arglist) #+Genera (:import-from zwei indentation) #+lcl3.0 (:import-from lcl arglist) #+lispm (:import-from lisp char-bit) #+lispm (:import-from sys arglist with-stack-list with-stack-list*) #+sbcl (:use sb-bsd-sockets) (: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-extended-max-request-length display-finish-output display-force-output display-host display-image-lsb-first-p display-invoke-after-function display-keycode-range display-max-keycode display-max-request-length display-min-keycode display-motion-buffer-size display-nscreens display-p display-pixmap-formats display-plist display-protocol-major-version display-protocol-minor-version display-protocol-version display-release-number display-report-asynchronous-errors display-resource-id-base display-resource-id-mask display-roots display-vendor display-vendor-name display-xdefaults display-xid draw-arc draw-arcs draw-direction draw-glyph draw-glyphs draw-image-glyph draw-image-glyphs draw-line draw-lines draw-point draw-points draw-rectangle draw-rectangles draw-segments drawable drawable-border-width drawable-depth drawable-display drawable-equal drawable-error drawable-height drawable-id drawable-p drawable-plist drawable-root drawable-width drawable-x drawable-y error-key event-case event-cond event-handler event-key event-listen event-mask event-mask-class extension-opcode find-atom font font-all-chars-exist-p font-ascent font-default-char font-descent font-direction font-display font-equal font-error font-id font-max-byte1 font-max-byte2 font-max-char font-min-byte1 font-min-byte2 font-min-char font-name font-p font-path font-plist font-properties font-property fontable force-gcontext-changes free-colormap free-colors free-cursor free-gcontext free-pixmap gcontext gcontext-arc-mode gcontext-background gcontext-cache-p gcontext-cap-style gcontext-clip-mask gcontext-clip-ordering gcontext-clip-x gcontext-clip-y gcontext-dash-offset gcontext-dashes gcontext-display gcontext-equal gcontext-error gcontext-exposures gcontext-fill-rule gcontext-fill-style gcontext-font gcontext-foreground gcontext-function gcontext-id gcontext-join-style gcontext-key gcontext-line-style gcontext-line-width gcontext-p gcontext-plane-mask gcontext-plist gcontext-stipple gcontext-subwindow-mode gcontext-tile gcontext-ts-x gcontext-ts-y generalized-boolean get-external-event-code get-image get-property get-raw-image get-resource get-search-resource get-search-table get-standard-colormap get-wm-class global-pointer-position grab-button grab-key grab-keyboard grab-pointer grab-server grab-status icon-sizes iconify-window id-choice-error illegal-request-error image image-blue-mask image-depth image-green-mask image-height image-name image-pixmap image-plist image-red-mask image-width image-x image-x-hot image-x-p image-xy image-xy-bitmap-list image-xy-p image-y-hot image-z image-z-bits-per-pixel image-z-p image-z-pixarray implementation-error input-focus install-colormap installed-colormaps int16 int32 int8 intern-atom invalid-font keyboard-control keyboard-mapping keycode->character keycode->keysym keysym keysym->character keysym->keycodes keysym-in-map-p keysym-set kill-client kill-temporary-clients length-error list-extensions list-font-names list-fonts list-properties lookup-color lookup-error make-color make-event-handlers make-event-keys make-event-mask make-resource-database make-state-keys make-state-mask make-wm-hints make-wm-size-hints map-resource map-subwindows map-window mapping-notify mask16 mask32 match-error max-char-ascent max-char-attributes max-char-descent max-char-left-bearing max-char-right-bearing max-char-width merge-resources min-char-ascent min-char-attributes min-char-descent min-char-left-bearing min-char-right-bearing min-char-width missing-parameter modifier-key modifier-mapping modifier-mask motion-events name-error no-operation open-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)) cl-clx-sbcl-0.7.4.20160323.orig/socket.c0000644000175000017500000001042212715665272015255 0ustar pdmpdm/* Copyright Massachusetts Institute of Technology 1988 */ /* * THIS IS AN OS DEPENDENT FILE! It should work on 4.2BSD derived * systems. VMS and System V should plan to have their own version. * * This code was cribbed from lib/X/XConnDis.c. * Compile using * % cc -c socket.c -DUNIXCONN */ #include #include #include #include #include #include #include #include #ifndef hpux #include #endif extern int errno; /* Certain (broken) OS's don't have this */ /* decl in errno.h */ #ifdef UNIXCONN #include #ifndef X_UNIX_PATH #ifdef hpux #define X_UNIX_PATH "/usr/spool/sockets/X11/" #define OLD_UNIX_PATH "/tmp/.X11-unix/X" #else /* hpux */ #define X_UNIX_PATH "/tmp/.X11-unix/X" #endif /* hpux */ #endif /* X_UNIX_PATH */ #endif /* UNIXCONN */ #ifndef hpux void bcopy(); #endif /* hpux */ /* * Attempts to connect to server, given host and display. Returns file * descriptor (network socket) or 0 if connection fails. */ int connect_to_server (host, display) char *host; int display; { struct sockaddr_in inaddr; /* INET socket address. */ struct sockaddr *addr; /* address to connect to */ struct hostent *host_ptr; int addrlen; /* length of address */ #ifdef UNIXCONN struct sockaddr_un unaddr; /* UNIX socket address. */ #endif extern char *getenv(); extern struct hostent *gethostbyname(); int fd; /* Network socket */ { #ifdef UNIXCONN if ((host[0] == '\0') || (strcmp("unix", host) == 0)) { /* Connect locally using Unix domain. */ unaddr.sun_family = AF_UNIX; (void) strcpy(unaddr.sun_path, X_UNIX_PATH); (void) sprintf(&unaddr.sun_path[strlen(unaddr.sun_path)], "%d", display); addr = (struct sockaddr *) &unaddr; addrlen = strlen(unaddr.sun_path) + 2; /* * Open the network connection. */ if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0) { #ifdef hpux /* this is disgusting */ /* cribbed from X11R4 xlib source */ if (errno == ENOENT) { /* No such file or directory */ (void) sprintf(unaddr.sun_path, "%s%d", OLD_UNIX_PATH, display); addrlen = strlen(unaddr.sun_path) + 2; if ((fd = socket ((int) addr->sa_family, SOCK_STREAM, 0)) < 0) return(-1); /* errno set by most recent system call. */ } else #endif /* hpux */ return(-1); /* errno set by system call. */ } } else #endif /* UNIXCONN */ { /* Get the statistics on the specified host. */ if ((inaddr.sin_addr.s_addr = inet_addr(host)) == -1) { if ((host_ptr = gethostbyname(host)) == NULL) { /* No such host! */ errno = EINVAL; return(-1); } /* Check the address type for an internet host. */ if (host_ptr->h_addrtype != AF_INET) { /* Not an Internet host! */ errno = EPROTOTYPE; return(-1); } /* Set up the socket data. */ inaddr.sin_family = host_ptr->h_addrtype; #ifdef hpux (void) memcpy((char *)&inaddr.sin_addr, (char *)host_ptr->h_addr, sizeof(inaddr.sin_addr)); #else /* hpux */ (void) bcopy((char *)host_ptr->h_addr, (char *)&inaddr.sin_addr, sizeof(inaddr.sin_addr)); #endif /* hpux */ } else { inaddr.sin_family = AF_INET; } addr = (struct sockaddr *) &inaddr; addrlen = sizeof (struct sockaddr_in); inaddr.sin_port = display + X_TCP_PORT; inaddr.sin_port = htons(inaddr.sin_port); /* * Open the network connection. */ if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0){ return(-1); /* errno set by system call. */} /* make sure to turn off TCP coalescence */ #ifdef TCP_NODELAY { int mi = 1; setsockopt (fd, IPPROTO_TCP, TCP_NODELAY, &mi, sizeof (int)); } #endif } /* * Changed 9/89 to retry connection if system call was interrupted. This * is necessary for multiprocessing implementations that use timers, * since the timer results in a SIGALRM. -- jdi */ while (connect(fd, addr, addrlen) == -1) { if (errno != EINTR) { (void) close (fd); return(-1); /* errno set by system call. */ } } } /* * Return the id if the connection succeeded. */ return(fd); } cl-clx-sbcl-0.7.4.20160323.orig/dep-allegro.lisp0000644000175000017500000022775012715665272016723 0ustar pdmpdm;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- ;; This file contains some of the system dependent code for CLX ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (in-package :xlib) (proclaim '(declaration array-register)) ;;; The size of the output buffer. Must be a multiple of 4. (defparameter *output-buffer-size* 8192) ;;; Number of seconds to wait for a reply to a server request (defparameter *reply-timeout* nil) #-(or clx-overlapping-arrays (not clx-little-endian)) (progn (defconstant +word-0+ 0) (defconstant +word-1+ 1) (defconstant +long-0+ 0) (defconstant +long-1+ 1) (defconstant +long-2+ 2) (defconstant +long-3+ 3)) #-(or clx-overlapping-arrays clx-little-endian) (progn (defconstant +word-0+ 1) (defconstant +word-1+ 0) (defconstant +long-0+ 3) (defconstant +long-1+ 2) (defconstant +long-2+ 1) (defconstant +long-3+ 0)) ;;; Set some compiler-options for often used code (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +buffer-speed+ #+clx-debugging 1 #-clx-debugging 3 "Speed compiler option for buffer code.") (defconstant +buffer-safety+ #+clx-debugging 3 #-clx-debugging 0 "Safety compiler option for buffer code.") (defconstant +buffer-debug+ #+clx-debugging 2 #-clx-debugging 1 "Debug compiler option for buffer code>") (defun declare-bufmac () `(declare (optimize (speed ,+buffer-speed+) (safety ,+buffer-safety+) (debug ,+buffer-debug+)))) ;; It's my impression that in lucid there's some way to make a ;; declaration called fast-entry or something that causes a function ;; to not do some checking on args. Sadly, we have no lucid manuals ;; here. If such a declaration is available, it would be a good ;; idea to make it here when +buffer-speed+ is 3 and +buffer-safety+ ;; is 0. (defun declare-buffun () `(declare (optimize (speed ,+buffer-speed+) (safety ,+buffer-safety+) (debug ,+buffer-debug+))))) (declaim (inline card8->int8 int8->card8 card16->int16 int16->card16 card32->int32 int32->card32)) #-Genera (progn (defun card8->int8 (x) (declare (type card8 x)) (declare (clx-values int8)) #.(declare-buffun) (the int8 (if (logbitp 7 x) (the int8 (- x #x100)) x))) (defun int8->card8 (x) (declare (type int8 x)) (declare (clx-values card8)) #.(declare-buffun) (the card8 (ldb (byte 8 0) x))) (defun card16->int16 (x) (declare (type card16 x)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (if (logbitp 15 x) (the int16 (- x #x10000)) x))) (defun int16->card16 (x) (declare (type int16 x)) (declare (clx-values card16)) #.(declare-buffun) (the card16 (ldb (byte 16 0) x))) (defun card32->int32 (x) (declare (type card32 x)) (declare (clx-values int32)) #.(declare-buffun) (the int32 (if (logbitp 31 x) (the int32 (- x #x100000000)) x))) (defun int32->card32 (x) (declare (type int32 x)) (declare (clx-values card32)) #.(declare-buffun) (the card32 (ldb (byte 32 0) x))) ) (declaim (inline aref-card8 aset-card8 aref-int8 aset-int8)) #+(or excl lcl3.0 clx-overlapping-arrays) (declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29 aset-card16 aset-int16 aset-card32 aset-int32 aset-card29)) #+(and clx-overlapping-arrays (not Genera)) (progn (defun aref-card16 (a i) (aref a i)) (defun aset-card16 (v a i) (setf (aref a i) v)) (defun aref-int16 (a i) (card16->int16 (aref a i))) (defun aset-int16 (v a i) (setf (aref a i) (int16->card16 v)) v) (defun aref-card32 (a i) (aref a i)) (defun aset-card32 (v a i) (setf (aref a i) v)) (defun aref-int32 (a i) (card32->int32 (aref a i))) (defun aset-int32 (v a i) (setf (aref a i) (int32->card32 v)) v) (defun aref-card29 (a i) (aref a i)) (defun aset-card29 (v a i) (setf (aref a i) v)) ) #+excl (progn (defun aref-card8 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card8)) #.(declare-buffun) (the card8 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :unsigned-byte))) (defun aset-card8 (v a i) (declare (type card8 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :unsigned-byte) v)) (defun aref-int8 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int8)) #.(declare-buffun) (the int8 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :signed-byte))) (defun aset-int8 (v a i) (declare (type int8 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :signed-byte) v)) (defun aref-card16 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card16)) #.(declare-buffun) (the card16 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :unsigned-word))) (defun aset-card16 (v a i) (declare (type card16 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :unsigned-word) v)) (defun aref-int16 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :signed-word))) (defun aset-int16 (v a i) (declare (type int16 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :signed-word) v)) (defun aref-card32 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card32)) #.(declare-buffun) (the card32 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :unsigned-long))) (defun aset-card32 (v a i) (declare (type card32 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :unsigned-long) v)) (defun aref-int32 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int32)) #.(declare-buffun) (the int32 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :signed-long))) (defun aset-int32 (v a i) (declare (type int32 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :signed-long) v)) (defun aref-card29 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card29)) #.(declare-buffun) (the card29 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :unsigned-long))) (defun aset-card29 (v a i) (declare (type card29 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :unsigned-long) v)) ) (defsetf aref-card8 (a i) (v) `(aset-card8 ,v ,a ,i)) (defsetf aref-int8 (a i) (v) `(aset-int8 ,v ,a ,i)) (defsetf aref-card16 (a i) (v) `(aset-card16 ,v ,a ,i)) (defsetf aref-int16 (a i) (v) `(aset-int16 ,v ,a ,i)) (defsetf aref-card32 (a i) (v) `(aset-card32 ,v ,a ,i)) (defsetf aref-int32 (a i) (v) `(aset-int32 ,v ,a ,i)) (defsetf aref-card29 (a i) (v) `(aset-card29 ,v ,a ,i)) ;;; Other random conversions (defun rgb-val->card16 (value) ;; Short floats are good enough (declare (type rgb-val value)) (declare (clx-values card16)) #.(declare-buffun) ;; Convert VALUE from float to card16 (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff))))) (defun card16->rgb-val (value) ;; Short floats are good enough (declare (type card16 value)) (declare (clx-values short-float)) #.(declare-buffun) ;; Convert VALUE from card16 to float (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff)))) (defun radians->int16 (value) ;; Short floats are good enough (declare (type angle value)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0))))) (defun int16->radians (value) ;; Short floats are good enough (declare (type int16 value)) (declare (clx-values short-float)) #.(declare-buffun) (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float)))) #+(or cmu sbcl) (progn ;;; 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 protocol 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)))) ) ;;----------------------------------------------------------------------------- ;; Character transformation ;;----------------------------------------------------------------------------- ;;; This stuff transforms chars to ascii codes in card8's and back. ;;; You might have to hack it a little to get it to work for your machine. (declaim (inline char->card8 card8->char)) (macrolet ((char-translators () (let ((alist `(#-lispm ;; The normal ascii codes for the control characters. ,@`((#\Return . 13) (#\Linefeed . 10) (#\Rubout . 127) (#\Page . 12) (#\Tab . 9) (#\Backspace . 8) (#\Newline . 10) (#\Space . 32)) ;; One the lispm, #\Newline is #\Return, but we'd really like ;; #\Newline to translate to ascii code 10, so we swap the ;; Ascii codes for #\Return and #\Linefeed. We also provide ;; mappings from the counterparts of these control characters ;; so that the character mapping from the lisp machine ;; character set to ascii is invertible. #+lispm ,@`((#\Return . 10) (,(code-char 10) . ,(char-code #\Return)) (#\Linefeed . 13) (,(code-char 13) . ,(char-code #\Linefeed)) (#\Rubout . 127) (,(code-char 127) . ,(char-code #\Rubout)) (#\Page . 12) (,(code-char 12) . ,(char-code #\Page)) (#\Tab . 9) (,(code-char 9) . ,(char-code #\Tab)) (#\Backspace . 8) (,(code-char 8) . ,(char-code #\Backspace)) (#\Newline . 10) (,(code-char 10) . ,(char-code #\Newline)) (#\Space . 32) (,(code-char 32) . ,(char-code #\Space))) ;; The rest of the common lisp charater set with the normal ;; ascii codes for them. (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) (#\} . 125) (#\~ . 126)))) (cond ((dolist (pair alist nil) (when (not (= (char-code (car pair)) (cdr pair))) (return t))) `(progn (defconstant *char-to-card8-translation-table* ',(let ((array (make-array (let ((max-char-code 255)) (dolist (pair alist) (setq max-char-code (max max-char-code (char-code (car pair))))) (1+ max-char-code)) :element-type 'card8))) (dotimes (i (length array)) (setf (aref array i) (mod i 256))) (dolist (pair alist) (setf (aref array (char-code (car pair))) (cdr pair))) array)) (defconstant *card8-to-char-translation-table* ',(let ((array (make-array 256))) (dotimes (i (length array)) (setf (aref array i) (code-char i))) (dolist (pair alist) (setf (aref array (cdr pair)) (car pair))) array)) #-Genera (progn (defun char->card8 (char) (declare (type base-char char)) #.(declare-buffun) (the card8 (aref (the (simple-array card8 (*)) *char-to-card8-translation-table*) (the array-index (char-code char))))) (defun card8->char (card8) (declare (type card8 card8)) #.(declare-buffun) (the base-char (or (aref (the simple-vector *card8-to-char-translation-table*) card8) (error "Invalid CHAR code ~D." card8)))) ) #+Genera (progn (defun char->card8 (char) (declare lt:(side-effects reader reducible)) (aref *char-to-card8-translation-table* (char-code char))) (defun card8->char (card8) (declare lt:(side-effects reader reducible)) (aref *card8-to-char-translation-table* card8)) ) #-Minima (dotimes (i 256) (unless (= i (char->card8 (card8->char i))) (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" (list i (card8->char i) (char->card8 (card8->char i)))) (return nil))) #-Minima (dotimes (i (length *char-to-card8-translation-table*)) (let ((char (code-char i))) (unless (eql char (card8->char (char->card8 char))) (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S" (list char (char->card8 char) (card8->char (char->card8 char)))) (return nil)))))) (t `(progn (defun char->card8 (char) (declare (type base-char char)) #.(declare-buffun) (the card8 (char-code char))) (defun card8->char (card8) (declare (type card8 card8)) #.(declare-buffun) (the base-char (code-char card8))) )))))) (char-translators)) ;;----------------------------------------------------------------------------- ;; Process Locking ;; ;; Common-Lisp doesn't provide process locking primitives, so we define ;; our own here, based on Zetalisp primitives. Holding-Lock is very ;; similar to with-lock on The TI Explorer, and a little more efficient ;; than with-process-lock on a Symbolics. ;;----------------------------------------------------------------------------- ;;; MAKE-PROCESS-LOCK: Creating a process lock. #+excl (defun make-process-lock (name) (mp:make-process-lock :name name)) ;;; HOLDING-LOCK: Execute a body of code with a lock held. ;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN ;;; passes its timeout to the holding-lock macro, so any timeout you want to ;;; work for event-listen you should do for holding-lock. ;; If you're not sharing DISPLAY objects within a multi-processing ;; shared-memory environment, this is sufficient ;;; HOLDING-LOCK for CMU Common Lisp. ;;; ;;; We are not multi-processing, but we use this macro to try to protect ;;; against re-entering request functions. This can happen if an interrupt ;;; occurs and the handler attempts to use X over the same display connection. ;;; This can happen if the GC hooks are used to notify the user over the same ;;; display connection. We inhibit GC notifications since display of them ;;; could cause recursive entry into CLX. ;;; ;;; HOLDING-LOCK for CMU Common Lisp with multi-processes. ;;; #+excl (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) (declare (ignore display)) `(let (.hl-lock. .hl-obtained-lock. .hl-curproc.) (unwind-protect (block .hl-doit. (when (sys:scheduler-running-p) ; fast test for scheduler running (setq .hl-lock. ,locator .hl-curproc. mp::*current-process*) (when (and .hl-curproc. ; nil if in process-wait fun (not (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.))) ;; Then we need to grab the lock. ,(if timeout `(if (not (mp::process-lock .hl-lock. .hl-curproc. ,whostate ,timeout)) (return-from .hl-doit. nil)) `(mp::process-lock .hl-lock. .hl-curproc. ,@(when whostate `(,whostate)))) ;; There is an apparent race condition here. However, there is ;; no actual race condition -- our implementation of mp:process- ;; lock guarantees that the lock will still be held when it ;; returns, and no interrupt can happen between that and the ;; execution of the next form. -- jdi 2/27/91 (setq .hl-obtained-lock. t))) ,@body) (if (and .hl-obtained-lock. ;; Note -- next form added to allow error handler inside ;; body to unlock the lock prematurely if it knows that ;; the current process cannot possibly continue but will ;; throw out (or is it throw up?). (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.)) (mp::process-unlock .hl-lock. .hl-curproc.))))) ;;; WITHOUT-ABORTS ;;; If you can inhibit asynchronous keyboard aborts inside the body of this ;;; macro, then it is a good idea to do this. This macro is wrapped around ;;; request writing and reply reading to ensure that requests are atomically ;;; written and replies are atomically read from the stream. #+excl (defmacro without-aborts (&body body) `(without-interrupts ,@body)) ;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value. ;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's ;;; value changes. #+excl (defun process-block (whostate predicate &rest predicate-args) (if (sys:scheduler-running-p) (apply #'mp::process-wait whostate predicate predicate-args) (or (apply predicate predicate-args) (error "Program tried to wait with no scheduler.")))) ;;; PROCESS-WAKEUP: Check some other process' wait function. (declaim (inline process-wakeup)) #+excl (defun process-wakeup (process) (let ((curproc mp::*current-process*)) (when (and curproc process) (unless (mp::process-p curproc) (error "~s is not a process" curproc)) (unless (mp::process-p process) (error "~s is not a process" process)) (if (> (mp::process-priority process) (mp::process-priority curproc)) (mp::process-allow-schedule process))))) ;;; CURRENT-PROCESS: Return the current process object for input locking and ;;; for calling PROCESS-WAKEUP. (declaim (inline current-process)) ;;; Default return NIL, which is acceptable even if there is a scheduler. #+excl (defun current-process () (and (sys:scheduler-running-p) mp::*current-process*)) ;;; WITHOUT-INTERRUPTS -- provide for atomic operations. ;;; CONDITIONAL-STORE: ;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times. ;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD. #-sbcl (defmacro conditional-store (place old-value new-value) `(without-interrupts (cond ((eq ,place ,old-value) (setf ,place ,new-value) t)))) ;;;---------------------------------------------------------------------------- ;;; IO Error Recovery ;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro. ;;; It prevents multiple mindless errors when the network craters. ;;; ;;;---------------------------------------------------------------------------- #-Genera (defmacro wrap-buf-output ((buffer) &body body) ;; Error recovery wrapper `(unless (buffer-dead ,buffer) ,@body)) #-Genera (defmacro wrap-buf-input ((buffer) &body body) (declare (ignore buffer)) ;; Error recovery wrapper `(progn ,@body)) ;;;---------------------------------------------------------------------------- ;;; System dependent IO primitives ;;; Functions for opening, reading writing forcing-output and closing ;;; the stream to the server. ;;;---------------------------------------------------------------------------- ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X ;;; server ;; ;; Note that since we don't use the CL i/o facilities to do i/o, the display ;; input and output "stream" is really a file descriptor (fixnum). ;; #+excl (defun open-x-stream (host display protocol) (declare (ignore protocol)) ;; assume TCP (let ((stream (socket:make-socket :remote-host (string host) :remote-port (+ *x-tcp-port* display) :format :binary))) (if (streamp stream) stream (error "Cannot connect to server: ~A:~D" host display)))) ;;; BUFFER-READ-DEFAULT - read data from the X stream ;; ;; Rewritten 10/89 to not use foreign function interface to do I/O. ;; #+excl (defun buffer-read-default (display vector start end timeout) (declare (type display display) (type buffer-bytes vector) (type array-index start end) (type (or null (real 0 *)) timeout)) #.(declare-buffun) (let* ((howmany (- end start)) (fd (display-input-stream display))) (declare (type array-index howmany)) (or (cond ((fd-char-avail-p fd) nil) ((and timeout (= timeout 0)) :timeout) ((buffer-input-wait-default display timeout))) (fd-read-bytes fd vector start howmany)))) ;;; WARNING: ;;; CLX performance will suffer if your lisp uses read-byte for ;;; receiving all data from the X Window System server. ;;; You are encouraged to write a specialized version of ;;; buffer-read-default that does block transfers. ;;; BUFFER-WRITE-DEFAULT - write data to the X stream #+excl (defun buffer-write-default (vector display start end) (declare (type buffer-bytes vector) (type display display) (type array-index start end)) #.(declare-buffun) (let ((stream (display-output-stream display))) (unless (null stream) (write-sequence vector stream :start start :end end))) ) ;;; WARNING: ;;; CLX performance will be severely degraded if your lisp uses ;;; write-byte to send all data to the X Window System server. ;;; You are STRONGLY encouraged to write a specialized version ;;; of buffer-write-default that does block transfers. ;;; buffer-force-output-default - force output to the X stream #+excl (defun buffer-force-output-default (display) ;; The default buffer force-output function for use with common-lisp streams (declare (type display display)) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (force-output stream)))) ;;; BUFFER-CLOSE-DEFAULT - close the X stream #+excl (defun buffer-close-default (display &key abort) ;; The default buffer close function for use with common-lisp streams (declare (type display display)) #.(declare-buffun) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (close stream :abort abort)))) ;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the ;;; buffer. This is called in read-input between requests, so that a process ;;; waiting for input is abortable when between requests. Should return ;;; :TIMEOUT if it times out, NIL otherwise. ;;; The default implementation ;; ;; This is used so an 'eq' test may be used to find out whether or not we can ;; safely throw this process out of the CLX read loop. ;; #+excl (defparameter *read-whostate* "waiting for input from X server") ;; ;; Note that this function returns nil on error if the scheduler is running, ;; t on error if not. This is ok since buffer-read will detect the error. ;; #+excl (defun buffer-input-wait-default (display timeout) (declare (type display display) (type (or null (real 0 *)) timeout)) (declare (clx-values timeout)) (let ((fd (display-input-stream display))) (when (streamp fd) (cond ((fd-char-avail-p fd) nil) ;; Otherwise no bytes were available on the socket ((and timeout (= timeout 0)) ;; If there aren't enough and timeout == 0, timeout. :timeout) ;; If the scheduler is running let it do timeouts. ((sys:scheduler-running-p) (if (not (mp:wait-for-input-available fd :whostate *read-whostate* :wait-function #'fd-char-avail-p :timeout timeout)) (return-from buffer-input-wait-default :timeout)) ) ;; Otherwise we have to handle timeouts by hand, and call select() ;; to block until input is available. Note we don't really handle ;; the interaction of interrupts and (numberp timeout) here. XX (t #+mswindows (error "scheduler must be running to use CLX on MS Windows") #-mswindows (let ((res 0)) (declare (fixnum res)) (with-interrupt-checking-on (loop (setq res (fd-wait-for-input fd (if (null timeout) 0 (truncate timeout)))) (cond ((plusp res) ; success (return nil)) ((eq res 0) ; timeout (return :timeout)) ((eq res -1) ; error (return t)) ;; Otherwise we got an interrupt -- go around again. ))))))))) ;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the ;;; buffer. This should never block, so it can be called from the scheduler. ;;; The default implementation is to just use listen. #+excl #+(and excl clx-use-allegro-streams) (defun buffer-listen-default (display) (declare (type display display)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (if (null stream) t (listen stream)))) #+(and excl (not clx-use-allegro-streams)) (defun buffer-listen-default (display) (declare (type display display)) (let ((fd (display-input-stream display))) (declare (type fixnum fd)) (if (= fd -1) t (fd-char-avail-p fd)))) ;;;---------------------------------------------------------------------------- ;;; System dependent speed hacks ;;;---------------------------------------------------------------------------- ;; ;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature. ;; If your lisp doesn't have stack-lists, and you're worried about ;; consing garbage, you may want to re-write this to allocate and ;; initialize lists from a resource. ;; #-lispm (defmacro with-stack-list ((var &rest elements) &body body) ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body) ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body) ;; except that the list produced by MAPCAR resides on the stack and ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list ,@elements))) (declare (type cons ,var) #+clx-ansi-common-lisp (dynamic-extent ,var)) ,@body)) #-lispm (defmacro with-stack-list* ((var &rest elements) &body body) ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body) ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body) ;; except that the list produced by MAPCAR resides on the stack and ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list* ,@elements))) (declare (type cons ,var) #+clx-ansi-common-lisp (dynamic-extent ,var)) ,@body)) (declaim (inline buffer-replace)) #+excl (defun buffer-replace (target-sequence source-sequence target-start target-end &optional (source-start 0)) (declare (type buffer-bytes target-sequence source-sequence) (type array-index target-start target-end source-start) (optimize (speed 3) (safety 0))) (let ((source-end (length source-sequence))) (declare (type array-index source-end)) (excl:if* (and (eq target-sequence source-sequence) (> target-start source-start)) then (let ((nelts (min (- target-end target-start) (- source-end source-start)))) (do ((target-index (+ target-start nelts -1) (1- target-index)) (source-index (+ source-start nelts -1) (1- source-index))) ((= target-index (1- target-start)) target-sequence) (declare (type array-index target-index source-index)) (setf (aref target-sequence target-index) (aref source-sequence source-index)))) else (do ((target-index target-start (1+ target-index)) (source-index source-start (1+ source-index))) ((or (= target-index target-end) (= source-index source-end)) target-sequence) (declare (type array-index target-index source-index)) (setf (aref target-sequence target-index) (aref source-sequence source-index)))))) #-lispm (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) &body body) (let ((local-state (gensym)) (resets nil)) (dolist (index indexes) (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index)) resets)) `(unwind-protect (progn ,@body) (let ((,local-state (gcontext-local-state ,gc))) (declare (type gcontext-state ,local-state)) ,@resets (setf (svref ,local-state ,ts-index) 0)) (when ,temp-gc (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) (deallocate-gcontext-state ,saved-state)))) ;;;---------------------------------------------------------------------------- ;;; How much error detection should CLX do? ;;; Several levels are possible: ;;; ;;; 1. Do the equivalent of check-type on every argument. ;;; ;;; 2. Simply report TYPE-ERROR. This eliminates overhead of all the format ;;; strings generated by check-type. ;;; ;;; 3. Do error checking only on arguments that are likely to have errors ;;; (like keyword names) ;;; ;;; 4. Do error checking only where not doing so may dammage the envirnment ;;; on a non-tagged machine (i.e. when storing into a structure that has ;;; been passed in) ;;; ;;; 5. No extra error detection code. On lispm's, ASET may barf trying to ;;; store a non-integer into a number array. ;;; ;;; How extensive should the error checking be? For example, if the server ;;; expects a CARD16, is is sufficient for CLX to check for integer, or ;;; should it also check for non-negative and less than 65536? ;;;---------------------------------------------------------------------------- ;; The +TYPE-CHECK?+ constant controls how much error checking is done. ;; Possible values are: ;; NIL - Don't do any error checking ;; t - Do the equivalent of checktype on every argument ;; :minimal - Do error checking only where errors are likely ;;; This controls macro expansion, and isn't changable at run-time You will ;;; probably want to set this to nil if you want good performance at ;;; production time. (defconstant +type-check?+ #+(or Genera Minima CMU sbcl) nil #-(or Genera Minima CMU sbcl) t) ;; TYPE? is used to allow the code to do error checking at a different level from ;; the declarations. It also does some optimizations for systems that don't have ;; good compiler support for TYPEP. The definitions for CARD32, CARD16, INT16, etc. ;; include range checks. You can modify TYPE? to do less extensive checking ;; for these types if you desire. ;; ;; ### This comment is a lie! TYPE? is really also used for run-time type ;; dispatching, not just type checking. -- Ram. (defmacro type? (object type) #+(or cmu sbcl) `(typep ,object ,type) #-(or cmu sbcl) (if (not (constantp type)) `(typep ,object ,type) (progn (setq type (eval type)) #+(or Genera explorer Minima) (if +type-check?+ `(locally (declare (optimize safety)) (typep ,object ',type)) `(typep ,object ',type)) #-(or Genera explorer Minima) (let ((predicate (assoc type '((drawable drawable-p) (window window-p) (pixmap pixmap-p) (cursor cursor-p) (font font-p) (gcontext gcontext-p) (colormap colormap-p) (null null) (integer integerp))))) (cond (predicate `(,(second predicate) ,object)) ((eq type 'generalized-boolean) 't) ; Everything is a generalized-boolean. (+type-check?+ `(locally (declare (optimize safety)) (typep ,object ',type))) (t `(typep ,object ',type))))))) ;; X-TYPE-ERROR is the function called for type errors. ;; If you want lots of checking, but are concerned about code size, ;; this can be made into a macro that ignores some parameters. (defun x-type-error (object type &optional error-string) (x-error 'x-type-error :datum object :expected-type type :type-string error-string)) ;;----------------------------------------------------------------------------- ;; Error handlers ;; Hack up KMP error signaling using zetalisp until the real thing comes ;; along ;;----------------------------------------------------------------------------- (defun default-error-handler (display error-key &rest key-vals &key asynchronous &allow-other-keys) (declare (type generalized-boolean asynchronous) (dynamic-extent key-vals)) ;; The default display-error-handler. ;; It signals the conditions listed in the DISPLAY file. (if asynchronous (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals) (apply #'x-error error-key :display display :error-key error-key key-vals))) #+(or clx-ansi-common-lisp excl lcl3.0 (and CMU mp)) (defun x-error (condition &rest keyargs) (declare (dynamic-extent keyargs)) (apply #'error condition keyargs)) #+(or clx-ansi-common-lisp excl lcl3.0 CMU) (defun x-cerror (proceed-format-string condition &rest keyargs) (declare (dynamic-extent keyargs)) (apply #'cerror proceed-format-string condition keyargs)) ;;; X-ERROR for CMU Common Lisp ;;; ;;; We detect a couple condition types for which we disable event handling in ;;; our system. This prevents going into the debugger or returning to a ;;; command prompt with CLX repeatedly seeing the same condition. This occurs ;;; because CMU Common Lisp provides for all events (that is, X, input on file ;;; descriptors, Mach messages, etc.) to come through one routine anyone can ;;; use to wait for input. ;;; #+(and CMU (not mp)) (defun x-error (condition &rest keyargs) (let ((condx (apply #'make-condition condition keyargs))) (when (eq condition 'closed-display) (let ((disp (closed-display-display condx))) (warn "Disabled event handling on ~S." disp) (ext::disable-clx-event-handling disp))) (error condx))) #-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl) (defun x-error (condition &rest keyargs) (error "X-Error: ~a" (princ-to-string (apply #'make-condition condition keyargs)))) #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl) (defun x-cerror (proceed-format-string condition &rest keyargs) (cerror proceed-format-string "X-Error: ~a" (princ-to-string (apply #'make-condition condition keyargs)))) ;; version 15 of Pitman error handling defines the syntax for define-condition to be: ;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*] ;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string) ;; or (:report exp) #+(and excl (not clx-ansi-common-lisp)) (defmacro define-condition (name parent-types &optional slots &rest args) `(excl::define-condition ,name (,(first parent-types)) ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) slots) ,@args)) #+(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl) (define-condition x-error (error) ()) ;;----------------------------------------------------------------------------- ;; HOST hacking ;;----------------------------------------------------------------------------- #+(and allegro-version>= (version>= 5 0)) (eval-when (compile eval load) #+(version>= 6 0) (progn (require :sock) #-(version>= 7 0) (require :gray-compat)) #-(version>= 6 0) (require :sock)) #+(and allegro-version>= (version>= 5 0)) (defun host-address (host &optional (family :internet)) (ecase family (:internet (cons :internet (multiple-value-list (socket::ipaddr-to-dotted (socket::lookup-hostname host) :values t)))))) #+(and allegro-version>= (not (version>= 5 0))) (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (labels ((no-host-error () (error "Unknown host ~S" host)) (no-address-error () (error "Host ~S has no ~S address" host family))) (let ((hostent 0)) (unwind-protect (progn (setf hostent (ipc::gethostbyname (string host))) (when (zerop hostent) (no-host-error)) (ecase family ((:internet nil 0) (unless (= (ipc::hostent-addrtype hostent) 2) (no-address-error)) (assert (= (ipc::hostent-length hostent) 4)) (let ((addr (ipc::hostent-addr hostent))) (when (or (member comp::.target. '(:hp :sgi4d :sony :dec3100) :test #'eq) (probe-file "/lib/ld.so")) ;; BSD 4.3 based systems require an extra indirection (setq addr (si:memref-int addr 0 0 :unsigned-long))) (list :internet (si:memref-int addr 0 0 :unsigned-byte) (si:memref-int addr 1 0 :unsigned-byte) (si:memref-int addr 2 0 :unsigned-byte) (si:memref-int addr 3 0 :unsigned-byte)))))) (ff:free-cstruct hostent))))) ;;----------------------------------------------------------------------------- ;; Whether to use closures for requests or not. ;;----------------------------------------------------------------------------- ;;; If this macro expands to non-NIL, then request and locking code is ;;; compiled in a much more compact format, as the common code is shared, and ;;; the specific code is built into a closure that is funcalled by the shared ;;; code. If your compiler makes efficient use of closures then you probably ;;; want to make this expand to T, as it makes the code more compact. (defmacro use-closures () #+(or lispm Minima) t #-(or lispm Minima) nil) #-(or Genera Minima) (defun clx-macroexpand (form env) (macroexpand form env)) ;;----------------------------------------------------------------------------- ;; Resource stuff ;;----------------------------------------------------------------------------- ;;; Utilities (defun getenv (name) #+excl (sys:getenv name) ) (defun get-host-name () "Return the same hostname as gethostname(3) would" ;; resources-pathname was using short-site-name for this purpose #+excl (short-site-name) ) (defun homedir-file-pathname (name) (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal) (merge-pathnames (user-homedir-pathname) (pathname name)))) ;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if ;;; a resource manager isn't running. (defun default-resources-pathname () (homedir-file-pathname ".Xdefaults")) ;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the ;;; defaults have been loaded. (defun resources-pathname () (or (let ((string (getenv "XENVIRONMENT"))) (and string (pathname string))) (homedir-file-pathname (concatenate 'string ".Xdefaults-" (get-host-name))))) ;;; AUTHORITY-PATHNAME - The pathname of the authority file. (defun authority-pathname () (or (let ((xauthority (getenv "XAUTHORITY"))) (and xauthority (pathname xauthority))) (homedir-file-pathname ".Xauthority"))) ;;; this particular defaulting behaviour is typical to most Unices, I think #+unix (defun get-default-display (&optional display-name) "Parse the argument DISPLAY-NAME, or the environment variable $DISPLAY if it is NIL. Display names have the format [protocol/] [hostname] : [:] displaynumber [.screennumber] There are two special cases in parsing, to match that done in the Xlib C language bindings - If the hostname is ``unix'' or the empty string, any supplied protocol is ignored and a connection is made using the :local transport. - If a double colon separates hostname from displaynumber, the protocol is assumed to be decnet. Returns a list of (host display-number screen protocol)." (let* ((name (or display-name (getenv "DISPLAY") (error "DISPLAY environment variable is not set"))) (slash-i (or (position #\/ name) -1)) (colon-i (position #\: name :start (1+ slash-i))) (decnet-colon-p (eql (elt name (1+ colon-i)) #\:)) (host (subseq name (1+ slash-i) colon-i)) (dot-i (and colon-i (position #\. name :start colon-i))) (display (when colon-i (parse-integer name :start (if decnet-colon-p (+ colon-i 2) (1+ colon-i)) :end dot-i))) (screen (when dot-i (parse-integer name :start (1+ dot-i)))) (protocol (cond ((or (string= host "") (string-equal host "unix")) :local) (decnet-colon-p :decnet) ((> slash-i -1) (intern (string-upcase (subseq name 0 slash-i)) :keyword)) (t :internet)))) (list host (or display 0) (or screen 0) protocol))) ;;----------------------------------------------------------------------------- ;; GC stuff ;;----------------------------------------------------------------------------- (defun gc-cleanup () (declare (special *event-free-list* *pending-command-free-list* *reply-buffer-free-lists* *gcontext-local-state-cache* *temp-gcontext-cache*)) (setq *event-free-list* nil) (setq *pending-command-free-list* nil) (when (boundp '*reply-buffer-free-lists*) (fill *reply-buffer-free-lists* nil)) (setq *gcontext-local-state-cache* nil) (setq *temp-gcontext-cache* nil) nil) ;;----------------------------------------------------------------------------- ;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND) ;;----------------------------------------------------------------------------- #-(or clx-ansi-common-lisp Genera CMU sbcl) (defun with-standard-io-syntax-function (function) (declare #+lispm (sys:downward-funarg function)) (let ((*package* (find-package :user)) (*print-array* t) (*print-base* 10) (*print-case* :upcase) (*print-circle* nil) (*print-escape* t) (*print-gensym* t) (*print-length* nil) (*print-level* nil) (*print-pretty* nil) (*print-radix* nil) (*read-base* 10) (*read-default-float-format* 'single-float) (*read-suppress* nil) ) (funcall function))) #-(or clx-ansi-common-lisp Genera CMU sbcl) (defmacro with-standard-io-syntax (&body body) `(flet ((.with-standard-io-syntax-body. () ,@body)) (with-standard-io-syntax-function #'.with-standard-io-syntax-body.))) ;;----------------------------------------------------------------------------- ;; DEFAULT-KEYSYM-TRANSLATE ;;----------------------------------------------------------------------------- ;;; If object is a character, char-bits are set from state. ;;; ;;; [the following isn't implemented (should it be?)] ;;; If object is a list, it is an alist with entries: ;;; (base-char [modifiers] [mask-modifiers]) ;;; When MODIFIERS are specified, this character translation ;;; will only take effect when the specified modifiers are pressed. ;;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore. ;;; When MASK-MODIFIERS is missing, all other modifiers are ignored. ;;; In ambiguous cases, the most specific translation is used. #-(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl) (defun default-keysym-translate (display state object) (declare (type display display) (type card16 state) (type t object) (clx-values t) (special left-meta-keysym right-meta-keysym left-super-keysym right-super-keysym left-hyper-keysym right-hyper-keysym)) (when (characterp object) (when (logbitp (position :control +state-mask-vector+) state) (setf (char-bit object :control) 1)) (when (or (state-keysymp display state left-meta-keysym) (state-keysymp display state right-meta-keysym)) (setf (char-bit object :meta) 1)) (when (or (state-keysymp display state left-super-keysym) (state-keysymp display state right-super-keysym)) (setf (char-bit object :super) 1)) (when (or (state-keysymp display state left-hyper-keysym) (state-keysymp display state right-hyper-keysym)) (setf (char-bit object :hyper) 1))) object) ;;----------------------------------------------------------------------------- ;; Image stuff ;;----------------------------------------------------------------------------- ;;; Types (deftype pixarray-1-element-type () 'bit) (deftype pixarray-4-element-type () '(unsigned-byte 4)) (deftype pixarray-8-element-type () '(unsigned-byte 8)) (deftype pixarray-16-element-type () '(unsigned-byte 16)) (deftype pixarray-24-element-type () '(unsigned-byte 24)) (deftype pixarray-32-element-type () #-(or Genera Minima) '(unsigned-byte 32) #+(or Genera Minima) 'fixnum) (deftype pixarray-1 () '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-1-element-type (* *))) (deftype pixarray-4 () '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-4-element-type (* *))) (deftype pixarray-8 () '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-8-element-type (* *))) (deftype pixarray-16 () '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-16-element-type (* *))) (deftype pixarray-24 () '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-24-element-type (* *))) (deftype pixarray-32 () '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-32-element-type (* *))) (deftype pixarray () '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32)) (deftype bitmap () 'pixarray-1) ;;; WITH-UNDERLYING-SIMPLE-VECTOR #+excl (defmacro with-underlying-simple-vector ((variable element-type pixarray) &body body) `(let ((,variable (cdr (excl::ah_data ,pixarray)))) (declare (type (simple-array ,element-type (*)) ,variable)) ,@body)) ;;; These are used to read and write pixels from and to CARD8s. ;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s. (defmacro read-image-load-byte (size position integer) (unless +image-bit-lsb-first-p+ (setq position (- 7 position))) `(the (unsigned-byte ,size) (#-Genera ldb #+Genera sys:%logldb (byte ,size ,position) (the card8 ,integer)))) ;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from ;;; the appropriate number of CARD8s. (defmacro read-image-assemble-bytes (&rest bytes) (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes))) (let ((it (first bytes)) (count 0)) (dolist (byte (rest bytes)) (setq it `(#-Genera dpb #+Genera sys:%logdpb (the card8 ,byte) (byte 8 ,(incf count 8)) (the (unsigned-byte ,count) ,it)))) #-Genera `(the (unsigned-byte ,(* (length bytes) 8)) ,it) #+Genera it)) ;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit ;;; pixel. (defmacro write-image-load-byte (position integer integer-size) integer-size (unless +image-byte-lsb-first-p+ (setq position (- integer-size 8 position))) `(the card8 (#-Genera ldb #+Genera sys:%logldb (byte 8 ,position) #-Genera (the (unsigned-byte ,integer-size) ,integer) #+Genera ,integer ))) ;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit ;;; pixels. (defmacro write-image-assemble-bytes (&rest bytes) (unless +image-bit-lsb-first-p+ (setq bytes (reverse bytes))) (let ((size (floor 8 (length bytes))) (it (first bytes)) (count 0)) (dolist (byte (rest bytes)) (setq it `(#-Genera dpb #+Genera sys:%logdpb (the (unsigned-byte ,size) ,byte) (byte ,size ,(incf count size)) (the (unsigned-byte ,count) ,it)))) `(the card8 ,it))) #+(or Genera lcl3.0 excl) (defvar *computed-image-byte-lsb-first-p* +image-byte-lsb-first-p+) #+(or Genera lcl3.0 excl) (defvar *computed-image-bit-lsb-first-p* +image-bit-lsb-first-p+) ;;; The following table gives the bit ordering within bytes (when accessed ;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to ;;; 31, where bit 0 should be leftmost on the display. For a given byte ;;; labelled A-B, A is for the most significant bit of the byte, and B is ;;; for the least significant bit. ;;; ;;; legend: ;;; 1 scanline-unit = 8 ;;; 2 scanline-unit = 16 ;;; 4 scanline-unit = 32 ;;; M byte-order = MostSignificant ;;; L byte-order = LeastSignificant ;;; m bit-order = MostSignificant ;;; l bit-order = LeastSignificant ;;; ;;; ;;; format ordering ;;; ;;; 1Mm 00-07 08-15 16-23 24-31 ;;; 2Mm 00-07 08-15 16-23 24-31 ;;; 4Mm 00-07 08-15 16-23 24-31 ;;; 1Ml 07-00 15-08 23-16 31-24 ;;; 2Ml 15-08 07-00 31-24 23-16 ;;; 4Ml 31-24 23-16 15-08 07-00 ;;; 1Lm 00-07 08-15 16-23 24-31 ;;; 2Lm 08-15 00-07 24-31 16-23 ;;; 4Lm 24-31 16-23 08-15 00-07 ;;; 1Ll 07-00 15-08 23-16 31-24 ;;; 2Ll 07-00 15-08 23-16 31-24 ;;; 4Ll 07-00 15-08 23-16 31-24 #+(or Genera lcl3.0 excl) (defconstant *image-bit-ordering-table* '(((1 (00 07) (08 15) (16 23) (24 31)) (nil nil)) ((2 (00 07) (08 15) (16 23) (24 31)) (nil nil)) ((4 (00 07) (08 15) (16 23) (24 31)) (nil nil)) ((1 (07 00) (15 08) (23 16) (31 24)) (nil t)) ((2 (15 08) (07 00) (31 24) (23 16)) (nil t)) ((4 (31 24) (23 16) (15 08) (07 00)) (nil t)) ((1 (00 07) (08 15) (16 23) (24 31)) (t nil)) ((2 (08 15) (00 07) (24 31) (16 23)) (t nil)) ((4 (24 31) (16 23) (08 15) (00 07)) (t nil)) ((1 (07 00) (15 08) (23 16) (31 24)) (t t)) ((2 (07 00) (15 08) (23 16) (31 24)) (t t)) ((4 (07 00) (15 08) (23 16) (31 24)) (t t)))) #+(or Genera lcl3.0 excl) (defun compute-image-byte-and-bit-ordering () (declare (clx-values image-byte-lsb-first-p image-bit-lsb-first-p)) ;; First compute the ordering (let ((ordering nil) (a (make-array '(1 32) :element-type 'bit :initial-element 0))) (dotimes (i 4) (push (flet ((bitpos (a i n) (declare (optimize (speed 3) (safety 0) (space 0))) (declare (type (simple-array bit (* *)) a) (type fixnum i n)) (with-underlying-simple-vector (v (unsigned-byte 8) a) (prog2 (setf (aref v i) n) (dotimes (i 32) (unless (zerop (aref a 0 i)) (return i))) (setf (aref v i) 0))))) (list (bitpos a i #b10000000) (bitpos a i #b00000001))) ordering)) (setq ordering (cons (floor +image-unit+ 8) (nreverse ordering))) ;; Now from the ordering, compute byte-lsb-first-p and bit-lsb-first-p (let ((byte-and-bit-ordering (second (assoc ordering *image-bit-ordering-table* :test #'equal)))) (unless byte-and-bit-ordering (error "Couldn't determine image byte and bit ordering~@ measured image ordering = ~A" ordering)) (values-list byte-and-bit-ordering)))) #+(or Genera lcl3.0 excl) (multiple-value-setq (*computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) (compute-image-byte-and-bit-ordering)) ;;; If you can write fast routines that can read and write pixarrays out of a ;;; buffer-bytes, do it! It makes the image code a lot faster. The ;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines ;;; return T if they can do it, NIL if they can't. ;;; FIXME: though we have some #+sbcl -conditionalized routines in ;;; here, they would appear not to work, and so are commented out in ;;; the the FAST-xxx-PIXARRAY routines themseleves. Investigate ;;; whether the unoptimized routines are often used, and also whether ;;; speeding them up while maintaining correctness is possible. ;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s #+(or lcl3.0 excl) (defun fast-read-pixarray-1 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-1 array) (type card16 x y width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-1-element-type array) (do* ((start (index+ index (index* y padded-bytes-per-line) (index-ceiling x 8)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y)) (left-bits (the array-index (mod (the fixnum (- x)) 8))) (right-bits (index-mod (index- width left-bits) 8)) (middle-bits (the fixnum (- (the fixnum (- width left-bits)) right-bits))) (middle-bytes (index-floor middle-bits 8))) ((index>= y height)) (declare (type array-index start y left-bits right-bits middle-bytes) (fixnum middle-bits)) (cond ((< middle-bits 0) (let ((byte (aref buffer-bbuf (index1- start))) (x (array-row-major-index array y left-bits))) (declare (type card8 byte) (type array-index x)) (when (index> right-bits 6) (setf (aref vector (index- x 1)) (read-image-load-byte 1 7 byte))) (when (and (index> left-bits 1) (index> right-bits 5)) (setf (aref vector (index- x 2)) (read-image-load-byte 1 6 byte))) (when (and (index> left-bits 2) (index> right-bits 4)) (setf (aref vector (index- x 3)) (read-image-load-byte 1 5 byte))) (when (and (index> left-bits 3) (index> right-bits 3)) (setf (aref vector (index- x 4)) (read-image-load-byte 1 4 byte))) (when (and (index> left-bits 4) (index> right-bits 2)) (setf (aref vector (index- x 5)) (read-image-load-byte 1 3 byte))) (when (and (index> left-bits 5) (index> right-bits 1)) (setf (aref vector (index- x 6)) (read-image-load-byte 1 2 byte))) (when (index> left-bits 6) (setf (aref vector (index- x 7)) (read-image-load-byte 1 1 byte))))) (t (unless (index-zerop left-bits) (let ((byte (aref buffer-bbuf (index1- start))) (x (array-row-major-index array y left-bits))) (declare (type card8 byte) (type array-index x)) (setf (aref vector (index- x 1)) (read-image-load-byte 1 7 byte)) (when (index> left-bits 1) (setf (aref vector (index- x 2)) (read-image-load-byte 1 6 byte)) (when (index> left-bits 2) (setf (aref vector (index- x 3)) (read-image-load-byte 1 5 byte)) (when (index> left-bits 3) (setf (aref vector (index- x 4)) (read-image-load-byte 1 4 byte)) (when (index> left-bits 4) (setf (aref vector (index- x 5)) (read-image-load-byte 1 3 byte)) (when (index> left-bits 5) (setf (aref vector (index- x 6)) (read-image-load-byte 1 2 byte)) (when (index> left-bits 6) (setf (aref vector (index- x 7)) (read-image-load-byte 1 1 byte)) )))))))) (do* ((end (index+ start middle-bytes)) (i start (index1+ i)) (x (array-row-major-index array y left-bits) (index+ x 8))) ((index>= i end) (unless (index-zerop right-bits) (let ((byte (aref buffer-bbuf end)) (x (array-row-major-index array y (index+ left-bits middle-bits)))) (declare (type card8 byte) (type array-index x)) (setf (aref vector (index+ x 0)) (read-image-load-byte 1 0 byte)) (when (index> right-bits 1) (setf (aref vector (index+ x 1)) (read-image-load-byte 1 1 byte)) (when (index> right-bits 2) (setf (aref vector (index+ x 2)) (read-image-load-byte 1 2 byte)) (when (index> right-bits 3) (setf (aref vector (index+ x 3)) (read-image-load-byte 1 3 byte)) (when (index> right-bits 4) (setf (aref vector (index+ x 4)) (read-image-load-byte 1 4 byte)) (when (index> right-bits 5) (setf (aref vector (index+ x 5)) (read-image-load-byte 1 5 byte)) (when (index> right-bits 6) (setf (aref vector (index+ x 6)) (read-image-load-byte 1 6 byte)) ))))))))) (declare (type array-index end i x)) (let ((byte (aref buffer-bbuf i))) (declare (type card8 byte)) (setf (aref vector (index+ x 0)) (read-image-load-byte 1 0 byte)) (setf (aref vector (index+ x 1)) (read-image-load-byte 1 1 byte)) (setf (aref vector (index+ x 2)) (read-image-load-byte 1 2 byte)) (setf (aref vector (index+ x 3)) (read-image-load-byte 1 3 byte)) (setf (aref vector (index+ x 4)) (read-image-load-byte 1 4 byte)) (setf (aref vector (index+ x 5)) (read-image-load-byte 1 5 byte)) (setf (aref vector (index+ x 6)) (read-image-load-byte 1 6 byte)) (setf (aref vector (index+ x 7)) (read-image-load-byte 1 7 byte)))) ))))) t) #+(or lcl3.0 excl) (defun fast-read-pixarray-4 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-4 array) (type card16 x y width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-4-element-type array) (do* ((start (index+ index (index* y padded-bytes-per-line) (index-ceiling x 2)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y)) (left-nibbles (the array-index (mod (the fixnum (- (the fixnum x))) 2))) (right-nibbles (index-mod (index- width left-nibbles) 2)) (middle-nibbles (index- width left-nibbles right-nibbles)) (middle-bytes (index-floor middle-nibbles 2))) ((index>= y height)) (declare (type array-index start y left-nibbles right-nibbles middle-nibbles middle-bytes)) (unless (index-zerop left-nibbles) (setf (aref array y 0) (read-image-load-byte 4 4 (aref buffer-bbuf (index1- start))))) (do* ((end (index+ start middle-bytes)) (i start (index1+ i)) (x (array-row-major-index array y left-nibbles) (index+ x 2))) ((index>= i end) (unless (index-zerop right-nibbles) (setf (aref array y (index+ left-nibbles middle-nibbles)) (read-image-load-byte 4 0 (aref buffer-bbuf end))))) (declare (type array-index end i x)) (let ((byte (aref buffer-bbuf i))) (declare (type card8 byte)) (setf (aref vector (index+ x 0)) (read-image-load-byte 4 0 byte)) (setf (aref vector (index+ x 1)) (read-image-load-byte 4 4 byte)))) ))) t) #+(or Genera lcl3.0 excl CMU sbcl) (defun fast-read-pixarray-24 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-24 array) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-24-element-type array) (do* ((start (index+ index (index* y padded-bytes-per-line) (index* x 3)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y))) ((index>= y height)) (declare (type array-index start y)) (do* ((end (index+ start (index* width 3))) (i start (index+ i 3)) (x (array-row-major-index array y 0) (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (setf (aref vector x) (read-image-assemble-bytes (aref buffer-bbuf (index+ i 0)) (aref buffer-bbuf (index+ i 1)) (aref buffer-bbuf (index+ i 2)))))))) t) ;;; COPY-BIT-RECT -- Internal ;;; ;;; This is the classic BITBLT operation, copying a rectangular subarray ;;; from one array to another (but source and destination must not overlap.) ;;; Widths are specified in bits. Neither array can have a non-zero ;;; displacement. We allow extra random bit-offset to be thrown into the X. ;;; #+(or Genera lcl3.0 excl) (defun fast-read-pixarray-with-swap (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type array-index boffset padded-bytes-per-line) (type pixarray pixarray) (type card16 x y width height) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (unless (index= bits-per-pixel 24) (let ((pixarray-padded-bits-per-line (if (index= height 1) 0 (index* (index- (array-row-major-index pixarray 1 0) (array-row-major-index pixarray 0 0)) bits-per-pixel))) (x-bits (index* x bits-per-pixel))) (declare (type array-index pixarray-padded-bits-per-line x-bits)) (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) (index-zerop (index-mod x-bits 8))) (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) (index-zerop (index-mod x-bits +image-unit+)))) (multiple-value-bind (image-swap-function image-swap-lsb-first-p) (image-swap-function bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p +image-unit+ *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) (declare (type symbol image-swap-function) (type generalized-boolean image-swap-lsb-first-p)) (with-underlying-simple-vector (dst card8 pixarray) (funcall (symbol-function image-swap-function) bbuf dst (index+ boffset (index* y padded-bytes-per-line) (index-floor x-bits 8)) 0 (index-ceiling (index* width bits-per-pixel) 8) padded-bytes-per-line (index-floor pixarray-padded-bits-per-line 8) height image-swap-lsb-first-p))) t)))) (defun fast-read-pixarray (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type array-index boffset padded-bytes-per-line) (type pixarray pixarray) (type card16 x y width height) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (progn bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (or #+(or Genera lcl3.0 excl) (fast-read-pixarray-with-swap bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (let ((function (or #+lispm (and (= (sys:array-element-size pixarray) bits-per-pixel) (zerop (index-mod padded-bytes-per-line 4)) (zerop (index-mod (* #+Genera (sys:array-row-span pixarray) #-Genera (array-dimension pixarray 1) bits-per-pixel) 32)) #'fast-read-pixarray-using-bitblt) #+(or CMU) (and (index= (pixarray-element-size pixarray) bits-per-pixel) #'fast-read-pixarray-using-bitblt) #+(or lcl3.0 excl) (and (index= bits-per-pixel 1) #'fast-read-pixarray-1) #+(or lcl3.0 excl) (and (index= bits-per-pixel 4) #'fast-read-pixarray-4) #+(or Genera lcl3.0 excl CMU) (and (index= bits-per-pixel 24) #'fast-read-pixarray-24)))) (when function (read-pixarray-internal bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel function unit byte-lsb-first-p bit-lsb-first-p +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+))))) ;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s #+(or lcl3.0 excl) (defun fast-write-pixarray-1 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-1 array) (type card16 x y width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-1-element-type array) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (right-bits (index-mod width 8)) (middle-bits (index- width right-bits)) (middle-bytes (index-ceiling middle-bits 8)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index h y right-bits middle-bits middle-bytes start)) (do* ((end (index+ start middle-bytes)) (i start (index1+ i)) (start-x x) (x (array-row-major-index array y start-x) (index+ x 8))) ((index>= i end) (unless (index-zerop right-bits) (let ((x (array-row-major-index array y (index+ start-x middle-bits)))) (declare (type array-index x)) (setf (aref buffer-bbuf end) (write-image-assemble-bytes (aref vector (index+ x 0)) (if (index> right-bits 1) (aref vector (index+ x 1)) 0) (if (index> right-bits 2) (aref vector (index+ x 2)) 0) (if (index> right-bits 3) (aref vector (index+ x 3)) 0) (if (index> right-bits 4) (aref vector (index+ x 4)) 0) (if (index> right-bits 5) (aref vector (index+ x 5)) 0) (if (index> right-bits 6) (aref vector (index+ x 6)) 0) 0))))) (declare (type array-index end i start-x x)) (setf (aref buffer-bbuf i) (write-image-assemble-bytes (aref vector (index+ x 0)) (aref vector (index+ x 1)) (aref vector (index+ x 2)) (aref vector (index+ x 3)) (aref vector (index+ x 4)) (aref vector (index+ x 5)) (aref vector (index+ x 6)) (aref vector (index+ x 7)))))))) t) #+(or lcl3.0 excl) (defun fast-write-pixarray-4 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-4 array) (type int16 x y) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-4-element-type array) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (right-nibbles (index-mod width 2)) (middle-nibbles (index- width right-nibbles)) (middle-bytes (index-ceiling middle-nibbles 2)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index h y right-nibbles middle-nibbles middle-bytes start)) (do* ((end (index+ start middle-bytes)) (i start (index1+ i)) (start-x x) (x (array-row-major-index array y start-x) (index+ x 2))) ((index>= i end) (unless (index-zerop right-nibbles) (setf (aref buffer-bbuf end) (write-image-assemble-bytes (aref array y (index+ start-x middle-nibbles)) 0)))) (declare (type array-index end i start-x x)) (setf (aref buffer-bbuf i) (write-image-assemble-bytes (aref vector (index+ x 0)) (aref vector (index+ x 1)))))))) t) #+(or Genera lcl3.0 excl CMU sbcl) (defun fast-write-pixarray-24 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-24 array) (type int16 x y) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-24-element-type array) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index y start)) (do* ((end (index+ start (index* width 3))) (i start (index+ i 3)) (x (array-row-major-index array y x) (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (let ((pixel (aref vector x))) (declare (type pixarray-24-element-type pixel)) (setf (aref buffer-bbuf (index+ i 0)) (write-image-load-byte 0 pixel 24)) (setf (aref buffer-bbuf (index+ i 1)) (write-image-load-byte 8 pixel 24)) (setf (aref buffer-bbuf (index+ i 2)) (write-image-load-byte 16 pixel 24))))))) t) #+(or Genera lcl3.0 excl) (defun fast-write-pixarray-with-swap (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type pixarray pixarray) (type card16 x y width height) (type array-index boffset padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (unless (index= bits-per-pixel 24) (let ((pixarray-padded-bits-per-line (if (index= height 1) 0 (index* (index- (array-row-major-index pixarray 1 0) (array-row-major-index pixarray 0 0)) bits-per-pixel))) (pixarray-start-bit-offset (index* (array-row-major-index pixarray y x) bits-per-pixel))) (declare (type array-index pixarray-padded-bits-per-line pixarray-start-bit-offset)) (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) (index-zerop (index-mod pixarray-start-bit-offset 8))) (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) (multiple-value-bind (image-swap-function image-swap-lsb-first-p) (image-swap-function bits-per-pixel +image-unit+ *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p* unit byte-lsb-first-p bit-lsb-first-p) (declare (type symbol image-swap-function) (type generalized-boolean image-swap-lsb-first-p)) (with-underlying-simple-vector (src card8 pixarray) (funcall (symbol-function image-swap-function) src bbuf (index-floor pixarray-start-bit-offset 8) boffset (index-ceiling (index* width bits-per-pixel) 8) (index-floor pixarray-padded-bits-per-line 8) padded-bytes-per-line height image-swap-lsb-first-p)) t))))) (defun fast-write-pixarray (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type pixarray pixarray) (type card16 x y width height) (type array-index boffset padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (progn bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (or #+(or Genera lcl3.0 excl) (fast-write-pixarray-with-swap bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (let ((function (or #+lispm (and (= (sys:array-element-size pixarray) bits-per-pixel) (zerop (index-mod padded-bytes-per-line 4)) (zerop (index-mod (* #+Genera (sys:array-row-span pixarray) #-Genera (array-dimension pixarray 1) bits-per-pixel) 32)) #'fast-write-pixarray-using-bitblt) #+(or CMU) (and (index= (pixarray-element-size pixarray) bits-per-pixel) #'fast-write-pixarray-using-bitblt) #+(or lcl3.0 excl) (and (index= bits-per-pixel 1) #'fast-write-pixarray-1) #+(or lcl3.0 excl) (and (index= bits-per-pixel 4) #'fast-write-pixarray-4) #+(or Genera lcl3.0 excl CMU) (and (index= bits-per-pixel 24) #'fast-write-pixarray-24)))) (when function (write-pixarray-internal bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel function +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+ unit byte-lsb-first-p bit-lsb-first-p))))) ;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another (defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel) (declare (type pixarray pixarray copy) (type card16 x y width height) (type (member 1 4 8 16 24 32) bits-per-pixel)) (progn pixarray copy x y width height bits-per-pixel nil) (or #+(or lispm CMU) (let* ((pixarray-padded-pixels-per-line #+Genera (sys:array-row-span pixarray) #-Genera (array-dimension pixarray 1)) (pixarray-padded-bits-per-line (* pixarray-padded-pixels-per-line bits-per-pixel)) (copy-padded-pixels-per-line #+Genera (sys:array-row-span copy) #-Genera (array-dimension copy 1)) (copy-padded-bits-per-line (* copy-padded-pixels-per-line bits-per-pixel))) #-(or CMU) (when (and (= (sys:array-element-size pixarray) bits-per-pixel) (zerop (index-mod pixarray-padded-bits-per-line 32)) (zerop (index-mod copy-padded-bits-per-line 32))) (sys:bitblt boole-1 width height pixarray x y copy 0 0) t) #+(or CMU) (when (index= (pixarray-element-size pixarray) (pixarray-element-size copy) bits-per-pixel) (copy-bit-rect pixarray pixarray-padded-bits-per-line x y copy copy-padded-bits-per-line 0 0 height (index* width bits-per-pixel)) t)) #+(or lcl3.0 excl) (unless (index= bits-per-pixel 24) (let ((pixarray-padded-bits-per-line (if (index= height 1) 0 (index* (index- (array-row-major-index pixarray 1 0) (array-row-major-index pixarray 0 0)) bits-per-pixel))) (copy-padded-bits-per-line (if (index= height 1) 0 (index* (index- (array-row-major-index copy 1 0) (array-row-major-index copy 0 0)) bits-per-pixel))) (pixarray-start-bit-offset (index* (array-row-major-index pixarray y x) bits-per-pixel))) (declare (type array-index pixarray-padded-bits-per-line copy-padded-bits-per-line pixarray-start-bit-offset)) (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) (index-zerop (index-mod copy-padded-bits-per-line 8)) (index-zerop (index-mod pixarray-start-bit-offset 8))) (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) (index-zerop (index-mod copy-padded-bits-per-line +image-unit+)) (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) (with-underlying-simple-vector (src card8 pixarray) (with-underlying-simple-vector (dst card8 copy) (image-noswap src dst (index-floor pixarray-start-bit-offset 8) 0 (index-ceiling (index* width bits-per-pixel) 8) (index-floor pixarray-padded-bits-per-line 8) (index-floor copy-padded-bits-per-line 8) height nil))) t))) #+(or lcl3.0 excl) (macrolet ((copy (type element-type) `(let ((pixarray pixarray) (copy copy)) (declare (type ,type pixarray copy)) #.(declare-buffun) (with-underlying-simple-vector (src ,element-type pixarray) (with-underlying-simple-vector (dst ,element-type copy) (do* ((dst-y 0 (index1+ dst-y)) (src-y y (index1+ src-y))) ((index>= dst-y height)) (declare (type card16 dst-y src-y)) (do* ((dst-idx (array-row-major-index copy dst-y 0) (index1+ dst-idx)) (dst-end (index+ dst-idx width)) (src-idx (array-row-major-index pixarray src-y x) (index1+ src-idx))) ((index>= dst-idx dst-end)) (declare (type array-index dst-idx src-idx dst-end)) (setf (aref dst dst-idx) (the ,element-type (aref src src-idx)))))))))) (ecase bits-per-pixel (1 (copy pixarray-1 pixarray-1-element-type)) (4 (copy pixarray-4 pixarray-4-element-type)) (8 (copy pixarray-8 pixarray-8-element-type)) (16 (copy pixarray-16 pixarray-16-element-type)) (24 (copy pixarray-24 pixarray-24-element-type)) (32 (copy pixarray-32 pixarray-32-element-type))) t))) cl-clx-sbcl-0.7.4.20160323.orig/sockcl.lisp0000644000175000017500000001062612715665272015776 0ustar pdmpdm;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;;; Server Connection for kcl and ibcl ;;; Copyright (C) 1987, 1989 Massachussetts Institute of Technology ;;; ;;; Permission is granted to any individual or institution to use, copy, ;;; modify, and distribute this software, provided that this complete ;;; copyright and permission notice is maintained, intact, in all copies and ;;; supporting documentation. ;;; ;;; Massachussetts Institute of Technology provides this software "as is" ;;; without express or implied warranty. ;;; ;;; Adapted from code by Roman Budzianowski - Project Athena/MIT ;;; make-two-way-stream is probably not a reasonable thing to do. ;;; A close on a two way stream probably does not close the substreams. ;;; I presume an :io will not work (maybe because it uses 1 buffer?). ;;; There should be some fast io (writes and reads...). ;;; Compile this file with compile-file. ;;; Load it with (si:faslink "sockcl.o" "socket.o -lc") (in-package :xlib) ;;; The cmpinclude.h file does not have this type definition from ;;; /h/object.h. We include it here so the ;;; compile-file will work without figuring out where the distribution ;;; directory is located. ;;; (CLINES " enum smmode { /* stream mode */ smm_input, /* input */ smm_output, /* output */ smm_io, /* input-output */ smm_probe, /* probe */ smm_synonym, /* synonym */ smm_broadcast, /* broadcast */ smm_concatenated, /* concatenated */ smm_two_way, /* two way */ smm_echo, /* echo */ smm_string_input, /* string input */ smm_string_output, /* string output */ smm_user_defined /* for user defined */ }; ") #-akcl (CLINES " struct stream { short t, m; FILE *sm_fp; /* file pointer */ object sm_object0; /* some object */ object sm_object1; /* some object */ int sm_int0; /* some int */ int sm_int1; /* some int */ short sm_mode; /* stream mode */ /* of enum smmode */ }; ") ;;;; Connect to the server. ;;; A lisp string is not a reasonable type for C, so copy the characters ;;; out and then call connect_to_server routine defined in socket.o (CLINES " int konnect_to_server(host,display) object host; /* host name */ int display; /* display number */ { int fd; /* file descriptor */ int i; char hname[BUFSIZ]; FILE *fout, *fin; if (host->st.st_fillp > BUFSIZ - 1) too_long_file_name(host); for (i = 0; i < host->st.st_fillp; i++) hname[i] = host->st.st_self[i]; hname[i] = '\\0'; /* doubled backslash for lisp */ fd = connect_to_server(hname,display); return(fd); } ") (defentry konnect-to-server (object int) (int "konnect_to_server")) ;;;; Make a one-way stream from a file descriptor. (CLINES " object konnect_stream(host,fd,flag,elem) object host; /* not really used */ int fd; /* file descriptor */ int flag; /* 0 input, 1 output */ object elem; /* 'string-char */ { struct stream *stream; char *mode; /* file open mode */ FILE *fp; /* file pointer */ enum smmode smm; /* lisp mode (a short) */ vs_mark; switch(flag){ case 0: smm = smm_input; mode = \"r\"; break; case 1: smm = smm_output; mode = \"w\"; break; default: FEerror(\"konnect_stream : wrong mode\"); } fp = fdopen(fd,mode); if (fp == NULL) { stream = Cnil; vs_push(stream); } else { stream = alloc_object(t_stream); stream->sm_mode = (short)smm; stream->sm_fp = fp; stream->sm_object0 = elem; stream->sm_object1 = host; stream->sm_int0 = stream->sm.sm_int1 = 0; vs_push(stream); setbuf(fp, alloc_contblock(BUFSIZ)); } vs_reset; return(stream); } ") (defentry konnect-stream (object int int object) (object "konnect_stream")) ;;;; Open an X stream (defun open-socket-stream (host display) (when (not (and (typep host 'string) ; sanity check the arguments (typep display 'fixnum))) (error "Host ~s or display ~s are bad." host display)) (let ((fd (konnect-to-server host display))) ; get a file discriptor (if (< fd 0) NIL (let ((stream-in (konnect-stream host fd 0 'string-char)) ; input (stream-out (konnect-stream host fd 1 'string-char))) ; output (if (or (null stream-in) (null stream-out)) (error "Could not make i/o streams for fd ~d." fd)) (make-two-way-stream stream-in stream-out)) ))) cl-clx-sbcl-0.7.4.20160323.orig/exclREADME0000644000175000017500000000407712715665272015366 0ustar pdmpdm This file contains instructions on how to make CLX work with Franz Common Lisp. CLX should work on any machine that supports Allegro Common Lisp version 3.0.1 or greater. It also works under ExCL version 2.0.10. However it has been tested extensively with only Allegro CL versions 3.0, 3.1, and 4.0. There are three steps to compile and install CLX. The first is simply moving files around. In this directory, execute (assuming you using csh): % foreach i (*.l */*.l) ? mv $i $i:r.cl ? end % mv exclMakefile Makefile The second is compiling the source files into fasl files. The fasl files will be combined into one big fasl file, CLX.fasl. This file is then installed in your Common Lisp library directory in the next step. You may need to edit the Makefile to select the proper CFLAGS for your machine -- look in Makefile for examples. Then just: % make Now you must move the CLX.fasl file into the standard CL library. This is normally "/usr/local/lib/cl/code", but you can find out for sure by typing: (directory-namestring excl::*library-code-pathname*) to a running Lisp. If it prints something other than "/usr/local/lib/cl/code" substitute what it prints in the below instructions. % mv CLX.fasl /usr/local/lib/cl/code/clx.fasl % mv *.o /usr/local/lib/cl/code Now you can just start up Lisp and type: (load "clx") to load in CLX. You may want to dump a lisp at this point since CLX is a large package and can take some time to load into Lisp. You probably also want to set the :generation-spread to 1 while loading CLX. Please see your Allegro CL User Guide for more information on :generation-spread. Sophisticated users may wish to peruse the Makefile and defsystem.cl and note how things are set up. For example we hardwire the compiler interrupt check switch on, so that CL can still be interrupted while it is reading from the X11 socket. Please see chapter 7 of the CL User's guide for more information on compiler switches and their effects. Please report Franz specific CLX bugs to: ucbvax!franz!bugs or bugs@Franz.COM cl-clx-sbcl-0.7.4.20160323.orig/dep-openmcl.lisp0000644000175000017500000011115712715665272016724 0ustar pdmpdm;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- ;; This file contains some of the system dependent code for CLX ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (in-package :xlib) (proclaim '(declaration array-register)) ;;; The size of the output buffer. Must be a multiple of 4. (defparameter *output-buffer-size* 8192) ;;; Number of seconds to wait for a reply to a server request (defparameter *reply-timeout* nil) (progn (defconstant +word-0+ 1) (defconstant +word-1+ 0) (defconstant +long-0+ 3) (defconstant +long-1+ 2) (defconstant +long-2+ 1) (defconstant +long-3+ 0)) ;;; Set some compiler-options for often used code (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +buffer-speed+ #+clx-debugging 1 #-clx-debugging 3 "Speed compiler option for buffer code.") (defconstant +buffer-safety+ #+clx-debugging 3 #-clx-debugging 0 "Safety compiler option for buffer code.") (defconstant +buffer-debug+ #+clx-debugging 2 #-clx-debugging 1 "Debug compiler option for buffer code>") (defun declare-bufmac () `(declare (optimize (speed ,+buffer-speed+) (safety ,+buffer-safety+) (debug ,+buffer-debug+)))) ;; It's my impression that in lucid there's some way to make a ;; declaration called fast-entry or something that causes a function ;; to not do some checking on args. Sadly, we have no lucid manuals ;; here. If such a declaration is available, it would be a good ;; idea to make it here when +buffer-speed+ is 3 and +buffer-safety+ ;; is 0. (defun declare-buffun () `(declare (optimize (speed ,+buffer-speed+) (safety ,+buffer-safety+) (debug ,+buffer-debug+))))) (declaim (inline card8->int8 int8->card8 card16->int16 int16->card16 card32->int32 int32->card32)) (progn (defun card8->int8 (x) (declare (type card8 x)) (declare (clx-values int8)) #.(declare-buffun) (the int8 (if (logbitp 7 x) (the int8 (- x #x100)) x))) (defun int8->card8 (x) (declare (type int8 x)) (declare (clx-values card8)) #.(declare-buffun) (the card8 (ldb (byte 8 0) x))) (defun card16->int16 (x) (declare (type card16 x)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (if (logbitp 15 x) (the int16 (- x #x10000)) x))) (defun int16->card16 (x) (declare (type int16 x)) (declare (clx-values card16)) #.(declare-buffun) (the card16 (ldb (byte 16 0) x))) (defun card32->int32 (x) (declare (type card32 x)) (declare (clx-values int32)) #.(declare-buffun) (the int32 (if (logbitp 31 x) (the int32 (- x #x100000000)) x))) (defun int32->card32 (x) (declare (type int32 x)) (declare (clx-values card32)) #.(declare-buffun) (the card32 (ldb (byte 32 0) x))) ) (declaim (inline aref-card8 aset-card8 aref-int8 aset-int8)) (progn (defun aref-card8 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card8)) #.(declare-buffun) (the card8 (aref a i))) (defun aset-card8 (v a i) (declare (type card8 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a i) v)) (defun aref-int8 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int8)) #.(declare-buffun) (card8->int8 (aref a i))) (defun aset-int8 (v a i) (declare (type int8 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a i) (int8->card8 v))) ) (progn (defun aref-card16 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card16)) #.(declare-buffun) (the card16 (logior (the card16 (ash (the card8 (aref a (index+ i +word-1+))) 8)) (the card8 (aref a (index+ i +word-0+)))))) (defun aset-card16 (v a i) (declare (type card16 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-int16 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (logior (the int16 (ash (the int8 (aref-int8 a (index+ i +word-1+))) 8)) (the card8 (aref a (index+ i +word-0+)))))) (defun aset-int16 (v a i) (declare (type int16 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-card32 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card32)) #.(declare-buffun) (the card32 (logior (the card32 (ash (the card8 (aref a (index+ i +long-3+))) 24)) (the card29 (ash (the card8 (aref a (index+ i +long-2+))) 16)) (the card16 (ash (the card8 (aref a (index+ i +long-1+))) 8)) (the card8 (aref a (index+ i +long-0+)))))) (defun aset-card32 (v a i) (declare (type card32 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-int32 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int32)) #.(declare-buffun) (the int32 (logior (the int32 (ash (the int8 (aref-int8 a (index+ i +long-3+))) 24)) (the card29 (ash (the card8 (aref a (index+ i +long-2+))) 16)) (the card16 (ash (the card8 (aref a (index+ i +long-1+))) 8)) (the card8 (aref a (index+ i +long-0+)))))) (defun aset-int32 (v a i) (declare (type int32 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-card29 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card29)) #.(declare-buffun) (the card29 (logior (the card29 (ash (the card8 (aref a (index+ i +long-3+))) 24)) (the card29 (ash (the card8 (aref a (index+ i +long-2+))) 16)) (the card16 (ash (the card8 (aref a (index+ i +long-1+))) 8)) (the card8 (aref a (index+ i +long-0+)))))) (defun aset-card29 (v a i) (declare (type card29 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) v) ) (defsetf aref-card8 (a i) (v) `(aset-card8 ,v ,a ,i)) (defsetf aref-int8 (a i) (v) `(aset-int8 ,v ,a ,i)) (defsetf aref-card16 (a i) (v) `(aset-card16 ,v ,a ,i)) (defsetf aref-int16 (a i) (v) `(aset-int16 ,v ,a ,i)) (defsetf aref-card32 (a i) (v) `(aset-card32 ,v ,a ,i)) (defsetf aref-int32 (a i) (v) `(aset-int32 ,v ,a ,i)) (defsetf aref-card29 (a i) (v) `(aset-card29 ,v ,a ,i)) ;;; Other random conversions (defun rgb-val->card16 (value) ;; Short floats are good enough (declare (type rgb-val value)) (declare (clx-values card16)) #.(declare-buffun) ;; Convert VALUE from float to card16 (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff))))) (defun card16->rgb-val (value) ;; Short floats are good enough (declare (type card16 value)) (declare (clx-values short-float)) #.(declare-buffun) ;; Convert VALUE from card16 to float (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff)))) (defun radians->int16 (value) ;; Short floats are good enough (declare (type angle value)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0))))) (defun int16->radians (value) ;; Short floats are good enough (declare (type int16 value)) (declare (clx-values short-float)) #.(declare-buffun) (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float)))) ;;----------------------------------------------------------------------------- ;; Character transformation ;;----------------------------------------------------------------------------- ;;; This stuff transforms chars to ascii codes in card8's and back. ;;; You might have to hack it a little to get it to work for your machine. (declaim (inline char->card8 card8->char)) (macrolet ((char-translators () (let ((alist `( ;; The normal ascii codes for the control characters. ,@`((#\Return . 13) (#\Linefeed . 10) (#\Rubout . 127) (#\Page . 12) (#\Tab . 9) (#\Backspace . 8) (#\Newline . 10) (#\Space . 32)) ;; The rest of the common lisp charater set with ;; the normal ascii codes for them. (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) (#\} . 125) (#\~ . 126)))) (cond ((dolist (pair alist nil) (when (not (= (char-code (car pair)) (cdr pair))) (return t))) `(progn (defconstant *char-to-card8-translation-table* ',(let ((array (make-array (let ((max-char-code 255)) (dolist (pair alist) (setq max-char-code (max max-char-code (char-code (car pair))))) (1+ max-char-code)) :element-type 'card8))) (dotimes (i (length array)) (setf (aref array i) (mod i 256))) (dolist (pair alist) (setf (aref array (char-code (car pair))) (cdr pair))) array)) (defconstant *card8-to-char-translation-table* ',(let ((array (make-array 256))) (dotimes (i (length array)) (setf (aref array i) (code-char i))) (dolist (pair alist) (setf (aref array (cdr pair)) (car pair))) array)) (progn (defun char->card8 (char) (declare (type base-char char)) #.(declare-buffun) (the card8 (aref (the (simple-array card8 (*)) *char-to-card8-translation-table*) (the array-index (char-code char))))) (defun card8->char (card8) (declare (type card8 card8)) #.(declare-buffun) (the base-char (or (aref (the simple-vector *card8-to-char-translation-table*) card8) (error "Invalid CHAR code ~D." card8)))) ) #+Genera (progn (defun char->card8 (char) (declare lt:(side-effects reader reducible)) (aref *char-to-card8-translation-table* (char-code char))) (defun card8->char (card8) (declare lt:(side-effects reader reducible)) (aref *card8-to-char-translation-table* card8)) ) (dotimes (i 256) (unless (= i (char->card8 (card8->char i))) (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" (list i (card8->char i) (char->card8 (card8->char i)))) (return nil))) (dotimes (i (length *char-to-card8-translation-table*)) (let ((char (code-char i))) (unless (eql char (card8->char (char->card8 char))) (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S" (list char (char->card8 char) (card8->char (char->card8 char)))) (return nil)))))) (t `(progn (defun char->card8 (char) (declare (type base-char char)) #.(declare-buffun) (the card8 (char-code char))) (defun card8->char (card8) (declare (type card8 card8)) #.(declare-buffun) (the base-char (code-char card8))) )))))) (char-translators)) ;;----------------------------------------------------------------------------- ;; Process Locking ;; ;; Common-Lisp doesn't provide process locking primitives, so we define ;; our own here, based on Zetalisp primitives. Holding-Lock is very ;; similar to with-lock on The TI Explorer, and a little more efficient ;; than with-process-lock on a Symbolics. ;;----------------------------------------------------------------------------- ;;; MAKE-PROCESS-LOCK: Creating a process lock. (defun make-process-lock (name) (ccl:make-lock name)) ;;; HOLDING-LOCK: Execute a body of code with a lock held. ;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN ;;; passes its timeout to the holding-lock macro, so any timeout you want to ;;; work for event-listen you should do for holding-lock. (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) (declare (ignore timeout display)) `(ccl:with-lock-grabbed (,locator ,whostate) ,@body)) ;;; WITHOUT-ABORTS ;;; If you can inhibit asynchronous keyboard aborts inside the body of this ;;; macro, then it is a good idea to do this. This macro is wrapped around ;;; request writing and reply reading to ensure that requests are atomically ;;; written and replies are atomically read from the stream. (defmacro without-aborts (&body body) `(ccl:without-interrupts ,@body)) ;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value. ;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's ;;; value changes. (defun process-block (whostate predicate &rest predicate-args) (declare (dynamic-extent predicate-args)) (apply #'ccl:process-wait whostate predicate predicate-args)) ;;; PROCESS-WAKEUP: Check some other process' wait function. (declaim (inline process-wakeup)) (defun process-wakeup (process) (declare (ignore process)) nil) ;;; CURRENT-PROCESS: Return the current process object for input locking and ;;; for calling PROCESS-WAKEUP. (declaim (inline current-process)) ;;; Default return NIL, which is acceptable even if there is a scheduler. (defun current-process () ccl::*current-process*) ;;; WITHOUT-INTERRUPTS -- provide for atomic operations. (defmacro without-interrupts (&body body) `(ccl:without-interrupts ,@body)) ;;; CONDITIONAL-STORE: ;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times. ;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD. (defmacro conditional-store (place old-value new-value) `(ccl::conditional-store ,place ,old-value ,new-value)) ;;;---------------------------------------------------------------------------- ;;; IO Error Recovery ;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro. ;;; It prevents multiple mindless errors when the network craters. ;;; ;;;---------------------------------------------------------------------------- (defmacro wrap-buf-output ((buffer) &body body) ;; Error recovery wrapper `(unless (buffer-dead ,buffer) ,@body)) (defmacro wrap-buf-input ((buffer) &body body) (declare (ignore buffer)) ;; Error recovery wrapper `(progn ,@body)) ;;;---------------------------------------------------------------------------- ;;; System dependent IO primitives ;;; Functions for opening, reading writing forcing-output and closing ;;; the stream to the server. ;;;---------------------------------------------------------------------------- ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X ;;; server (defun open-x-stream (host display protocol) (declare (ignore protocol)) (let ((local-socket-path (unix-socket-path-from-host host display))) (if local-socket-path (ccl::make-socket :connect :active :address-family :file :remote-filename local-socket-path) (ccl::make-socket :connect :active :remote-host host :remote-port (+ 6000 display))))) ;;; BUFFER-READ-DEFAULT - read data from the X stream (defun buffer-read-default (display vector start end timeout) (declare (type display display) (type buffer-bytes vector) (type array-index start end) (type (or null (real 0 *)) timeout)) #.(declare-buffun) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (or (cond ((null stream)) ((listen stream) nil) ((and timeout (= timeout 0)) :timeout) ((buffer-input-wait-default display timeout))) (progn (ccl:stream-read-ivector stream vector start (- end start)) nil)))) ;;; BUFFER-WRITE-DEFAULT - write data to the X stream (defun buffer-write-default (vector display start end) (declare (type buffer-bytes vector) (type display display) (type array-index start end)) #.(declare-buffun) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (ccl:stream-write-ivector stream vector start (- end start))) nil)) ;;; buffer-force-output-default - force output to the X stream (defun buffer-force-output-default (display) ;; The default buffer force-output function for use with common-lisp streams (declare (type display display)) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (force-output stream)))) ;;; BUFFER-CLOSE-DEFAULT - close the X stream (defun buffer-close-default (display &key abort) ;; The default buffer close function for use with common-lisp streams (declare (type display display)) #.(declare-buffun) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (close stream :abort abort)))) ;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the ;;; buffer. This is called in read-input between requests, so that a process ;;; waiting for input is abortable when between requests. Should return ;;; :TIMEOUT if it times out, NIL otherwise. (defun buffer-input-wait-default (display timeout) (declare (type display display) (type (or null number) timeout)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (cond ((null stream)) ((listen stream) nil) ((eql timeout 0) :timeout) (t (let* ((fd (ccl::stream-device stream :input)) (ticks (and timeout (floor (* timeout ccl::*ticks-per-second*))))) (if (ccl::process-input-wait fd ticks) nil :timeout)))))) ;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the ;;; buffer. This should never block, so it can be called from the scheduler. ;;; The default implementation is to just use listen. (defun buffer-listen-default (display) (declare (type display display)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (if (null stream) t (listen stream)))) ;;;---------------------------------------------------------------------------- ;;; System dependent speed hacks ;;;---------------------------------------------------------------------------- ;; ;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature. ;; If your lisp doesn't have stack-lists, and you're worried about ;; consing garbage, you may want to re-write this to allocate and ;; initialize lists from a resource. ;; (defmacro with-stack-list ((var &rest elements) &body body) ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body) ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body) ;; except that the list produced by MAPCAR resides on the stack and ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list ,@elements))) (declare (type cons ,var) #+clx-ansi-common-lisp (dynamic-extent ,var)) ,@body)) (defmacro with-stack-list* ((var &rest elements) &body body) ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body) ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body) ;; except that the list produced by MAPCAR resides on the stack and ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list* ,@elements))) (declare (type cons ,var) (dynamic-extent ,var)) ,@body)) (declaim (inline buffer-replace)) (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) (declare (type buffer-bytes buf1 buf2) (type array-index start1 end1 start2)) (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) &body body) (let ((local-state (gensym)) (resets nil)) (dolist (index indexes) (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index)) resets)) `(unwind-protect (progn ,@body) (let ((,local-state (gcontext-local-state ,gc))) (declare (type gcontext-state ,local-state)) ,@resets (setf (svref ,local-state ,ts-index) 0)) (when ,temp-gc (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) (deallocate-gcontext-state ,saved-state)))) ;;;---------------------------------------------------------------------------- ;;; How much error detection should CLX do? ;;; Several levels are possible: ;;; ;;; 1. Do the equivalent of check-type on every argument. ;;; ;;; 2. Simply report TYPE-ERROR. This eliminates overhead of all the format ;;; strings generated by check-type. ;;; ;;; 3. Do error checking only on arguments that are likely to have errors ;;; (like keyword names) ;;; ;;; 4. Do error checking only where not doing so may dammage the envirnment ;;; on a non-tagged machine (i.e. when storing into a structure that has ;;; been passed in) ;;; ;;; 5. No extra error detection code. On lispm's, ASET may barf trying to ;;; store a non-integer into a number array. ;;; ;;; How extensive should the error checking be? For example, if the server ;;; expects a CARD16, is is sufficient for CLX to check for integer, or ;;; should it also check for non-negative and less than 65536? ;;;---------------------------------------------------------------------------- ;; The +TYPE-CHECK?+ constant controls how much error checking is done. ;; Possible values are: ;; NIL - Don't do any error checking ;; t - Do the equivalent of checktype on every argument ;; :minimal - Do error checking only where errors are likely ;;; This controls macro expansion, and isn't changable at run-time You will ;;; probably want to set this to nil if you want good performance at ;;; production time. (defconstant +type-check?+ nil) ;; TYPE? is used to allow the code to do error checking at a different level from ;; the declarations. It also does some optimizations for systems that don't have ;; good compiler support for TYPEP. The definitions for CARD32, CARD16, INT16, etc. ;; include range checks. You can modify TYPE? to do less extensive checking ;; for these types if you desire. ;; ;; ### This comment is a lie! TYPE? is really also used for run-time type ;; dispatching, not just type checking. -- Ram. (defmacro type? (object type) (if (not (constantp type)) `(typep ,object ,type) (progn (setq type (eval type)) (let ((predicate (assoc type '((drawable drawable-p) (window window-p) (pixmap pixmap-p) (cursor cursor-p) (font font-p) (gcontext gcontext-p) (colormap colormap-p) (null null) (integer integerp))))) (cond (predicate `(,(second predicate) ,object)) ((eq type 'generalized-boolean) 't) ; Everything is a generalized-boolean. (+type-check?+ `(locally (declare (optimize safety)) (typep ,object ',type))) (t `(typep ,object ',type))))))) ;; X-TYPE-ERROR is the function called for type errors. ;; If you want lots of checking, but are concerned about code size, ;; this can be made into a macro that ignores some parameters. (defun x-type-error (object type &optional error-string) (x-error 'x-type-error :datum object :expected-type type :type-string error-string)) ;;----------------------------------------------------------------------------- ;; Error handlers ;; Hack up KMP error signaling using zetalisp until the real thing comes ;; along ;;----------------------------------------------------------------------------- (defun default-error-handler (display error-key &rest key-vals &key asynchronous &allow-other-keys) (declare (type generalized-boolean asynchronous) (dynamic-extent key-vals)) ;; The default display-error-handler. ;; It signals the conditions listed in the DISPLAY file. (if asynchronous (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals) (apply #'x-error error-key :display display :error-key error-key key-vals))) (defun x-error (condition &rest keyargs) (declare (dynamic-extent keyargs)) (apply #'error condition keyargs)) (defun x-cerror (proceed-format-string condition &rest keyargs) (declare (dynamic-extent keyargs)) (apply #'cerror proceed-format-string condition keyargs)) ;; version 15 of Pitman error handling defines the syntax for define-condition to be: ;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*] ;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string) ;; or (:report exp) (define-condition x-error (error) ()) ;;----------------------------------------------------------------------------- ;; HOST hacking ;;----------------------------------------------------------------------------- (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (ecase family ((:internet nil 0) (let* ((addr (ccl::htonl (ccl::host-as-inet-host host)))) (cons :internet (list (ldb (byte 8 24) addr) (ldb (byte 8 16) addr) (ldb (byte 8 8) addr) (ldb (byte 8 0) addr))))))) ;;----------------------------------------------------------------------------- ;; Whether to use closures for requests or not. ;;----------------------------------------------------------------------------- ;;; If this macro expands to non-NIL, then request and locking code is ;;; compiled in a much more compact format, as the common code is shared, and ;;; the specific code is built into a closure that is funcalled by the shared ;;; code. If your compiler makes efficient use of closures then you probably ;;; want to make this expand to T, as it makes the code more compact. (defmacro use-closures () nil) (defun clx-macroexpand (form env) (macroexpand form env)) ;;----------------------------------------------------------------------------- ;; Resource stuff ;;----------------------------------------------------------------------------- ;;; Utilities (defun getenv (name) (ccl::getenv name)) (defun get-host-name () "Return the same hostname as gethostname(3) would" (machine-instance)) (defun homedir-file-pathname (name) (merge-pathnames (user-homedir-pathname) (pathname name))) ;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if ;;; a resource manager isn't running. (defun default-resources-pathname () (homedir-file-pathname ".Xdefaults")) ;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the ;;; defaults have been loaded. (defun resources-pathname () (or (let ((string (getenv "XENVIRONMENT"))) (and string (pathname string))) (homedir-file-pathname (concatenate 'string ".Xdefaults-" (get-host-name))))) ;;; AUTHORITY-PATHNAME - The pathname of the authority file. (defun authority-pathname () (or (let ((xauthority (getenv "XAUTHORITY"))) (and xauthority (pathname xauthority))) (homedir-file-pathname ".Xauthority"))) ;;; this particular defaulting behaviour is typical to most Unices, I think (defun get-default-display (&optional display-name) "Parse the argument DISPLAY-NAME, or the environment variable $DISPLAY if it is NIL. Display names have the format [protocol/] [hostname] : [:] displaynumber [.screennumber] There are two special cases in parsing, to match that done in the Xlib C language bindings - If the hostname is ``unix'' or the empty string, any supplied protocol is ignored and a connection is made using the :local transport. - If a double colon separates hostname from displaynumber, the protocol is assumed to be decnet. Returns a list of (host display-number screen protocol)." (let* ((name (or display-name (getenv "DISPLAY") (error "DISPLAY environment variable is not set"))) (slash-i (or (position #\/ name) -1)) (colon-i (position #\: name :start (1+ slash-i))) (decnet-colon-p (eql (elt name (1+ colon-i)) #\:)) (host (subseq name (1+ slash-i) colon-i)) (dot-i (and colon-i (position #\. name :start colon-i))) (display (when colon-i (parse-integer name :start (if decnet-colon-p (+ colon-i 2) (1+ colon-i)) :end dot-i))) (screen (when dot-i (parse-integer name :start (1+ dot-i)))) (protocol (cond ((or (string= host "") (string-equal host "unix")) :local) (decnet-colon-p :decnet) ((> slash-i -1) (intern (string-upcase (subseq name 0 slash-i)) :keyword)) (t :internet)))) (list host (or display 0) (or screen 0) protocol))) ;;----------------------------------------------------------------------------- ;; GC stuff ;;----------------------------------------------------------------------------- (defun gc-cleanup () (declare (special *event-free-list* *pending-command-free-list* *reply-buffer-free-lists* *gcontext-local-state-cache* *temp-gcontext-cache*)) (setq *event-free-list* nil) (setq *pending-command-free-list* nil) (when (boundp '*reply-buffer-free-lists*) (fill *reply-buffer-free-lists* nil)) (setq *gcontext-local-state-cache* nil) (setq *temp-gcontext-cache* nil) nil) ;;----------------------------------------------------------------------------- ;; DEFAULT-KEYSYM-TRANSLATE ;;----------------------------------------------------------------------------- ;;; If object is a character, char-bits are set from state. ;;; ;;; [the following isn't implemented (should it be?)] ;;; If object is a list, it is an alist with entries: ;;; (base-char [modifiers] [mask-modifiers]) ;;; When MODIFIERS are specified, this character translation ;;; will only take effect when the specified modifiers are pressed. ;;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore. ;;; When MASK-MODIFIERS is missing, all other modifiers are ignored. ;;; In ambiguous cases, the most specific translation is used. (defun default-keysym-translate (display state object) (declare (type display display) (type card16 state) (type t object) (ignore display state) (clx-values t)) object) ;;----------------------------------------------------------------------------- ;; Image stuff ;;----------------------------------------------------------------------------- ;;; Types (deftype pixarray-1-element-type () 'bit) (deftype pixarray-4-element-type () '(unsigned-byte 4)) (deftype pixarray-8-element-type () '(unsigned-byte 8)) (deftype pixarray-16-element-type () '(unsigned-byte 16)) (deftype pixarray-24-element-type () '(unsigned-byte 24)) (deftype pixarray-32-element-type () '(unsigned-byte 32)) (deftype pixarray-1 () '(array pixarray-1-element-type (* *))) (deftype pixarray-4 () '(array pixarray-4-element-type (* *))) (deftype pixarray-8 () '(array pixarray-8-element-type (* *))) (deftype pixarray-16 () '(array pixarray-16-element-type (* *))) (deftype pixarray-24 () '(array pixarray-24-element-type (* *))) (deftype pixarray-32 () '(array pixarray-32-element-type (* *))) (deftype pixarray () '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32)) (deftype bitmap () 'pixarray-1) ;;; WITH-UNDERLYING-SIMPLE-VECTOR (defmacro with-underlying-simple-vector ((variable element-type pixarray) &body body) (declare (ignore element-type)) `(let* ((,variable (ccl::array-data-and-offset ,pixarray))) ,@body)) ;;; These are used to read and write pixels from and to CARD8s. ;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s. (defmacro read-image-load-byte (size position integer) (unless +image-bit-lsb-first-p+ (setq position (- 7 position))) `(the (unsigned-byte ,size) (ldb (byte ,size ,position) (the card8 ,integer)))) ;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from ;;; the appropriate number of CARD8s. (defmacro read-image-assemble-bytes (&rest bytes) (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes))) (let ((it (first bytes)) (count 0)) (dolist (byte (rest bytes)) (setq it `(dpb (the card8 ,byte) (byte 8 ,(incf count 8)) (the (unsigned-byte ,count) ,it)))) `(the (unsigned-byte ,(* (length bytes) 8)) ,it))) ;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit ;;; pixel. (defmacro write-image-load-byte (position integer integer-size) integer-size (unless +image-byte-lsb-first-p+ (setq position (- integer-size 8 position))) `(the card8 (ldb (byte 8 ,position) (the (unsigned-byte ,integer-size) ,integer)))) ;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit ;;; pixels. (defmacro write-image-assemble-bytes (&rest bytes) (unless +image-bit-lsb-first-p+ (setq bytes (reverse bytes))) (let ((size (floor 8 (length bytes))) (it (first bytes)) (count 0)) (dolist (byte (rest bytes)) (setq it `(dpb (the (unsigned-byte ,size) ,byte) (byte ,size ,(incf count size)) (the (unsigned-byte ,count) ,it)))) `(the card8 ,it))) ;;; If you can write fast routines that can read and write pixarrays out of a ;;; buffer-bytes, do it! It makes the image code a lot faster. The ;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines ;;; return T if they can do it, NIL if they can't. ;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s (defun fast-read-pixarray (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (ignore bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)) nil) ;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s (defun fast-write-pixarray (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (ignore bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)) nil) ;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another (defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel) (declare (ignore pixarray copy x y width height bits-per-pixel)) nil) cl-clx-sbcl-0.7.4.20160323.orig/demo/0000755000175000017500000000000012715665272014546 5ustar pdmpdmcl-clx-sbcl-0.7.4.20160323.orig/demo/menu.lisp0000644000175000017500000002765112715665272016416 0ustar pdmpdm;;; -*- 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 (&optional (font-name "fixed")) (let* ((display (open-default-display)) (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))))) cl-clx-sbcl-0.7.4.20160323.orig/demo/clclock.lisp0000644000175000017500000000421412715665272017052 0ustar pdmpdm(defpackage "XCLCLOCK" (:use "CL") (:export "CLOCK")) (in-package "XCLCLOCK") (defvar *display* (xlib:open-default-display)) (defvar *screen* (xlib:display-default-screen *display*)) (defvar *colormap* (xlib:screen-default-colormap *screen*)) (defvar *font* (xlib:open-font *display* "fixed")) (defvar *win*) (multiple-value-bind (width ascent) (xlib:text-extents *font* "XVIIII XXXVIIII XXXVIIII") (setq *win* (xlib:create-window :parent (xlib:screen-root *screen*) :x 512 :y 512 :width (+ 20 width) :height (+ 20 ascent) :background (xlib:alloc-color *colormap* (xlib:lookup-color *colormap* "midnightblue"))))) (defvar *gcontext* (xlib:create-gcontext :drawable *win* :fill-style :solid :background (xlib:screen-white-pixel *screen*) :foreground (xlib:alloc-color *colormap* (xlib:lookup-color *colormap* "yellow")) :font *font*)) (defvar *background* (xlib:create-gcontext :drawable *win* :fill-style :solid :background (xlib:screen-white-pixel *screen*) :foreground (xlib:alloc-color *colormap* (xlib:lookup-color *colormap* "midnightblue")) :font *font*)) (defvar *palette* nil) (defvar *black* (xlib:screen-black-pixel *screen*)) (defun romanize (arg) (if (zerop arg) "O" (format nil "~@R" arg))) (defun clock-string () (multiple-value-bind (s m h) (decode-universal-time (get-universal-time)) (format nil "~a ~a ~a" (romanize h) (romanize m) (romanize s)))) (defun update-clockface () (let ((string (clock-string))) (let ((string-width (xlib:text-width *gcontext* string))) (xlib:draw-rectangle *win* *background* 0 0 (xlib:drawable-width *win*) (xlib:drawable-height *win*) :fill-p) (xlib:draw-glyphs *win* *gcontext* (- (truncate (- (xlib:drawable-width *win*) string-width) 2) 10) (- (xlib:drawable-height *win*) 10) string))) (xlib:display-force-output *display*)) (defun clock () (xlib:map-window *win*) (loop (update-clockface) (sleep 1))) cl-clx-sbcl-0.7.4.20160323.orig/demo/clx-demos.lisp0000644000175000017500000010454612715665272017344 0ustar pdmpdm;;; -*- Mode: Lisp; Package: Demos -*- ;;; ;;; This file contains various graphics hacks written and ported over the ;;; years by various and numerous persons. ;;; ;;; This file should be portable to any valid Common Lisp with CLX -- DEC 88. ;;; (defpackage :demos (:use :common-lisp) (:export do-all-demos demo)) (in-package :demos) ;;;; Graphic demos wrapper macro. ;;; This wrapper macro should be reconsidered with respect to its property ;;; list usage. Possibly a demo structure should be used with *demos* ;;; pointing to these instead of function names. Also, something should ;;; be done about a title window that displays the name of the demo while ;;; it is running. (defparameter *demos* nil) (defvar *display* nil) (defvar *screen* nil) (defvar *root* nil) (defvar *black-pixel* nil) (defvar *white-pixel* nil) (defvar *window* nil) (defmacro defdemo (fun-name demo-name args x y width height doc &rest forms) `(progn (defun ,fun-name ,args ,doc (unless *display* #+:cmu (multiple-value-setq (*display* *screen*) (ext:open-clx-display)) #+(or sbcl allegro clisp lispworks) (progn (setf *display* (xlib::open-default-display)) (setf *screen* (xlib:display-default-screen *display*))) #-(or cmu sbcl allegro clisp lispworks) (progn ;; Portable method (setf *display* (xlib:open-display (machine-instance))) (setf *screen* (xlib:display-default-screen *display*))) (setf *root* (xlib:screen-root *screen*)) (setf *black-pixel* (xlib:screen-black-pixel *screen*)) (setf *white-pixel* (xlib:screen-white-pixel *screen*))) (let ((*window* (xlib:create-window :parent *root* :x ,x :y ,y :event-mask nil :width ,width :height ,height :background *white-pixel* :border *black-pixel* :border-width 2 :override-redirect :on))) (xlib:map-window *window*) ;; ;; I hate to do this since this is not something any normal ;; program should do ... (setf (xlib:window-priority *window*) :above) (xlib:display-finish-output *display*) (unwind-protect (progn ,@forms) (xlib:unmap-window *window*) (xlib:display-finish-output *display*)))) (setf (get ',fun-name 'demo-name) ',demo-name) (setf (get ',fun-name 'demo-doc) ',doc) (export ',fun-name) (pushnew ',fun-name *demos*) ',fun-name)) ;;;; Main entry points. (defun do-all-demos () (loop (dolist (demo *demos*) (funcall demo) (sleep 3)))) ;;; DEMO is a hack to get by. It should be based on creating a menu. At ;;; that time, *name-to-function* should be deleted, since this mapping will ;;; be manifested in the menu slot name cross its action. Also the ;;; "Shove-bounce" demo should be renamed to "Shove bounce"; likewise for ;;; "Fast-towers-of-Hanoi" and "Slow-towers-of-hanoi". ;;; (defvar *name-to-function* (make-hash-table :test #'eq)) (defvar *keyword-package* (find-package "KEYWORD")) (defun demo () (macrolet ((read-demo () `(let ((*package* *keyword-package*)) (read)))) (dolist (d *demos*) (setf (gethash (intern (string-upcase (get d 'demo-name)) *keyword-package*) *name-to-function*) d)) (loop (fresh-line) (dolist (d *demos*) (write-string " ") (write-line (get d 'demo-name))) (write-string " ") (write-line "Help ") (write-string " ") (write-line "Quit") (write-string "Enter demo name: ") (let ((demo (read-demo))) (case demo (:help (let* ((demo (read-demo)) (fun (gethash demo *name-to-function*))) (fresh-line) (if fun (format t "~&~%~A~&~%" (get fun 'demo-doc)) (format t "Unknown demo name -- ~A." demo)))) (:quit (return t)) (t (let ((fun (gethash demo *name-to-function*))) (if fun #+mp (mp:make-process #'(lambda () (loop (funcall fun) (sleep 2))) :name (format nil "~S" demo)) #-mp (funcall fun) (format t "~&~%Unknown demo name -- ~A.~&~%" demo))))))))) ;;;; Shared demo utilities. (defun full-window-state (w) (xlib:with-state (w) (values (xlib:drawable-width w) (xlib:drawable-height w) (xlib:drawable-x w) (xlib:drawable-y w) (xlib:window-map-state w)))) ;;;; Greynetic. ;;; GREYNETIC displays random sized and shaded boxes in a window. This is ;;; real slow. It needs work. ;;; (defun greynetic (window duration) (let* ((pixmap (xlib:create-pixmap :width 32 :height 32 :depth 1 :drawable window)) (gcontext (xlib:create-gcontext :drawable window :background *white-pixel* :foreground *black-pixel* :tile pixmap :fill-style :tiled))) (multiple-value-bind (width height) (full-window-state window) (dotimes (i duration) (let* ((pixmap-data (greynetic-pixmapper)) (image (xlib:create-image :width 32 :height 32 :depth 1 :data pixmap-data))) (xlib:put-image pixmap gcontext image :x 0 :y 0 :width 32 :height 32) (xlib:draw-rectangle window gcontext (- (random width) 5) (- (random height) 5) (+ 4 (random (truncate width 3))) (+ 4 (random (truncate height 3))) t)) (xlib:display-force-output *display*))) (xlib:free-gcontext gcontext) (xlib:free-pixmap pixmap))) (defvar *greynetic-pixmap-array* (make-array '(32 32) :initial-element 0 :element-type 'xlib:pixel)) (defun greynetic-pixmapper () (let ((pixmap-data *greynetic-pixmap-array*)) (dotimes (i 4) (declare (fixnum i)) (let ((nibble (random 16))) (setf nibble (logior nibble (ash nibble 4)) nibble (logior nibble (ash nibble 8)) nibble (logior nibble (ash nibble 12)) nibble (logior nibble (ash nibble 16))) (dotimes (j 32) (let ((bit (if (logbitp j nibble) 1 0))) (setf (aref pixmap-data i j) bit (aref pixmap-data (+ 4 i) j) bit (aref pixmap-data (+ 8 i) j) bit (aref pixmap-data (+ 12 i) j) bit (aref pixmap-data (+ 16 i) j) bit (aref pixmap-data (+ 20 i) j) bit (aref pixmap-data (+ 24 i) j) bit (aref pixmap-data (+ 28 i) j) bit))))) pixmap-data)) #+nil (defdemo greynetic-demo "Greynetic" (&optional (duration 300)) 100 100 600 600 "Displays random grey rectangles." (greynetic *window* duration)) ;;;; Qix. (defstruct qix buffer (dx1 5) (dy1 10) (dx2 10) (dy2 5)) (defun construct-qix (length) (let ((qix (make-qix))) (setf (qix-buffer qix) (make-circular-list length)) qix)) (defun make-circular-list (length) (let ((l (make-list length))) (rplacd (last l) l))) (defun qix (window lengths duration) "Each length is the number of lines to put in a qix, and that many qix (of the correct size) are put up on the screen. Lets the qix wander around the screen for Duration steps." (let ((histories (mapcar #'construct-qix lengths))) (multiple-value-bind (width height) (full-window-state window) (declare (fixnum width height)) (xlib:clear-area window) (xlib:display-force-output *display*) (do ((h histories (cdr h)) (l lengths (cdr l))) ((null h)) (do ((x (qix-buffer (car h)) (cdr x)) (i 0 (1+ i))) ((= i (car l))) (rplaca x (make-array 4)))) ;; Start each qix at a random spot on the screen. (dolist (h histories) (let ((x (random width)) (y (random height))) (rplaca (qix-buffer h) (make-array 4 :initial-contents (list x y x y))))) (rplacd (last histories) histories) (let ((x1 0) (y1 0) (x2 0) (y2 0) (dx1 0) (dy1 0) (dx2 0) (dy2 0) tem line next-line qix (gc (xlib:create-gcontext :drawable window :foreground *white-pixel* :background *black-pixel* :line-width 0 :line-style :solid :function boole-c2))) (declare (fixnum x1 y1 x2 y2 dx1 dy1 dx2 dy2)) (dotimes (i duration) ;; Line is the next line in the next qix. Rotate this qix and ;; the qix ring. (setq qix (car histories)) (setq line (car (qix-buffer qix))) (setq next-line (cadr (qix-buffer qix))) (setf (qix-buffer qix) (cdr (qix-buffer qix))) (setq histories (cdr histories)) (setf x1 (svref line 0)) (setf y1 (svref line 1)) (setf x2 (svref line 2)) (setf y2 (svref line 3)) (xlib:draw-line window gc x1 y1 x2 y2) (setq dx1 (- (+ (qix-dx1 qix) (random 3)) 1)) (setq dy1 (- (+ (qix-dy1 qix) (random 3)) 1)) (setq dx2 (- (+ (qix-dx2 qix) (random 3)) 1)) (setq dy2 (- (+ (qix-dy2 qix) (random 3)) 1)) (cond ((> dx1 10) (setq dx1 10)) ((< dx1 -10) (setq dx1 -10))) (cond ((> dy1 10) (setq dy1 10)) ((< dy1 -10) (setq dy1 -10))) (cond ((> dx2 10) (setq dx2 10)) ((< dx2 -10) (setq dx2 -10))) (cond ((> dy2 10) (setq dy2 10)) ((< dy2 -10) (setq dy2 -10))) (cond ((or (>= (setq tem (+ x1 dx1)) width) (minusp tem)) (setq dx1 (- dx1)))) (cond ((or (>= (setq tem (+ x2 dx2)) width) (minusp tem)) (setq dx2 (- dx2)))) (cond ((or (>= (setq tem (+ y1 dy1)) height) (minusp tem)) (setq dy1 (- dy1)))) (cond ((or (>= (setq tem (+ y2 dy2)) height) (minusp tem)) (setq dy2 (- dy2)))) (setf (qix-dy2 qix) dy2) (setf (qix-dx2 qix) dx2) (setf (qix-dy1 qix) dy1) (setf (qix-dx1 qix) dx1) ` (when (svref next-line 0) (xlib:draw-line window gc (svref next-line 0) (svref next-line 1) (svref next-line 2) (svref next-line 3))) (setf (svref next-line 0) (+ x1 dx1)) (setf (svref next-line 1) (+ y1 dy1)) (setf (svref next-line 2) (+ x2 dx2)) (setf (svref next-line 3) (+ y2 dy2)) (xlib:display-force-output *display*)))))) (defdemo qix-demo "Qix" (&optional (lengths '(30 30)) (duration 2000)) 0 0 700 700 "Hypnotic wandering lines." (qix *window* lengths duration)) ;;;; Petal. ;;; Fast sine constants: (defconstant d360 #o5500) (defconstant d270 #o4160) (defconstant d180 #o2640) (defconstant d90 #o1320) (defconstant vecmax 2880) (defparameter sin-array '#(#o0 #o435 #o1073 #o1531 #o2166 #o2623 #o3260 #o3714 #o4350 #o5003 #o5435 #o6066 #o6516 #o7145 #o7573 #o10220 #o10644 #o11266 #o11706 #o12326 #o12743 #o13357 #o13771 #o14401 #o15007 #o15414 #o16016 #o16416 #o17013 #o17407 #o20000 #o20366 #o20752 #o21333 #o21711 #o22265 #o22636 #o23204 #o23546 #o24106 #o24443 #o24774 #o25323 #o25645 #o26165 #o26501 #o27011 #o27316 #o27617 #o30115 #o30406 #o30674 #o31156 #o31434 #o31706 #o32154 #o32416 #o32654 #o33106 #o33333 #o33554 #o33771 #o34202 #o34406 #o34605 #o35000 #o35167 #o35351 #o35526 #o35677 #o36043 #o36203 #o36336 #o36464 #o36605 #o36721 #o37031 #o37134 #o37231 #o37322 #o37407 #o37466 #o37540 #o37605 #o37646 #o37701 #o37730 #o37751 #o37766 #o37775 #o40000)) (defmacro psin (val) `(let* ((val ,val) neg frac sinlo) (if (>= val d180) (setq neg t val (- val d180))) (if (>= val d90) (setq val (- d180 val))) (setq frac (logand val 7)) (setq val (ash val -3)) ;; (setq sinlo (if (>= val 90) (svref sin-array 90) (svref sin-array val))) ;; (if (< val 90) (setq sinlo (+ sinlo (ash (* frac (- (svref sin-array (1+ val)) sinlo)) -3)))) ;; (if neg (- sinlo) sinlo))) (defmacro pcos (x) `(let ((tmp (- ,x d270))) (psin (if (minusp tmp) (+ tmp d360) tmp)))) ;;;; Miscellaneous petal hackery. (defmacro high-16bits-* (a b) `(let ((a-h (ash ,a -8)) (b-h (ash ,b -8))) (+ (* a-h b-h) (ash (* a-h (logand ,b 255)) -8) (ash (* b-h (logand ,a 255)) -8)))) (defun complete (style petal) (let ((repnum 1) factor cntval needed) (dotimes (i 3) (case i (0 (setq factor 2 cntval 6)) (1 (setq factor 3 cntval 2)) (2 (setq factor 5 cntval 1))) (do () ((or (minusp cntval) (not (zerop (rem style factor))))) (setq repnum (* repnum factor)) (setq cntval (1- cntval)) (setq style (floor style factor)))) (setq needed (floor vecmax repnum)) (if (and (not (oddp needed)) (oddp petal)) (floor needed 2) needed))) ;;;; Petal Parameters and Petal itself (defparameter continuous t) (defparameter styinc 2) (defparameter petinc 1) (defparameter scalfac-fac 8192) (defun petal (petal-window &optional (how-many 10) (style 0) (petal 0)) (let ((width 512) (height 512)) (xlib:clear-area petal-window) (xlib:display-force-output *display*) (let ((veccnt 0) (nustyle 722) (nupetal 3) (scalfac (1+ (floor scalfac-fac (min width height)))) (ctrx (floor width 2)) (ctry (floor height 2)) (tt 0) (s 0) (lststyle 0) (lstpetal 0) (petstyle 0) (vectors 0) (r 0) (x1 0) (y1 0) (x2 0) (y2 0) (i 0) (gc (xlib:create-gcontext :drawable petal-window :foreground *black-pixel* :background *white-pixel* :line-width 0 :line-style :solid))) (loop (when (zerop veccnt) (setq tt 0 s 0 lststyle style lstpetal petal petal nupetal style nustyle petstyle (rem (* petal style) d360) vectors (complete style petal)) (when continuous (setq nupetal (+ nupetal petinc) nustyle (+ nustyle styinc))) (when (or (/= lststyle style) (/= lstpetal petal)) (xlib:clear-area petal-window) (xlib:display-force-output *display*))) (when (or (/= lststyle style) (/= lstpetal petal)) (setq veccnt (1+ veccnt) i veccnt x1 x2 y1 y2 tt (rem (+ tt style) d360) s (rem (+ s petstyle) d360) r (pcos s)) (setq x2 (+ ctrx (floor (high-16bits-* (pcos tt) r) scalfac)) y2 (+ ctry (floor (high-16bits-* (psin tt) r) scalfac))) (when (/= i 1) (xlib:draw-line petal-window gc x1 y1 x2 y2) (xlib:display-force-output *display*))) (when (> veccnt vectors) (setq veccnt 0) (setq how-many (1- how-many)) (sleep 2) (when (zerop how-many) (return))))))) (defdemo petal-demo "Petal" (&optional (how-many 10) (style 0) (petal 0)) 100 100 512 512 "Flower-like display." (petal *window* how-many style petal)) ;;;; Hanoi. ;;; Random parameters: (defparameter disk-thickness 15 "The thickness of a disk in pixels.") (defparameter disk-spacing (+ disk-thickness 3) "The amount of vertical space used by a disk on a needle.") (defvar *horizontal-velocity* 20 "The speed at which disks slide sideways.") (defvar *vertical-velocity* 12 "The speed at which disks move up and down.") ;;; These variables are bound by the main function. (defvar *hanoi-window* () "The window that Hanoi is happening on.") (defvar *hanoi-window-height* () "The height of the viewport Hanoi is happening on.") (defvar *transfer-height* () "The height at which disks are transferred.") (defvar *hanoi-gcontext* () "The graphics context for Hanoi under X11.") ;;; Needle Functions (defstruct disk size) (defstruct needle position disk-stack) ;;; Needle-Top-Height returns the height of the top disk on NEEDLE. (defun needle-top-height (needle) (- *hanoi-window-height* (* disk-spacing (length (the list (needle-disk-stack needle)))))) (defvar available-disks (do ((i 10 (+ i 10)) (dlist () (cons (make-disk :size i) dlist))) ((> i 80) dlist))) (defvar needle-1 (make-needle :position 184)) (defvar needle-2 (make-needle :position 382)) (defvar needle-3 (make-needle :position 584)) ;;; Graphic interface abstraction: ;;; Invert-Rectangle calls the CLX function draw-rectangle with "fill-p" ;;; set to T. Update-Screen forces the display output. ;;; (defmacro invert-rectangle (x y height width) `(xlib:draw-rectangle *hanoi-window* *hanoi-gcontext* ,x ,y ,width ,height t)) (defmacro update-screen () `(xlib:display-force-output *display*)) ;;;; Moving disks up and down ;;; Slide-Up slides the image of a disk up from the coordinates X, ;;; START-Y to the point X, END-Y. DISK-SIZE is the size of the disk to ;;; move. START-Y must be greater than END-Y (defun slide-up (start-y end-y x disk-size) (multiple-value-bind (number-moves pixels-left) (truncate (- start-y end-y) *vertical-velocity*) (do ((x (- x disk-size)) (width (* disk-size 2)) (old-y start-y (- old-y *vertical-velocity*)) (new-y (- start-y *vertical-velocity*) (- new-y *vertical-velocity*)) (number-moves number-moves (1- number-moves))) ((zerop number-moves) (when (plusp pixels-left) (invert-rectangle x (- old-y pixels-left) disk-thickness width) (invert-rectangle x old-y disk-thickness width) (update-screen))) ;; Loop body writes disk at new height & erases at old height. (invert-rectangle x old-y disk-thickness width) (invert-rectangle x new-y disk-thickness width) (update-screen)))) ;;; Slide-Down slides the image of a disk down from the coordinates X, ;;; START-Y to the point X, END-Y. DISK-SIZE is the size of the disk to ;;; move. START-Y must be less than END-Y. (defun slide-down (start-y end-y x disk-size) (multiple-value-bind (number-moves pixels-left) (truncate (- end-y start-y) *vertical-velocity*) (do ((x (- x disk-size)) (width (* disk-size 2)) (old-y start-y (+ old-y *vertical-velocity*)) (new-y (+ start-y *vertical-velocity*) (+ new-y *vertical-velocity*)) (number-moves number-moves (1- number-moves))) ((zerop number-moves) (when (plusp pixels-left) (invert-rectangle x (+ old-y pixels-left) disk-thickness width) (invert-rectangle x old-y disk-thickness width) (update-screen))) ;; Loop body writes disk at new height & erases at old height. (invert-rectangle X old-y disk-thickness width) (invert-rectangle X new-y disk-thickness width) (update-screen)))) ;;;; Lifting and Droping Disks ;;; Lift-disk pops the top disk off of needle and raises it up to the ;;; transfer height. The disk is returned. (defun lift-disk (needle) "Pops the top disk off of NEEDLE, Lifts it above the needle, & returns it." (let* ((height (needle-top-height needle)) (disk (pop (needle-disk-stack needle)))) (slide-up height *transfer-height* (needle-position needle) (disk-size disk)) disk)) ;;; Drop-disk drops a disk positioned over needle at the transfer height ;;; onto needle. The disk is pushed onto needle. (defun drop-disk (disk needle) "DISK must be positioned above NEEDLE. It is dropped onto NEEDLE." (push disk (needle-disk-stack needle)) (slide-down *transfer-height* (needle-top-height needle) (needle-position needle) (disk-size disk)) t) ;;; Drop-initial-disk is the same as drop-disk except that the disk is ;;; drawn once before dropping. (defun drop-initial-disk (disk needle) "DISK must be positioned above NEEDLE. It is dropped onto NEEDLE." (let* ((size (disk-size disk)) (lx (- (needle-position needle) size))) (invert-rectangle lx *transfer-height* disk-thickness (* size 2)) (push disk (needle-disk-stack needle)) (slide-down *transfer-height* (needle-top-height needle) (needle-position needle) (disk-size disk)) t)) ;;;; Sliding Disks Right and Left ;;; Slide-Right slides the image of a disk located at START-X, Y to the ;;; position END-X, Y. DISK-SIZE is the size of the disk. START-X is ;;; less than END-X. (defun slide-right (start-x end-x Y disk-size) (multiple-value-bind (number-moves pixels-left) (truncate (- end-x start-x) *horizontal-velocity*) (do ((right-x (+ start-x disk-size) (+ right-x *horizontal-velocity*)) (left-x (- start-x disk-size) (+ left-x *horizontal-velocity*)) (number-moves number-moves (1- number-moves))) ((zerop number-moves) (when (plusp pixels-left) (invert-rectangle right-x Y disk-thickness pixels-left) (invert-rectangle left-x Y disk-thickness pixels-left) (update-screen))) ;; Loop body adds chunk *horizontal-velocity* pixels wide to right ;; side of disk, then chops off left side. (invert-rectangle right-x Y disk-thickness *horizontal-velocity*) (invert-rectangle left-x Y disk-thickness *horizontal-velocity*) (update-screen)))) ;;; Slide-Left is the same as Slide-Right except that START-X is greater ;;; than END-X. (defun slide-left (start-x end-x Y disk-size) (multiple-value-bind (number-moves pixels-left) (truncate (- start-x end-x) *horizontal-velocity*) (do ((right-x (- (+ start-x disk-size) *horizontal-velocity*) (- right-x *horizontal-velocity*)) (left-x (- (- start-x disk-size) *horizontal-velocity*) (- left-x *horizontal-velocity*)) (number-moves number-moves (1- number-moves))) ((zerop number-moves) (when (plusp pixels-left) (setq left-x (- (+ left-x *horizontal-velocity*) pixels-left)) (setq right-x (- (+ right-x *horizontal-velocity*) pixels-left)) (invert-rectangle left-x Y disk-thickness pixels-left) (invert-rectangle right-x Y disk-thickness pixels-left) (update-screen))) ;; Loop body adds chunk *horizontal-velocity* pixels wide to left ;; side of disk, then chops off right side. (invert-rectangle left-x Y disk-thickness *horizontal-velocity*) (invert-rectangle right-x Y disk-thickness *horizontal-velocity*) (update-screen)))) ;;;; Transferring Disks ;;; Transfer disk slides a disk at the transfer height from a position ;;; over START-NEEDLE to a position over END-NEEDLE. Modified disk is ;;; returned. (defun transfer-disk (disk start-needle end-needle) "Moves DISK from a position over START-NEEDLE to a position over END-NEEDLE." (let ((start (needle-position start-needle)) (end (needle-position end-needle))) (if (< start end) (slide-right start end *transfer-height* (disk-size disk)) (slide-left start end *transfer-height* (disk-size disk))) disk)) ;;; Move-One-Disk moves the top disk from START-NEEDLE to END-NEEDLE. (defun move-one-disk (start-needle end-needle) "Moves the disk on top of START-NEEDLE to the top of END-NEEDLE." (drop-disk (transfer-disk (lift-disk start-needle) start-needle end-needle) end-needle) t) ;;; Move-N-Disks moves the top N disks from START-NEEDLE to END-NEEDLE ;;; obeying the rules of the towers of hannoi problem. To move the ;;; disks, a third needle, TEMP-NEEDLE, is needed for temporary storage. (defun move-n-disks (n start-needle end-needle temp-needle) "Moves the top N disks from START-NEEDLE to END-NEEDLE. Uses TEMP-NEEDLE for temporary storage." (cond ((= n 1) (move-one-disk start-needle end-needle)) (t (move-n-disks (1- n) start-needle temp-needle end-needle) (move-one-disk start-needle end-needle) (move-n-disks (1- n) temp-needle end-needle start-needle))) t) ;;;; Hanoi itself. (defun hanoi (window n) (multiple-value-bind (width height) (full-window-state window) (declare (ignore width)) (let* ((*hanoi-window* window) (*hanoi-window-height* height) (*transfer-height* (- height (* disk-spacing n))) (*hanoi-gcontext* (xlib:create-gcontext :drawable *hanoi-window* :foreground *white-pixel* :background *black-pixel* :fill-style :solid :function boole-c2))) (xlib:clear-area *hanoi-window*) (xlib:display-force-output *display*) (let ((needle-1 (make-needle :position 184)) (needle-2 (make-needle :position 382)) (needle-3 (make-needle :position 584))) (setf (needle-disk-stack needle-1) ()) (setf (needle-disk-stack needle-2) ()) (setf (needle-disk-stack needle-3) ()) (do ((n n (1- n)) (available-disks available-disks (cdr available-disks))) ((zerop n)) (drop-initial-disk (car available-disks) needle-1)) (move-n-disks n needle-1 needle-3 needle-2) t)))) ;;; Change the names of these when the DEMO loop isn't so stupid. ;;; (defdemo slow-hanoi-demo "Slow-towers-of-Hanoi" (&optional (how-many 4)) 0 100 768 300 "Solves the Towers of Hanoi problem before your very eyes." (let ((*horizontal-velocity* 3) (*vertical-velocity* 1)) (hanoi *window* how-many))) ;;; (defdemo fast-hanoi-demo "Fast-towers-of-Hanoi" (&optional (how-many 7)) 0 100 768 300 "Solves the Towers of Hanoi problem before your very eyes." (hanoi *window* how-many)) ;;;; Bounce window. ;;; BOUNCE-WINDOW takes a window and seemingly drops it to the bottom of ;;; the screen. Optionally, the window can have an initial x velocity, ;;; screen border elasticity, and gravity value. The outer loop is ;;; entered the first time with the window at its initial height, but ;;; each iteration after this, the loop starts with the window at the ;;; bottom of the screen heading upward. The inner loop, except for the ;;; first execution, carries the window up until the negative velocity ;;; becomes positive, carrying the window down to bottom when the ;;; velocity is positive. Due to number lossage, ROUND'ing and ;;; TRUNC'ing when the velocity gets so small will cause the window to ;;; head upward with the same velocity over two iterations which will ;;; cause the window to bounce forever, so we have prev-neg-velocity and ;;; number-problems to check for this. This is not crucial with the x ;;; velocity since the loop terminates as a function of the y velocity. ;;; (defun bounce-window (window &optional (x-velocity 0) (elasticity 0.85) (gravity 2)) (unless (< 0 elasticity 1) (error "Elasticity must be between 0 and 1.")) (unless (plusp gravity) (error "Gravity must be positive.")) (multiple-value-bind (width height x y mapped) (full-window-state window) (when (eq mapped :viewable) (let ((top-of-window-at-bottom (- (xlib:drawable-height *root*) height)) (left-of-window-at-right (- (xlib:drawable-width *root*) width)) (y-velocity 0) (prev-neg-velocity most-negative-fixnum) (number-problems nil)) (declare (fixnum top-of-window-at-bottom left-of-window-at-right y-velocity)) (loop (when (= prev-neg-velocity 0) (return t)) (let ((negative-velocity (minusp y-velocity))) (loop (let ((next-y (+ y y-velocity)) (next-y-velocity (+ y-velocity gravity))) (declare (fixnum next-y next-y-velocity)) (when (> next-y top-of-window-at-bottom) (cond (number-problems (setf y-velocity (incf prev-neg-velocity))) (t (setq y-velocity (- (truncate (* elasticity y-velocity)))) (when (= y-velocity prev-neg-velocity) (incf y-velocity) (setf number-problems t)) (setf prev-neg-velocity y-velocity))) (setf y top-of-window-at-bottom) (setf (xlib:drawable-x window) x (xlib:drawable-y window) y) (xlib:display-force-output *display*) (return)) (setq y-velocity next-y-velocity) (setq y next-y)) (when (and negative-velocity (>= y-velocity 0)) (setf negative-velocity nil)) (let ((next-x (+ x x-velocity))) (declare (fixnum next-x)) (when (or (> next-x left-of-window-at-right) (< next-x 0)) (setq x-velocity (- (truncate (* elasticity x-velocity))))) (setq x next-x)) (setf (xlib:drawable-x window) x (xlib:drawable-y window) y) (xlib:display-force-output *display*)))))))) ;;; Change the name of this when DEMO is not so stupid. ;;; (defdemo shove-bounce-demo "Shove-bounce" () 100 100 300 300 "Drops the demo window with an inital X velocity which bounces off screen borders." (bounce-window *window* 30)) (defdemo bounce-demo "Bounce" () 100 100 300 300 "Drops the demo window which bounces off screen borders." (bounce-window *window*)) ;;;; Recurrence Demo ;;; Copyright (C) 1988 Michael O. Newton (newton@csvax.caltech.edu) ;;; 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. ;;; The author provides this software "as is" without express or ;;; implied warranty. ;;; This routine plots the recurrence ;;; x <- y(1+sin(0.7x)) - 1.2(|x|)^.5 ;;; y <- .21 - x ;;; As described in a ?? 1983 issue of the Mathematical Intelligencer (defun recurrence (display window &optional (point-count 10000)) (let ((gc (xlib:create-gcontext :drawable window :background *white-pixel* :foreground *black-pixel*))) (multiple-value-bind (width height) (full-window-state window) (xlib:clear-area window) (draw-ppict window gc point-count 0.0 0.0 (* width 0.5) (* height 0.5)) (xlib:display-force-output display) (sleep 4)) (xlib:free-gcontext gc))) ;;; Draw points. X assumes points are in the range of width x height, ;;; with 0,0 being upper left and 0,H being lower left. ;;; hw and hh are half-width and half-height of screen (defun draw-ppict (win gc count x y hw hh) "Recursively draw pretty picture" (unless (zerop count) (let ((xf (floor (* (+ 1.0 x) hw ))) ;These lines center the picture (yf (floor (* (+ 0.7 y) hh )))) (xlib:draw-point win gc xf yf) (draw-ppict win gc (1- count) (- (* y (1+ (sin (* 0.7 x)))) (* 1.2 (sqrt (abs x)))) (- 0.21 x) hw hh)))) (defdemo recurrence-demo "Recurrence" () 10 10 700 700 "Plots a cool recurrence relation." (recurrence *display* *window*)) ;;;; Plaid ;;; ;;; Translated from the X11 Plaid Demo written in C by Christopher Hoover. ;;; (defmacro rect-x (rects n) `(svref ,rects (ash ,n 2))) (defmacro rect-y (rects n) `(svref ,rects (+ (ash ,n 2) 1))) (defmacro rect-width (rects n) `(svref ,rects (+ (ash ,n 2) 2))) (defmacro rect-height (rects n) `(svref ,rects (+ (ash ,n 2) 3))) (defun plaid (display window &optional (num-iterations 10000) (num-rectangles 10)) (let ((gcontext (xlib:create-gcontext :drawable window :function boole-c2 :plane-mask (logxor *white-pixel* *black-pixel*) :background *white-pixel* :foreground *black-pixel* :fill-style :solid)) (rectangles (make-array (* 4 num-rectangles) :element-type 'number :initial-element 0))) (multiple-value-bind (width height) (full-window-state window) (let ((center-x (ash width -1)) (center-y (ash height -1)) (x-dir -2) (y-dir -2) (x-off 2) (y-off 2)) (dotimes (iter (truncate num-iterations num-rectangles)) (dotimes (i num-rectangles) (setf (rect-x rectangles i) (- center-x x-off)) (setf (rect-y rectangles i) (- center-y y-off)) (setf (rect-width rectangles i) (ash x-off 1)) (setf (rect-height rectangles i) (ash y-off 1)) (incf x-off x-dir) (incf y-off y-dir) (when (or (<= x-off 0) (>= x-off center-x)) (decf x-off (ash x-dir 1)) (setf x-dir (- x-dir))) (when (or (<= y-off 0) (>= y-off center-y)) (decf y-off (ash y-dir 1)) (setf y-dir (- y-dir)))) (xlib:draw-rectangles window gcontext rectangles t) (xlib:display-force-output display)))) (xlib:free-gcontext gcontext))) (defdemo plaid-demo "Plaid" (&optional (iterations 10000) (num-rectangles 10)) 10 10 101 201 "Plaid, man." (plaid *display* *window* iterations num-rectangles)) ;;;; Bball demo ;;; ;;; Ported to CLX by Blaine Burks ;;; (defvar *ball-size-x* 38) (defvar *ball-size-y* 34) (defmacro xor-ball (pixmap window gcontext x y) `(xlib:copy-area ,pixmap ,gcontext 0 0 *ball-size-x* *ball-size-y* ,window ,x ,y)) (defconstant bball-gravity 1) (defconstant maximum-x-drift 7) (defvar *max-bball-x*) (defvar *max-bball-y*) (defstruct ball (x (random (- *max-bball-x* *ball-size-x*))) (y (random (- *max-bball-y* *ball-size-y*))) (dx (if (zerop (random 2)) (random maximum-x-drift) (- (random maximum-x-drift)))) (dy 0)) (defun get-bounce-image () "Returns the pixmap to be bounced around the screen." (xlib::bitmap-image #*000000000000000000000000000000000000 #*000000000000000000000000000000000000 #*000000000000000000001000000010000000 #*000000000000000000000000000100000000 #*000000000000000000000100001000000000 #*000000000000000010000000010000000000 #*000000000000000000100010000000000000 #*000000000000000000001000000000000000 #*000000000001111100000000000101010000 #*000000000010000011000111000000000000 #*000000000100000000111000000000000000 #*000000000100000000000000000100000000 #*000000000100000000001000100010000000 #*000000111111100000010000000001000000 #*000000111111100000100000100000100000 #*000011111111111000000000000000000000 #*001111111111111110000000100000000000 #*001111111111111110000000000000000000 #*011111111111111111000000000000000000 #*011111111111111111000000000000000000 #*111111111111110111100000000000000000 #*111111111111111111100000000000000000 #*111111111111111101100000000000000000 #*111111111111111101100000000000000000 #*111111111111111101100000000000000000 #*111111111111111111100000000000000000 #*111111111111110111100000000000000000 #*011111111111111111000000000000000000 #*011111111111011111000000000000000000 #*001111111111111110000000000000000000 #*001111111111111110000000000000000000 #*000011111111111000000000000000000000 #*000000111111100000000000000000000000 #*000000000000000000000000000000000000)) (defun bounce-1-ball (pixmap window gcontext ball) (let ((x (ball-x ball)) (y (ball-y ball)) (dx (ball-dx ball)) (dy (ball-dy ball))) (xor-ball pixmap window gcontext x y) (setq x (+ x dx)) (setq y (+ y dy)) (if (or (< x 0) (> x (- *max-bball-x* *ball-size-x*))) (setq x (- x dx) dx (- dx))) (if (> y (- *max-bball-y* *ball-size-y*)) (setq y (- y dy) dy (- dy))) (setq dy (+ dy bball-gravity)) (setf (ball-x ball) x) (setf (ball-y ball) y) (setf (ball-dx ball) dx) (setf (ball-dy ball) dy) (xor-ball pixmap window gcontext x y))) (defun bounce-balls (display window how-many duration) (xlib:clear-area window) (xlib:display-force-output display) (multiple-value-bind (*max-bball-x* *max-bball-y*) (full-window-state window) (let* ((balls (do ((i 0 (1+ i)) (list () (cons (make-ball) list))) ((= i how-many) list))) (gcontext (xlib:create-gcontext :drawable window :foreground *white-pixel* :background *black-pixel* :function boole-xor :exposures :off)) (bounce-pixmap (xlib:create-pixmap :width 38 :height 34 :depth 1 :drawable window)) (pixmap-gc (xlib:create-gcontext :drawable bounce-pixmap :foreground *white-pixel* :background *black-pixel*))) (xlib:put-image bounce-pixmap pixmap-gc (get-bounce-image) :x 0 :y 0 :width 38 :height 34) (xlib:free-gcontext pixmap-gc) (dolist (ball balls) (xor-ball bounce-pixmap window gcontext (ball-x ball) (ball-y ball))) (xlib:display-force-output display) (dotimes (i duration) (dolist (ball balls) (bounce-1-ball bounce-pixmap window gcontext ball)) (xlib:display-force-output display)) (xlib:free-pixmap bounce-pixmap) (xlib:free-gcontext gcontext)))) #+nil (defdemo bouncing-ball-demo "Bouncing-Ball" (&optional (how-many 5) (duration 500)) 34 34 700 500 "Bouncing balls in space." (bounce-balls *display* *window* how-many duration)) cl-clx-sbcl-0.7.4.20160323.orig/demo/clipboard.lisp0000644000175000017500000002065012715665272017401 0ustar pdmpdm;;; This is a pretty direct translation of the Xlib selection test ;;; program by Tor Andersson found at ;;; , with ;;; minor enhancements: ;;; ;;; * gdk requestors apparently unconditionally request UTF8_STRING ;;; selections without checking the TARGETS list of the selection ;;; owner -- and apparently even never request anything else. This ;;; seems to be in contradiction with the freedesktop.org draft ;;; specification at ;;; ;;; (linked from ), but this is ;;; the real world and we have to live in it. It would be nice if ;;; someone in the freedesktop community could resolve this. ;;; ;;; * the original C code, in the XSendEvent call, has an event mask ;;; of SelectionNotify. SelectionNotify is not an event mask at ;;; all, however: but the code works "by accident" because ;;; SelectionNotify happens to have value 31, which has enough bits ;;; flipped on that most clients select on at least one of those ;;; events. This bug is fixed below. ;;; ;;; * [ Update 2004-11-29, superseding to some extent the above ] in ;;; fact, these two things are related. ICCCM says that the event ;;; disclaiming the ability to send in a given format should be sent ;;; with an empty event mask ("2.2 Responsibilities of the Selection ;;; Owner"). ;;; ;;; * implemented the ICCCM-required TIMESTAMP and MULTIPLE targets ;;; ;;; As ever with these things, the divisions in intellectual property ;;; between the writer of the original C program, Tor Andersson ;;; (contactable at tor [dot] andersson [at] gmail [dot] com) and the ;;; translator (Christophe Rhodes, csr21 [at] cam [dot] ac [dot] uk) ;;; are murky, probably depend on jurisdiction, and in addition for ;;; such a small work are essentially trivial. To set peoples' minds ;;; at ease, Tor wishes this information to be disseminated as widely ;;; as possible. ;;; Copyright (c) 2004, Christophe Rhodes ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. (defpackage "CLIPBOARD" (:use "CL" "XLIB") (:export "MAIN")) (in-package "CLIPBOARD") ;;; This is "traditional" XLIB style; I don't really know if it's the ;;; best way -- in developing this program, style of XLIB programming ;;; was secondary to achieving First Paste. (defvar *window*) (defvar *time*) (defvar *display*) (defun ownselect () (format t "~&> set-selection-owner~%") (finish-output) (set-selection-owner *display* :primary *window* *time*) (unless (eq *window* (selection-owner *display* :primary)) (write-string "failed to own primary"))) (defun deselect () (format t "~&> unset-selection-owner~%") (finish-output) (set-selection-owner *display* :primary nil *time*) (unless (eq nil (selection-owner *display* :primary)) (write-string "failed to disown primary"))) (defun ask-paste () (format t "~&! deleting properties on window~%") (finish-output) (delete-property *window* :aeclip-target) (delete-property *window* :aeclip-string) (delete-property *window* :aeclip-utf8_string) (delete-property *window* :aeclip-text) (format t "~&> convert-selection TARGETS~%") (finish-output) (convert-selection :primary :targets *window* :aeclip-target) (format t "~&> convert-selection STRING~%") (finish-output) (convert-selection :primary :string *window* :aeclip-string) (format t "~&> convert-selection UTF8_STRING~%") (finish-output) (convert-selection :primary :utf8_string *window* :aeclip-utf8_string) (format t "~&> convert-selection TEXT~%") (finish-output) (convert-selection :primary :text *window* :aeclip-text) nil) (defun recv-paste (property) (multiple-value-bind (data name format) (get-property *window* property) (format t "~&< get-prop ~S " name) (case format (32 (format t "[~{~S~^,~}]" (mapcar (lambda (x) (atom-name *display* x)) data))) (8 (format t "~S" (map 'string 'code-char data))) (t (format t "format=~S data=~S" format data))) (format t "~%") (finish-output) (delete-property *window* property))) (defun send-copy (selection target property requestor time) (flet ((send (target property) (case target ((:string) (format t "~&> sending text data~%") (finish-output) (change-property requestor property "Hello, World (from the CLX clipboard)!" target 8 :transform #'char-code) property) (:targets (format t "~&> sending targets list~%") (finish-output) ;; ARGH. Can't use :TRANSFORM as we scribble over CLX's buffer. (let ((targets (mapcar (lambda (x) (intern-atom *display* x)) '(:targets :timestamp :multiple :string)))) (change-property requestor property targets target 32)) property) (:timestamp (format t "~&> sending timestamp~%") (finish-output) (change-property requestor property (list *time*) target 32) property) (t (format t "~&> sending none~%") (finish-output) nil)))) (case target ;; WARNING: this is untested. I don't know of any clients which ;; use the :MULTIPLE target. (:multiple (let* ((list (get-property requestor property)) (plist (mapcar (lambda (x) (atom-name *display* x)) list))) (loop for (ptarget pproperty) on plist by #'cddr with all-succeeded = t if (send ptarget pproperty) collect ptarget into result and collect pproperty into result else collect nil into result and collect pproperty into result and do (setf all-succeeded nil) finally (unless all-succeeded (let ((new-list (mapcar (lambda (x) (intern-atom *display* x)) result))) (change-property requestor property new-list target 32)))))) (t (setf property (send target property)))) (send-event requestor :selection-notify (make-event-mask) :selection selection :target target :property property :time time :event-window requestor :window requestor))) (defun main () (let* ((*display* (open-default-display)) (screen (display-default-screen *display*)) (*window* (create-window :parent (screen-root screen) :x 10 :y 10 :width 200 :height 200 :event-mask (make-event-mask :button-press :property-change)))) (map-window *window*) (display-finish-output *display*) (event-case (*display*) (:button-press (code time) (format t "~&ButtonPress~%") (finish-output) (case code (1 (setf *time* time) (ownselect)) (2 (ask-paste)) (3 (deselect)))) (:client-message () (format t "~&ClientMessage~%") (finish-output)) (:selection-clear (selection) (format t "~&SelectionClear ~S~%" selection) (finish-output)) (:selection-notify (selection target property) (format t "~&SelectionNotify ~S ~S ~S~%" selection target property) (finish-output) (unless (eq property nil) (recv-paste property)) (display-finish-output *display*)) (:selection-request (selection target property requestor time) (format t "~&SelectionRequest ~S ~S ~S~%" selection target property) (finish-output) (send-copy selection target property requestor time) (display-finish-output *display*)) (:property-notify (atom state) (format t "~&PropertyNotify ~S ~S~%" atom state) (finish-output))))) cl-clx-sbcl-0.7.4.20160323.orig/demo/bezier.lisp0000644000175000017500000000241612715665272016722 0ustar pdmpdm;;; -*- 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)))) cl-clx-sbcl-0.7.4.20160323.orig/demo/mandel.lisp0000644000175000017500000004344712715665272016713 0ustar pdmpdm(defpackage "XMANDEL" (:use "CL") (:export "NEW-WINDOW" "EVENT-LOOP")) (in-package "XMANDEL") (defvar *display* (xlib:open-default-display)) (defvar *screen* (xlib:display-default-screen *display*)) (defvar *backing-store* (make-hash-table) "Backing store hashtable, keyed off window id") (defvar *colmap* nil) (defvar *helpwin* nil) (defvar *zoom-table* (make-hash-table)) (defvar *zoomcolmap* (xlib:create-gcontext :drawable (xlib:screen-root *screen*) :foreground (xlib:screen-white-pixel *screen*) :function boole-xor)) (defvar *white* (xlib:create-gcontext :drawable (xlib:screen-root *screen*) :foreground (xlib:screen-white-pixel *screen*) )) (defvar *winmap* (make-hash-table)) (defvar *textmap* (xlib:create-gcontext :drawable (xlib:screen-root *screen*) :foreground (xlib:screen-black-pixel *screen*) :background (xlib:screen-white-pixel *screen*))) ;;; OK, this is an ugly hack to make sure we can handle ;;; shift and modstate in a sane way, alas we can't 100% rely ;;; on "current state of keyboard", since we only process events ;;; with a noticeable delay, at eth best of times, so a fast keyboarder ;;; can fool us, we are, however, IIRC, guaranteed that all events are ;;; serialised, so... (defvar *modstate* nil) (declaim (list *modstate*)) (defun make-shift-foo () (let ((rv 0)) (if (member :shift *modstate*) (setf rv 1)) (if (member :character-set-switch *modstate*) (setf rv (+ rv 2))) rv)) (defstruct (mandel-square (:conc-name ms-)) (x 0 :type fixnum) (y 0 :type fixnum) (s 512 :type fixnum) (base-r 0.0d0 :type double-float) (base-i 0.0d0 :type double-float) (maxiter 1024 :type fixnum) (dr 0.0d0 :type double-float) (di 0.0d0 :type double-float) win ) (defun make-queue (&rest args) (apply #'make-instance 'queue args)) (defclass queue () ((head :initform nil :accessor q-head) (tail :initform nil :accessor q-tail))) (defclass out-queue () ((win-queues :accessor win-queues :initarg :xyzzy-1) (seen-windows :accessor windows :initform nil) (win-list :accessor win-list :initarg :xyzzy-2) (last-window :accessor last-window :initform nil)) (:default-initargs :xyzzy-1 (make-hash-table) :xyzzy-2 (make-instance 'queue))) (defvar *sysqueue* (make-instance 'out-queue)) (defgeneric empty-p (queue)) (defgeneric empty (queue)) (defgeneric empty-win (queue win)) (defgeneric enqueue (queue item)) (defgeneric queue-push (queue item)) (defgeneric dequeue (queue)) (defmethod empty-p ((q null)) t) (defmethod empty-p ((q queue)) (null (q-head q))) (defmethod empty-p ((q out-queue)) (let ((coll nil)) (maphash #'(lambda (key val) (declare (ignore key)) (push (empty-p val) coll)) (win-queues q)) (every #'identity coll))) (defmethod empty ((q null)) nil) (defmethod empty ((q queue)) (setf (q-head q) nil) (setf (q-tail q) nil)) (defmethod empty ((q out-queue)) (maphash #'(lambda (key val) (declare (ignore key)) (empty val)) (win-queues q))) (defmethod empty-win ((q out-queue) win) (let ((temp-queue (gethash win (win-queues q)))) (empty temp-queue))) (defmethod enqueue ((q queue) item) (cond ((empty-p q) (setf (q-head q) (cons item nil)) (setf (q-tail q) (q-head q))) (t (setf (cdr (q-tail q)) (cons item nil)) (setf (q-tail q) (cdr (q-tail q)))))) (defmethod enqueue ((q out-queue) item) (let ((windows (q-head (win-list q))) (win (ms-win item))) (declare (type xlib:window win)) (unless (member win windows) (enqueue (win-list q) win)) (unless (member win (windows q)) (push win (windows q))) (let ((temp-queue (gethash win (win-queues q)))) (if (null temp-queue) (let ((new (make-queue))) (setf (gethash win (win-queues q)) new) (enqueue new item)) (enqueue temp-queue item))))) (defmethod queue-push ((q queue) item) (cond ((empty-p q) (setf (q-head q) (cons item nil)) (setf (q-tail q) (q-head q))) (t (setf (q-head q) (cons item (q-head q)))))) (defmethod queue-push ((q out-queue) item) (let ((windows (q-head (win-list q))) (win (ms-win item))) (declare (type xlib:window win)) (unless (member win windows) (enqueue (win-list q) win)) (unless (member win (windows q)) (push win (windows q))) (let ((temp-queue (gethash win (win-queues q)))) (if (null temp-queue) (let ((new (make-queue))) (setf (gethash win (win-queues q)) new) (queue-push new item)) (queue-push temp-queue item))))) (defmethod dequeue ((q out-queue)) (if (empty-p q) nil (let ((windows (win-list q))) (do* ((next (dequeue windows)) (finished nil) (val nil) (temp-queue (gethash next (win-queues q)) (gethash next (win-queues q)))) (finished val) (cond ((empty-p temp-queue) (setf next (dequeue windows))) (t (setf val (dequeue temp-queue)) (unless (empty-p temp-queue) (enqueue windows next)) (setf finished t))))))) (defmethod dequeue ((q queue)) (prog1 (car (q-head q)) (if (not (empty-p q)) (setf (q-head q) (cdr (q-head q)))) (if (null (q-head q)) (progn (setf (q-head q) nil) (setf (q-tail q) nil))))) (defun iter (rc ic max) (declare (double-float rc ic) (fixnum max)) (do ((x 0.0d0 (the double-float (+ (- (* x x) (* y y)) rc))) (y 0.0d0 (the double-float (+ (* 2.0d0 x y) ic))) (n 1 (the fixnum (1+ n)))) ((or (>= n max) (>= (+ (* x x) (* y y)) 4.0d0)) n))) ;;; (a+bi)^2 --> ;;; (a+bi)(a+bi) --> ;;; a^2+2abi+(bi)^2 --> ;;; a^2+2abi-b^2 (defclass zoomer () ((zoom-type :initarg :type :reader zoom-type :type fixnum) (start-x :initarg :x :reader start-x :type fixnum) (start-y :initarg :y :reader start-y :type fixnum) (stop-x :accessor stop-x :initform -1 :type fixnum) (stop-y :accessor stop-y :initform -1 :type fixnum) (win :reader win :initarg :win))) ;;;(defmethod print-object ((object zoomer) stream) ;;; (format stream " [~a ~a]>~%" ;;; (zoom-type object) (start-x object) (start-y object) ;;; (stop-x object) (stop-y object))) (defun init-colours () (unless *colmap* (setf *colmap* (make-array 256 :element-type 'xlib:gcontext :initial-element *zoomcolmap*)) (setf (aref *colmap* 0) (xlib:create-gcontext :drawable (xlib:screen-root *screen*) :foreground (xlib:alloc-color (xlib:screen-default-colormap *screen*) (xlib:make-color :red 0 :green 0 :blue 0)))) (loop for index from 1 to 255 do (setf (aref *colmap* index) (xlib:create-gcontext :drawable (xlib:screen-root *screen*) :foreground (xlib:alloc-color (xlib:screen-default-colormap *screen*) (xlib:make-color :red (random 1.0) :green (random 1.0) :blue (random 1.0)))))))) (defmacro modcol (col max) `(if (= ,col ,max) 0 (1+ (mod ,col 255)))) (defun plot (win col x y max) (declare (fixnum col x y max)) (let ((col (modcol col max))) (xlib:draw-point win (aref *colmap* col) x y) (setf (aref (the (simple-array (integer 0 255) (512 512)) (gethash win *backing-store*)) x y) col))) (defun display-help () (unless *helpwin* (setf *helpwin* (xlib:create-window :parent (xlib:screen-root *screen*) :x 512 :y 512 :width 310 :height 180 :event-mask (xlib:make-event-mask :exposure) :backing-store :always :background (xlib:screen-white-pixel *screen*))) (xlib:map-window *helpwin*) (xlib:display-force-output *display*)) (unless (xlib:gcontext-font *textmap*) (let ((fixed (xlib:list-fonts *display* "fixed")) font) (if fixed (setf font (xlib:open-font *display* "fixed")) (error "Could not open suitable font")) (setf (xlib:gcontext-font *textmap*) (if (consp fixed) (car fixed) fixed)))) (xlib:draw-rectangle *helpwin* *white* 0 0 (xlib:drawable-width *helpwin*) (xlib:drawable-height *helpwin*) t) (xlib:draw-glyphs *helpwin* *textmap* 10 13 "Button 1: Zoom same") (xlib:draw-glyphs *helpwin* *textmap* 10 33 "Button 2: Zoom new") (xlib:draw-glyphs *helpwin* *textmap* 10 53 "Button 3: Zoom out, same") (xlib:draw-glyphs *helpwin* *textmap* 10 93 "In general, click to zoom centred on mouse,") (xlib:draw-glyphs *helpwin* *textmap* 10 113 "drag to zoom a region.") (xlib:draw-glyphs *helpwin* *textmap* 10 153 "Q: quit") (xlib:display-force-output *display*)) (defun repaint-window (win x-low y-low x-high y-high) (declare (fixnum x-low y-low x-high y-high)) (if (eq win *helpwin*) (display-help) (let ((bs (the (simple-array (integer 0 255) (512 512)) (gethash win *backing-store*)))) (loop for y of-type fixnum from y-low to y-high do (loop for x of-type fixnum from x-low to x-high do (xlib:draw-point win (aref *colmap* (aref bs x y)) x y)))))) (defun fill-square (win col x y s max) (declare (fixnum col x y s max)) (let ((col (modcol col max))) (xlib:draw-rectangle win (aref *colmap* col) x y s s t) (let ((bs (the (simple-array (integer 0 255) (512 512)) (gethash win *backing-store*)))) (loop for px of-type fixnum from x to (1- (+ x s)) do (loop for py of-type fixnum from y to (1- (+ y s)) do (setf (aref bs px py) col)))))) (defun make-square (win x y side bx by dx dy &optional (maxiter 1024)) (declare (xlib:window win) (fixnum x y side maxiter) (double-float bx by dx dy)) (let ((sq (make-mandel-square :x x :y y :s side :base-r bx :base-i by :dr dx :di dy :maxiter maxiter :win win))) (queue-push *sysqueue* sq))) (defun mandel-win (win lx ly hx hy &optional (maxiter 1024)) (declare (xlib:window win) (double-float lx ly hx hy) (fixnum maxiter)) (let ((dx (coerce (/ (- hx lx) 512.0d0) 'double-float)) (dy (coerce (/ (- hy ly) 512.0d0) 'double-float))) (setf (gethash win *winmap*) (make-mandel-square :x 0 :y 0 :s 512 :base-r lx :base-i ly :dr dx :di dy :maxiter maxiter)) (make-square win 0 256 256 lx ly dx dy maxiter) (make-square win 256 256 256 lx ly dx dy maxiter) (make-square win 256 0 256 lx ly dx dy maxiter) (make-square win 0 0 256 lx ly dx dy maxiter))) (defun new-window (lx ly hx hy &optional (maxiter 1024)) (let ((win (xlib:create-window :parent (xlib:screen-root *screen*) :x (+ 100 (random 50)) :y (+ 100 (random 50)) :width 512 :height 512 :bit-gravity :center :event-mask (xlib:make-event-mask :button-motion :button-press :button-release :key-press :exposure))) (ar (make-array '(512 512) :element-type '(integer 0 255) :initial-element 0)) ) (setf (gethash win *backing-store*) ar) (xlib:map-window win) (mandel-win win (coerce lx 'double-float) (coerce ly 'double-float) (coerce hx 'double-float) (coerce hy 'double-float) maxiter))) (defun fill-square-p (ix iy s bx by dx dy max win) (declare (fixnum ix iy s max) (double-float bx by dx dy)) (let ((norm (iter (+ bx (* ix dx)) (+ by (* iy dy)) max))) (and (loop for px from ix below (+ ix s) for x of-type double-float = (+ bx (* px dx)) with y = (+ by (* iy dy)) for i = (iter x y max) do (plot win i px iy max) while (= i norm) finally (return t)) (loop for py from iy below (+ s iy) for y of-type double-float = (+ by (* py dy)) with x = (+ bx (* ix dx)) for i = (iter x y max) do (plot win i ix py max) while (= i norm) finally (return t)) (loop for px from (1- (+ s ix)) downto ix for x of-type double-float = (+ bx (* px dx)) with y = (+ by (* dy (1- (+ s iy)))) for i = (iter x y max) do (plot win i px iy max) if (/= i norm) return nil finally (return t)) (loop for py from (1- (+ s iy)) downto iy for y of-type double-float = (+ by (* py dy)) with x = (+ bx (* dx (1- (+ s ix)))) for i = (iter x y max) do (plot win i ix py max) if (/= i norm) return nil finally (return t))))) (defmacro z (base delta int) `(+ ,base (* ,delta ,int))) (defun draw-square (square) (declare (mandel-square square)) (let ((dx (ms-dr square)) (dy (ms-di square)) (base-x (ms-base-r square)) (base-y (ms-base-i square)) (maxiter (ms-maxiter square)) (win (ms-win square)) (x (ms-x square)) (y (ms-y square)) (s (ms-s square)) ) (declare (double-float dx dy base-x base-y) (fixnum x y s maxiter)) (cond ((= s 2) (plot win (iter (z base-x dx (1+ x)) (z base-y dy (1+ y)) maxiter) (1+ x) (1+ y) maxiter) (plot win (iter (z base-x dx (1+ x)) (z base-y dy y) maxiter) (1+ x) y maxiter) (plot win (iter (z base-x dx x) (z base-y dy (1+ y)) maxiter) x (1+ y) maxiter) (plot win (iter (z base-x dx x) (z base-y dy y) maxiter) x y maxiter)) ((fill-square-p x y s base-x base-y dx dy maxiter win) (fill-square win (iter (z base-x dx x) (z base-y dy y) maxiter) x y s maxiter)) (t (let ((new-s (/ s 2))) (make-square win x y new-s base-x base-y dx dy maxiter) (make-square win x (+ y new-s) new-s base-x base-y dx dy maxiter) (make-square win (+ x new-s) y new-s base-x base-y dx dy maxiter) (make-square win (+ x new-s) (+ y new-s) new-s base-x base-y dx dy maxiter)))))) (defun create-zoom (win x y button) (setf (gethash win *zoom-table*) (make-instance 'zoomer :x x :y y :win win :type (case button (1 :zoom-same) (2 :zoom-new) (3 :zoom-out))))) (defun update-zoom (win x y code) (declare (ignore code) (fixnum x y)) (let ((zoomer (gethash win *zoom-table*))) (when zoomer (let ((new-side (max 0 (- (the fixnum x) (the fixnum (start-x zoomer))) (- (the fixnum y) (the fixnum (start-y zoomer)))))) (let ((old-side (max 0 (- (the fixnum (stop-x zoomer)) (the fixnum (start-x zoomer))) (- (the fixnum (stop-y zoomer)) (the fixnum (start-y zoomer)))))) (xlib:draw-rectangle win *zoomcolmap* (the fixnum (start-x zoomer)) (the fixnum (start-y zoomer)) old-side old-side)) (setf (stop-x zoomer) (max (the fixnum (start-x zoomer)) (the fixnum x) )) (setf (stop-y zoomer) (max (the fixnum (start-y zoomer)) (the fixnum y) )) (xlib:draw-rectangle win *zoomcolmap* (the fixnum (start-x zoomer)) (the fixnum (start-y zoomer)) new-side new-side) (xlib:display-force-output *display*))))) (defun finish-zoom (win x y code) (declare (ignore code)) (let ((zoomer (gethash win *zoom-table*))) (setf (stop-x zoomer) x) (setf (stop-y zoomer) y))) (defun do-zoom (win) (let ((zoomer (gethash win *zoom-table*))) (declare (zoomer zoomer)) (setf (gethash win *zoom-table*) nil) (let ((dx (- (the fixnum (stop-x zoomer)) (the fixnum (start-x zoomer)))) (dy (- (the fixnum (stop-y zoomer)) (the fixnum (start-y zoomer)))) (sq (gethash win *winmap*))) (let ((side (max dx dy)) (x (the fixnum (start-x zoomer))) (y (the fixnum (start-y zoomer))) lx hx ly hy ) (if (< side 5) (setf lx (+ (ms-base-r sq) (* (- x 128) (ms-dr sq))) ly (+ (ms-base-i sq) (* (- y 128) (ms-di sq))) hx (+ (ms-base-r sq) (* (+ x 128) (ms-dr sq))) hy (+ (ms-base-i sq) (* (+ y 128) (ms-di sq)))) (setf lx (+ (ms-base-r sq) (* x (ms-dr sq))) ly (+ (ms-base-i sq) (* y (ms-dr sq))) hx (+ (ms-base-r sq) (* (+ side x) (ms-dr sq))) hy (+ (ms-base-i sq) (* (+ side y) (ms-dr sq))))) ;;; (format t "DEBUG: zoomer is ~a~%~%" zoomer) (case (zoom-type zoomer) (:zoom-new (new-window lx ly hx hy (ms-maxiter sq))) (:zoom-same (empty-win *sysqueue* win) (mandel-win win lx ly hx hy (ms-maxiter sq))) (:zoom-out (empty-win *sysqueue* win) (let ((br (ms-base-r sq)) (bi (ms-base-i sq)) (dr (ms-dr sq)) (di (ms-di sq))) (mandel-win win (- br (* 512 dr)) (- bi (* 512 di)) (+ (* 1024 dr) br) (+ (* 1024 di) bi) (ms-maxiter sq)))) (t (format t "Unknown/unimplemented zoom type ~a~%~%" (zoom-type zoomer)))))))) (defun quit-window (window) (let ((temp (gethash window (win-queues *sysqueue*)))) (when temp (empty temp)))) (defun event-loop () (init-colours) (do ((quit nil) (redisplay nil t)) ((eq quit 'quit)) (xlib:event-case (*display* :timeout 0) (:button-press (window x y code) (create-zoom window x y code) t) (:button-release (window x y code) (finish-zoom window x y code) (do-zoom window) t) (:motion-notify (window x y code) (update-zoom window x y code) t) (:exposure (window x y width height count) (let ((count count)) (declare (ignore count) (fixnum x y width height)) (when redisplay (repaint-window window x y (1- (+ x width)) (1- (+ y height))))) t) (:key-press (window code) (case (xlib:keysym->character *display* (xlib:keycode->keysym *display* code (make-shift-foo))) (#\q (quit-window window)) (#\? (display-help)) ((:left-shift :right-shift) (push :shift *modstate*)) ((:left-control :right-control) (push :ctrl *modstate*)) (:character-set-switch (push :character-set-switch *modstate*))) t) (:key-release (window code) (let ((window window)) (declare (ignore window)) (case (xlib:keysym->character *display* (xlib:keycode->keysym *display* code 0)) (:character-set-switch (setf *modstate* (delete :character-set-switch *modstate*))) ((:left-control :right-control) (setf *modstate* (delete :ctrl *modstate*))) ((:left-shift :right-shift) (setf *modstate* (delete :shift *modstate*))))) t)) (cond ((empty-p *sysqueue*) nil) (t (let ((square (dequeue *sysqueue*))) (draw-square square)))))) cl-clx-sbcl-0.7.4.20160323.orig/demo/hello.lisp0000644000175000017500000000463112715665272016546 0ustar pdmpdm;;; -*- 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))))) cl-clx-sbcl-0.7.4.20160323.orig/demo/beziertest.lisp0000644000175000017500000000534512715665272017626 0ustar pdmpdm;;; -*- 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 (aref lines i) (ash (* (aref lines i) factor) -16))) (dotimes (i (length curves)) (setf (aref curves i) (ash (* (aref 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)))) cl-clx-sbcl-0.7.4.20160323.orig/demo/zoid.lisp0000644000175000017500000000403512715665272016406 0ustar pdmpdm;;; -*- 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)))) cl-clx-sbcl-0.7.4.20160323.orig/demo/gl-test.lisp0000644000175000017500000003720312715665272017023 0ustar pdmpdm(defpackage :gl-test (:use :common-lisp :xlib) (:export "TEST" "CLX-TEST")) (in-package :gl-test) (defun test (function &key (host "localhost") (display 1) (width 200) (height 200)) (let* ((display (open-display host :display display)) (screen (display-default-screen display)) (root (screen-root screen)) ctx) (unwind-protect (progn ;;; Inform the server about us. (glx::client-info display) (let* ((visual (glx:choose-visual screen '(:glx-rgba (:glx-red-size 1) (:glx-green-size 1) (:glx-blue-size 1) :glx-double-buffer))) (colormap (create-colormap (glx:visual-id visual) root)) (window (create-window :parent root :x 10 :y 10 :width width :height height :class :input-output :background (screen-black-pixel screen) :border (screen-black-pixel screen) :visual (glx:visual-id visual) :depth 24 :colormap colormap :event-mask '(:structure-notify :exposure))) (gc (create-gcontext :foreground (screen-white-pixel screen) :background (screen-black-pixel screen) :drawable window :font (open-font display "fixed")))) (set-wm-properties window :name "glx-test" :resource-class "glx-test" :command (list "glx-test") :x 10 :y 10 :width width :height height :min-width width :min-height height :initial-state :normal) (setf ctx (glx:create-context screen (glx:visual-id visual))) (map-window window) (glx:make-current window ctx) (funcall function display window) (unmap-window window) (free-gcontext gc))) (when ctx (glx:destroy-context ctx)) (close-display display)))) ;;; Tests (defun no-floats (display window) (declare (ignore display window)) (gl:color-3s #x7fff #x7fff 0) (gl:begin gl:+polygon+) (gl:vertex-2s 0 0) (gl:vertex-2s 1 0) (gl:vertex-2s 1 1) (gl:vertex-2s 0 1) (gl:end) (glx:swap-buffers) (sleep 5)) (defun anim (display window) (declare (ignore display window)) (gl:ortho 0.0d0 1.0d0 0.0d0 1.0d0 -1.0d0 1.0d0) (gl:clear-color 0.0s0 0.0s0 0.0s0 0.0s0) (gl:line-width 2.0s0) (loop repeat 361 for angle upfrom 0.0s0 by 1.0s0 do (progn (gl:clear gl:+color-buffer-bit+) (gl:push-matrix) (gl:translate-f 0.5s0 0.5s0 0.0s0) (gl:rotate-f angle 0.0s0 0.0s0 1.0s0) (gl:translate-f -0.5s0 -0.5s0 0.0s0) (gl:begin gl:+polygon+ #-(and) gl:+line-loop+) (gl:color-3ub 255 0 0) (gl:vertex-2f 0.25s0 0.25s0) (gl:color-3ub 0 255 0) (gl:vertex-2f 0.75s0 0.25s0) (gl:color-3ub 0 0 255) (gl:vertex-2f 0.75s0 0.75s0) (gl:color-3ub 255 255 255) (gl:vertex-2f 0.25s0 0.75s0) (gl:end) (gl:pop-matrix) (glx:swap-buffers) (sleep 0.02))) (sleep 3)) (defun anim/list (display window) (declare (ignore display window)) (gl:ortho 0.0d0 1.0d0 0.0d0 1.0d0 -1.0d0 1.0d0) (gl:clear-color 0.0s0 0.0s0 0.0s0 0.0s0) (let ((list (gl:gen-lists 1))) (gl:new-list list gl:+compile+) (gl:begin gl:+polygon+) (gl:color-3ub 255 0 0) (gl:vertex-2f 0.25s0 0.25s0) (gl:color-3ub 0 255 0) (gl:vertex-2f 0.75s0 0.25s0) (gl:color-3ub 0 0 255) (gl:vertex-2f 0.75s0 0.75s0) (gl:color-3ub 255 255 255) (gl:vertex-2f 0.25s0 0.75s0) (gl:end) (glx:render) (gl:end-list) (loop repeat 361 for angle upfrom 0.0s0 by 1.0s0 do (progn (gl:clear gl:+color-buffer-bit+) (gl:push-matrix) (gl:rotate-f angle 0.0s0 0.0s0 1.0s0) (gl:call-list list) (gl:pop-matrix) (glx:swap-buffers) (sleep 0.02)))) (sleep 3)) ;;; glxgears (defconstant +pi+ (coerce pi 'single-float)) (declaim (type single-float +pi+)) (defun gear (inner-radius outer-radius width teeth tooth-depth) (let ((r0 inner-radius) (r1 (/ (- outer-radius tooth-depth) 2.0s0)) (r2 (/ (+ outer-radius tooth-depth) 2.0s0)) (da (/ (* 2.0s0 +pi+) teeth 4.0s0))) (gl:shade-model gl:+flat+) (gl:normal-3f 0.0s0 0.0s0 1.0s0) ;; Front face. (gl:begin gl:+quad-strip+) (dotimes (i (1+ teeth)) (let ((angle (/ (* i 2.0 +pi+) teeth))) (declare (type single-float angle)) (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0)) (gl:vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5s0)) (when (< i teeth) (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0)) (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5s0))))) (gl:end) ;; Draw front sides of teeth. (gl:begin gl:+quads+) (setf da (/ (* 2.0s0 +pi+) teeth 4.0s0)) (dotimes (i teeth) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) (gl:vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5s0)) (gl:vertex-3f (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width 0.5s0)) (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width 0.5s0)) (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5s0)))) (gl:end) (gl:normal-3f 0.0s0 0.0s0 -1.0s0) ;; Draw back face. (gl:begin gl:+quad-strip+) (dotimes (i (1+ teeth)) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) (gl:vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5s0)) (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5s0)) (when (< i teeth) (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width -0.5s0)) (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0))))) (gl:end) ;; Draw back sides of teeth. (gl:begin gl:+quads+) (setf da (/ (* 2.0s0 +pi+) teeth 4.0s0)) (dotimes (i teeth) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width -0.5s0)) (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width -0.5s0)) (gl:vertex-3f (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width -0.5s0)) (gl:vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5s0)))) (gl:end) ;; Draw outward faces of teeth. (gl:begin gl:+quad-strip+) (dotimes (i teeth) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) (gl:vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5s0)) (gl:vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5s0)) (let* ((u (- (* r2 (cos (+ angle da))) (* r1 (cos angle)))) (v (- (* r2 (sin (+ angle da))) (* r1 (sin angle)))) (len (sqrt (+ (* u u) (* v v))))) (setf u (/ u len) v (/ v len)) (gl:normal-3f v u 0.0s0) (gl:vertex-3f (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width 0.5s0)) (gl:vertex-3f (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width -0.5s0)) (gl:normal-3f (cos angle) (sin angle) 0.0s0) (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width 0.5s0)) (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width -0.5s0)) (setf u (- (* r1 (cos (+ angle (* 3 da)))) (* r2 (cos (+ angle (* 2 da))))) v (- (* r1 (sin (+ angle (* 3 da)))) (* r2 (sin (+ angle (* 2 da)))))) (gl:normal-3f v (- u) 0.0s0) (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5s0)) (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width -0.5s0)) (gl:normal-3f (cos angle) (sin angle) 0.0s0)))) (gl:vertex-3f (* r1 (cos 0)) (* r1 (sin 0)) (* width 0.5s0)) (gl:vertex-3f (* r1 (cos 0)) (* r1 (sin 0)) (* width -0.5s0)) (gl:end) (gl:shade-model gl:+smooth+) ;; Draw inside radius cylinder. (gl:begin gl:+quad-strip+) (dotimes (i (1+ teeth)) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) (gl:normal-3f (- (cos angle)) (- (sin angle)) 0.0s0) (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5s0)) (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0)))) (gl:end))) (defun draw (gear-1 gear-2 gear-3 view-rotx view-roty view-rotz angle) (gl:clear (logior gl:+color-buffer-bit+ gl:+depth-buffer-bit+)) (gl:push-matrix) (gl:rotate-f view-rotx 1.0s0 0.0s0 0.0s0) (gl:rotate-f view-roty 0.0s0 1.0s0 0.0s0) (gl:rotate-f view-rotz 0.0s0 0.0s0 1.0s0) (gl:push-matrix) (gl:translate-f -3.0s0 -2.0s0 0.0s0) (gl:rotate-f angle 0.0s0 0.0s0 1.0s0) (gl:call-list gear-1) (gl:pop-matrix) (gl:push-matrix) (gl:translate-f 3.1s0 -2.0s0 0.0s0) (gl:rotate-f (- (* angle -2.0s0) 9.0s0) 0.0s0 0.0s0 1.0s0) (gl:call-list gear-2) (gl:pop-matrix) (gl:push-matrix) (gl:translate-f -3.1s0 4.2s0 0.0s0) (gl:rotate-f (- (* angle -2.s0) 25.0s0) 0.0s0 0.0s0 1.0s0) (gl:call-list gear-3) (gl:pop-matrix) (gl:pop-matrix)) (defun reshape (width height) (gl:viewport 0 0 width height) (let ((h (coerce (/ height width) 'double-float))) (gl:matrix-mode gl:+projection+) (gl:load-identity) (gl:frustum -1.0d0 1.0d0 (- h) h 5.0d0 60.0d0)) (gl:matrix-mode gl:+modelview+) (gl:load-identity) (gl:translate-f 0.0s0 0.0s0 -40.0s0)) (defun init () (let (gear-1 gear-2 gear-3) ;;(gl:light-fv gl:+light0+ gl:+position+ '(5.0s0 5.0s0 10.0s0 0.0s0)) ;;(gl:enable gl:+cull-face+) ;;(gl:enable gl:+lighting+) ;;(gl:enable gl:+light0+) ;;(gl:enable gl:+depth-test+) ;; Make the gears. (setf gear-1 (gl:gen-lists 1)) (gl:new-list gear-1 gl:+compile+) (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) (gear 1.0s0 4.0s0 1.0s0 20 0.7s0) (gl:end-list) (setf gear-2 (gl:gen-lists 1)) (gl:new-list gear-2 gl:+compile+) (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.0s0 0.8s0 0.2s0 1.0s0)) (gear 0.5s0 2.0s0 2.0s0 10 0.7s0) (gl:end-list) (setf gear-3 (gl:gen-lists 1)) (gl:new-list gear-3 gl:+compile+) (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.2s0 0.2s0 1.0s0 1.0s0)) (gear 1.3s0 2.0s0 0.5s0 10 0.7s0) (gl:end-list) ;;(gl:enable gl:+normalize+) (values gear-1 gear-2 gear-3))) (defun gears* (display window) (declare (ignore display window)) (gl:enable gl:+cull-face+) (gl:enable gl:+lighting+) (gl:enable gl:+light0+) (gl:enable gl:+normalize+) (gl:enable gl:+depth-test+) (reshape 300 300) ;;(gl:light-fv gl:+light0+ gl:+position+ #(5.0s0 5.0s0 10.0s0 0.0s0)) (let (list) (declare (ignore list)) #-(and) (progn (setf list (gl:gen-lists 1)) (gl:new-list list gl:+compile+) ;;(gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) (gear 1.0s0 4.0s0 1.0s0 20 0.7s0) (glx:render) (gl:end-list)) (loop ;;for angle from 0.0s0 below 361.0s0 by 1.0s0 with angle of-type single-float = 0.0s0 with dt = 0.004s0 repeat 2500 do (progn (incf angle (* 70.0s0 dt)) ; 70 degrees per second (when (< 3600.0s0 angle) (decf angle 3600.0s0)) (gl:clear (logior gl:+color-buffer-bit+ gl:+depth-buffer-bit+)) (gl:push-matrix) (gl:rotate-f 20.0s0 0.0s0 1.0s0 0.0s0) (gl:push-matrix) (gl:translate-f -3.0s0 -2.0s0 0.0s0) (gl:rotate-f angle 0.0s0 0.0s0 1.0s0) (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) (gear 1.0s0 4.0s0 1.0s0 20 0.7s0) (gl:pop-matrix) (gl:push-matrix) (gl:translate-f 3.1s0 -2.0s0 0.0s0) (gl:rotate-f (- (* angle -2.0s0) 9.0s0) 0.0s0 0.0s0 1.0s0) (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.0s0 0.8s0 0.2s0 1.0s0)) (gear 0.5s0 2.0s0 2.0s0 10 0.7s0) (gl:pop-matrix) (gl:push-matrix) (gl:translate-f -3.1s0 4.2s0 0.0s0) (gl:rotate-f (- (* angle -2.s0) 25.0s0) 0.0s0 0.0s0 1.0s0) (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.2s0 0.2s0 1.0s0 1.0s0)) (gear 1.3s0 2.0s0 0.5s0 10 0.7s0) (gl:pop-matrix) (gl:pop-matrix) (glx:swap-buffers) ;;(sleep 0.025) ))) ;;(sleep 3) ) (defun gears (display window) (declare (ignore window)) (let ((view-rotx 20.0s0) (view-roty 30.0s0) (view-rotz 0.0s0) (angle 0.0s0) (frames 0) (dt 0.004s0) ; *** This is dynamically adjusted ;;(t-rot-0 -1.0d0) ;;(t-rate-0 -1.d0) gear-1 gear-2 gear-3) (multiple-value-setq (gear-1 gear-2 gear-3) (init)) (loop (event-case (display :timeout 0.01 :force-output-p t) (configure-notify (width height) (reshape width height) t) (key-press (code) (format t "Key pressed: ~S~%" code) (return-from gears t))) (incf angle (* 70.0s0 dt)) ; 70 degrees per second (when (< 3600.0s0 angle) (decf angle 3600.0s0)) (draw gear-1 gear-2 gear-3 view-rotx view-roty view-rotz angle) (glx:swap-buffers) (incf frames) ;; FPS calculation goes here ))) cl-clx-sbcl-0.7.4.20160323.orig/fonts.lisp0000644000175000017500000003053412715665272015651 0ustar pdmpdm;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (in-package :xlib) ;; The char-info stuff is here instead of CLX because of uses of int16->card16. ; To allow efficient storage representations, the type char-info is not ; required to be a structure. ;; For each of left-bearing, right-bearing, width, ascent, descent, attributes: ;(defun char- (font index) ; ;; Note: I have tentatively chosen to return nil for an out-of-bounds index ; ;; (or an in-bounds index on a pseudo font), although returning zero or ; ;; signalling might be better. ; (declare (type font font) ; (type integer index) ; (clx-values (or null integer)))) ;(defun max-char- (font) ; ;; Note: I have tentatively chosen separate accessors over allowing :min and ; ;; :max as an index above. ; (declare (type font font) ; (clx-values integer))) ;(defun min-char- (font) ; (declare (type font font) ; (clx-values integer))) ;; Note: char16- accessors could be defined to accept two-byte indexes. (deftype char-info-vec () '(simple-array int16 (*))) (macrolet ((def-char-info-accessors (useless-name &body fields) `(within-definition (,useless-name def-char-info-accessors) ,@(do ((field fields (cdr field)) (n 0 (1+ n)) (name) (type) (result nil)) ((endp field) result) (setq name (xintern 'char- (caar field))) (setq type (cadar field)) (flet ((from (form) (if (eq type 'int16) form `(,(xintern 'int16-> type) ,form)))) (push `(defun ,name (font index) (declare (type font font) (type array-index index)) (declare (clx-values (or null ,type))) (when (and (font-name font) (index>= (font-max-char font) index (font-min-char font))) (the ,type ,(from `(the int16 (let ((char-info-vector (font-char-infos font))) (declare (type char-info-vec char-info-vector)) (if (index-zerop (length char-info-vector)) ;; Fixed width font (aref (the char-info-vec (font-max-bounds font)) ,n) ;; Variable width font (aref char-info-vector (index+ (index* 6 (index- index (font-min-char font))) ,n))))))))) result) (setq name (xintern 'min-char- (caar field))) (push `(defun ,name (font) (declare (type font font)) (declare (clx-values (or null ,type))) (when (font-name font) (the ,type ,(from `(the int16 (aref (the char-info-vec (font-min-bounds font)) ,n)))))) result) (setq name (xintern 'max-char- (caar field))) (push `(defun ,name (font) (declare (type font font)) (declare (clx-values (or null ,type))) (when (font-name font) (the ,type ,(from `(the int16 (aref (the char-info-vec (font-max-bounds font)) ,n)))))) result))) (defun make-char-info (&key ,@(mapcar #'(lambda (field) `(,(car field) (required-arg ,(car field)))) fields)) (declare ,@(mapcar #'(lambda (field) `(type ,@(reverse field))) fields)) (let ((result (make-array ,(length fields) :element-type 'int16))) (declare (type char-info-vec result)) ,@(do* ((field fields (cdr field)) (var (caar field) (caar field)) (type (cadar field) (cadar field)) (n 0 (1+ n)) (result nil)) ((endp field) (nreverse result)) (push `(setf (aref result ,n) ,(if (eq type 'int16) var `(,(xintern type '->int16) ,var))) result)) result))))) (def-char-info-accessors ignore (left-bearing int16) (right-bearing int16) (width int16) (ascent int16) (descent int16) (attributes card16))) (defun open-font (display name) ;; Font objects may be cached and reference counted locally within the display ;; object. This function might not execute a with-display if the font is cached. ;; The protocol QueryFont request happens on-demand under the covers. (declare (type display display) (type stringable name)) (declare (clx-values font)) (let* ((name-string (string-downcase (string name))) (font (car (member name-string (display-font-cache display) :key 'font-name :test 'equal))) font-id) (unless font (setq font (make-font :display display :name name-string)) (setq font-id (allocate-resource-id display font 'font)) (setf (font-id-internal font) font-id) (with-buffer-request (display +x-openfont+) (resource-id font-id) (card16 (length name-string)) (pad16 nil) (string name-string)) (push font (display-font-cache display))) (incf (font-reference-count font)) (unless (font-font-info-internal font) (query-font 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) cl-clx-sbcl-0.7.4.20160323.orig/generalock.lisp0000644000175000017500000000612612715665272016632 0ustar pdmpdm;;; -*- Mode: LISP; Syntax: Common-lisp; Package: PROCESS; Base: 10; Lowercase: Yes -*- ;;; Copyright (C) 1990 Symbolics, Inc. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Symbolics, Inc. provides this software "as is" without ;;; express or implied warranty. (defflavor xlib::clx-lock () (simple-recursive-normal-lock) (:init-keywords :flavor)) (defwhopper (lock-internal xlib::clx-lock) (lock-argument) (catch 'timeout (continue-whopper lock-argument))) (defmethod (lock-block-internal xlib::clx-lock) (lock-argument) (declare (dbg:locking-function describe-process-lock-for-debugger self)) (when (null waiter-queue) (setf waiter-queue (make-scheduler-queue :name name)) (setf timer (create-timer-call #'lock-timer-expired `(,self) :name name))) (let ((process (lock-argument-process lock-argument))) (unwind-protect (progn (lock-map-over-conflicting-owners self lock-argument #'(lambda (other-lock-arg) (add-promotion process lock-argument (lock-argument-process other-lock-arg) other-lock-arg))) (unless (timer-pending-p timer) (when (and (safe-to-use-timers %real-current-process) (not dbg:*debugger-might-have-system-problems*)) (reset-timer-relative-timer-units timer *lock-timer-interval*))) (assert (store-conditional (locf latch) process nil)) (sys:with-aborts-enabled (lock-latch) (let ((timeout (lock-argument-getf lock-argument :timeout nil))) (cond ((null timeout) (promotion-block waiter-queue name #'lock-lockable self lock-argument)) ((and (plusp timeout) (using-resource (timer process-block-timers) ;; Yeah, we know about the internal representation ;; of timers here. (setf (car (timer-args timer)) %real-current-process) (with-scheduler-locked (reset-timer-relative timer timeout) (flet ((lock-lockable-or-timeout (timer lock lock-argument) (or (not (timer-pending-p timer)) (lock-lockable lock lock-argument)))) (let ((priority (process-process-priority *current-process*))) (if (ldb-test %%scheduler-priority-preemption-field priority) (promotion-block waiter-queue name #'lock-lockable-or-timeout timer self lock-argument) ;; Change to preemptive priority so that when ;; unlock-internal wakes us up so we can have the lock, ;; we will really wake up right away (with-process-priority (dpb 1 %%scheduler-priority-preemption-field priority) (promotion-block waiter-queue name #'lock-lockable-or-timeout timer self lock-argument))))) (lock-lockable self lock-argument))))) (t (throw 'timeout nil)))))) (unless (store-conditional (locf latch) nil process) (lock-latch-wait-internal self)) (remove-promotions process lock-argument)))) (compile-flavor-methods xlib::clx-lock) cl-clx-sbcl-0.7.4.20160323.orig/exclcmac.lisp0000644000175000017500000001656112715665272016303 0ustar pdmpdm;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*- ;;; ;;; CLX -- exclcmac.cl ;;; This file provides for inline expansion of some functions. ;;; ;;; Copyright (c) 1989 Franz Inc, Berkeley, Ca. ;;; ;;; Permission is granted to any individual or institution to use, copy, ;;; modify, and distribute this software, provided that this complete ;;; copyright and permission notice is maintained, intact, in all copies and ;;; supporting documentation. ;;; ;;; Franz Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (in-package :xlib) ;; ;; Type predicates ;; (excl:defcmacro card8p (x) (let ((xx (gensym))) `(let ((,xx ,x)) (declare (optimize (speed 3) (safety 0)) (fixnum ,xx)) (and (excl:fixnump ,xx) (> #.(expt 2 8) ,xx) (>= ,xx 0))))) (excl:defcmacro card16p (x) (let ((xx (gensym))) `(let ((,xx ,x)) (declare (optimize (speed 3) (safety 0)) (fixnum ,xx)) (and (excl:fixnump ,xx) (> #.(expt 2 16) ,xx) (>= ,xx 0))))) (excl:defcmacro int8p (x) (let ((xx (gensym))) `(let ((,xx ,x)) (declare (optimize (speed 3) (safety 0)) (fixnum ,xx)) (and (excl:fixnump ,xx) (> #.(expt 2 7) ,xx) (>= ,xx #.(expt -2 7)))))) (excl:defcmacro int16p (x) (let ((xx (gensym))) `(let ((,xx ,x)) (declare (optimize (speed 3) (safety 0)) (fixnum ,xx)) (and (excl:fixnump ,xx) (> #.(expt 2 15) ,xx) (>= ,xx #.(expt -2 15)))))) ;; Card29p, card32p, int32p are too large to expand inline ;; ;; Type transformers ;; (excl:defcmacro card8->int8 (x) (let ((xx (gensym))) `(let ((,xx ,x)) ,(declare-bufmac) (declare (type card8 ,xx)) (the int8 (if (logbitp 7 ,xx) (the int8 (- ,xx #x100)) ,xx))))) (excl:defcmacro int8->card8 (x) `(locally ,(declare-bufmac) (the card8 (ldb (byte 8 0) (the int8 ,x))))) (excl:defcmacro card16->int16 (x) (let ((xx (gensym))) `(let ((,xx ,x)) ,(declare-bufmac) (declare (type card16 ,xx)) (the int16 (if (logbitp 15 ,xx) (the int16 (- ,xx #x10000)) ,xx))))) (excl:defcmacro int16->card16 (x) `(locally ,(declare-bufmac) (the card16 (ldb (byte 16 0) (the int16 ,x))))) (excl:defcmacro card32->int32 (x) (let ((xx (gensym))) `(let ((,xx ,x)) ,(declare-bufmac) (declare (type card32 ,xx)) (the int32 (if (logbitp 31 ,xx) (the int32 (- ,xx #x100000000)) ,xx))))) (excl:defcmacro int32->card32 (x) `(locally ,(declare-bufmac) (the card32 (ldb (byte 32 0) (the int32 ,x))))) (excl:defcmacro char->card8 (char) `(locally ,(declare-bufmac) (the card8 (char-code (the string-char ,char))))) (excl:defcmacro card8->char (card8) `(locally ,(declare-bufmac) (the string-char (code-char (the card8 ,card8))))) ;; ;; Array accessors and setters ;; (excl:defcmacro aref-card8 (a i) `(locally ,(declare-bufmac) (the card8 (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :unsigned-byte)))) (excl:defcmacro aset-card8 (v a i) `(locally ,(declare-bufmac) (setf (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :unsigned-byte) (the card8 ,v)))) (excl:defcmacro aref-int8 (a i) `(locally ,(declare-bufmac) (the int8 (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :signed-byte)))) (excl:defcmacro aset-int8 (v a i) `(locally ,(declare-bufmac) (setf (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :signed-byte) (the int8 ,v)))) (excl:defcmacro aref-card16 (a i) `(locally ,(declare-bufmac) (the card16 (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :unsigned-word)))) (excl:defcmacro aset-card16 (v a i) `(locally ,(declare-bufmac) (setf (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :unsigned-word) (the card16 ,v)))) (excl:defcmacro aref-int16 (a i) `(locally ,(declare-bufmac) (the int16 (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :signed-word)))) (excl:defcmacro aset-int16 (v a i) `(locally ,(declare-bufmac) (setf (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :signed-word) (the int16 ,v)))) (excl:defcmacro aref-card32 (a i) `(locally ,(declare-bufmac) (the card32 (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :unsigned-long)))) (excl:defcmacro aset-card32 (v a i) `(locally ,(declare-bufmac) (setf (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :unsigned-long) (the card32 ,v)))) (excl:defcmacro aref-int32 (a i) `(locally ,(declare-bufmac) (the int32 (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :signed-long)))) (excl:defcmacro aset-int32 (v a i) `(locally ,(declare-bufmac) (setf (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :signed-long) (the int32 ,v)))) (excl:defcmacro aref-card29 (a i) ;; Don't need to mask bits here since X protocol guarantees top bits zero `(locally ,(declare-bufmac) (the card29 (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :unsigned-long)))) (excl:defcmacro aset-card29 (v a i) ;; I also assume here Lisp is passing a number that fits in 29 bits. `(locally ,(declare-bufmac) (setf (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :unsigned-long) (the card29 ,v)))) ;; ;; Font accessors ;; (excl:defcmacro font-id (font) ;; Get font-id, opening font if needed (let ((f (gensym))) `(let ((,f ,font)) (or (font-id-internal ,f) (open-font-internal ,f))))) (excl:defcmacro font-font-info (font) (let ((f (gensym))) `(let ((,f ,font)) (or (font-font-info-internal ,f) (query-font ,f))))) (excl:defcmacro font-char-infos (font) (let ((f (gensym))) `(let ((,f ,font)) (or (font-char-infos-internal ,f) (progn (query-font ,f) (font-char-infos-internal ,f)))))) ;; ;; Miscellaneous ;; (excl:defcmacro current-process () `(the (or mp::process null) (and mp::*scheduler-stack-group* mp::*current-process*))) (excl:defcmacro process-wakeup (process) (let ((proc (gensym))) `(let ((.pw-curproc. mp::*current-process*) (,proc ,process)) (when (and .pw-curproc. ,proc) (if (> (mp::process-priority ,proc) (mp::process-priority .pw-curproc.)) (mp::process-allow-schedule ,proc)))))) (excl:defcmacro buffer-new-request-number (buffer) (let ((buf (gensym))) `(let ((,buf ,buffer)) (declare (type buffer ,buf)) (setf (buffer-request-number ,buf) (ldb (byte 16 0) (1+ (buffer-request-number ,buf))))))) cl-clx-sbcl-0.7.4.20160323.orig/clx-module.lisp0000644000175000017500000000024012715665272016560 0ustar pdmpdm;;;(in-package :xlib) ;;;(common-lisp:use-package (list :common-lisp)) (provide :clx) (load "clx:defsystem.lisp") (load-clx (translate-logical-pathname "CLX:"))cl-clx-sbcl-0.7.4.20160323.orig/requests.lisp0000644000175000017500000015375312715665272016404 0ustar pdmpdm;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (in-package :xlib) (defun create-window (&key window (parent (required-arg parent)) (x (required-arg x)) (y (required-arg y)) (width (required-arg width)) (height (required-arg height)) (depth 0) (border-width 0) (class :copy) (visual :copy) background border bit-gravity gravity backing-store backing-planes backing-pixel save-under event-mask do-not-propagate-mask override-redirect colormap cursor) ;; Display is obtained from parent. Only non-nil attributes are passed on in ;; the request: the function makes no assumptions about what the actual protocol ;; defaults are. Width and height are the inside size, excluding border. (declare (type (or null window) window) (type window parent) ; required (type int16 x y) ;required (type card16 width height) ;required (type card16 depth border-width) (type (member :copy :input-output :input-only) class) (type (or (member :copy) visual-info resource-id) visual) (type (or null (member :none :parent-relative) pixel pixmap) background) (type (or null (member :copy) pixel pixmap) border) (type (or null bit-gravity) bit-gravity) (type (or null win-gravity) gravity) (type (or null (member :not-useful :when-mapped :always)) backing-store) (type (or null pixel) backing-planes backing-pixel) (type (or null event-mask) event-mask) (type (or null device-event-mask) do-not-propagate-mask) (type (or null (member :on :off)) save-under override-redirect) (type (or null (member :copy) colormap) colormap) (type (or null (member :none) cursor) cursor)) (declare (clx-values window)) (let* ((display (window-display parent)) (window (or window (make-window :display display))) (wid (allocate-resource-id display window 'window)) back-pixmap back-pixel border-pixmap border-pixel) (declare (type display display) (type window window) (type resource-id wid) (type (or null resource-id) back-pixmap border-pixmap) (type (or null pixel) back-pixel border-pixel)) (setf (window-id window) wid) (case background ((nil) nil) (:none (setq back-pixmap 0)) (:parent-relative (setq back-pixmap 1)) (otherwise (if (type? background 'pixmap) (setq back-pixmap (pixmap-id background)) (if (integerp background) (setq back-pixel background) (x-type-error background '(or null (member :none :parent-relative) integer pixmap)))))) (case border ((nil) nil) (:copy (setq border-pixmap 0)) (otherwise (if (type? border 'pixmap) (setq border-pixmap (pixmap-id border)) (if (integerp border) (setq border-pixel border) (x-type-error border '(or null (member :copy) integer pixmap)))))) (when event-mask (setq event-mask (encode-event-mask event-mask))) (when do-not-propagate-mask (setq do-not-propagate-mask (encode-device-event-mask do-not-propagate-mask))) ;Make the request (with-buffer-request (display +x-createwindow+) (data depth) (resource-id wid) (window parent) (int16 x y) (card16 width height border-width) ((member16 :copy :input-output :input-only) class) (resource-id (cond ((eq visual :copy) 0) ((typep visual 'resource-id) visual) (t (visual-info-id visual)))) (mask (card32 back-pixmap back-pixel border-pixmap border-pixel) ((member-vector +bit-gravity-vector+) bit-gravity) ((member-vector +win-gravity-vector+) gravity) ((member :not-useful :when-mapped :always) backing-store) (card32 backing-planes backing-pixel) ((member :off :on) override-redirect save-under) (card32 event-mask do-not-propagate-mask) ((or (member :copy) colormap) colormap) ((or (member :none) cursor) cursor))) window)) (defun destroy-window (window) (declare (type window window)) (with-buffer-request ((window-display window) +x-destroywindow+) (window window))) (defun destroy-subwindows (window) (declare (type window window)) (with-buffer-request ((window-display window) +x-destroysubwindows+) (window window))) (defun add-to-save-set (window) (declare (type window window)) (with-buffer-request ((window-display window) +x-changesaveset+) (data 0) (window window))) (defun remove-from-save-set (window) (declare (type window window)) (with-buffer-request ((window-display window) +x-changesaveset+) (data 1) (window window))) (defun reparent-window (window parent x y) (declare (type window window parent) (type int16 x y)) (with-buffer-request ((window-display window) +x-reparentwindow+) (window window parent) (int16 x y))) (defun map-window (window) (declare (type window window)) (with-buffer-request ((window-display window) +x-mapwindow+) (window window))) (defun map-subwindows (window) (declare (type window window)) (with-buffer-request ((window-display window) +x-mapsubwindows+) (window window))) (defun unmap-window (window) (declare (type window window)) (with-buffer-request ((window-display window) +x-unmapwindow+) (window window))) (defun unmap-subwindows (window) (declare (type window window)) (with-buffer-request ((window-display window) +x-unmapsubwindows+) (window window))) (defun circulate-window-up (window) (declare (type window window)) (with-buffer-request ((window-display window) +x-circulatewindow+) (data 0) (window window))) (defun circulate-window-down (window) (declare (type window window)) (with-buffer-request ((window-display window) +x-circulatewindow+) (data 1) (window window))) (defun query-tree (window &key (result-type 'list)) (declare (type window window) (type t result-type)) ;;type specifier (declare (clx-values (clx-sequence window) parent root)) (let ((display (window-display window))) (multiple-value-bind (root parent sequence) (with-buffer-request-and-reply (display +x-querytree+ nil :sizes (8 16 32)) ((window window)) (values (window-get 8) (resource-id-get 12) (sequence-get :length (card16-get 16) :result-type result-type :index +replysize+))) ;; Parent is NIL for root window (setq parent (and (plusp parent) (lookup-window display parent))) (dotimes (i (length sequence)) ; Convert ID's to window's (setf (elt sequence i) (lookup-window display (elt sequence i)))) (values sequence parent root)))) ;; Although atom-ids are not visible in the normal user interface, atom-ids might ;; appear in window properties and other user data, so conversion hooks are needed. (defun intern-atom (display name) (declare (type display display) (type xatom name)) (declare (clx-values resource-id)) (let ((name (if (or (null name) (keywordp name)) name (kintern (string name))))) (declare (type symbol name)) (or (atom-id name display) (let ((string (symbol-name name))) (declare (type string string)) (multiple-value-bind (id) (with-buffer-request-and-reply (display +x-internatom+ 12 :sizes 32) ((data 0) (card16 (length string)) (pad16 nil) (string string)) (values (resource-id-get 8))) (declare (type resource-id id)) (setf (atom-id name display) id) id))))) (defun find-atom (display name) ;; Same as INTERN-ATOM, but with the ONLY-IF-EXISTS flag True (declare (type display display) (type xatom name)) (declare (clx-values (or null resource-id))) (let ((name (if (or (null name) (keywordp name)) name (kintern (string name))))) (declare (type symbol name)) (or (atom-id name display) (let ((string (symbol-name name))) (declare (type string string)) (multiple-value-bind (id) (with-buffer-request-and-reply (display +x-internatom+ 12 :sizes 32) ((data 1) (card16 (length string)) (pad16 nil) (string string)) (values (or-get 8 null resource-id))) (declare (type (or null resource-id) id)) (when id (setf (atom-id name display) id)) id))))) (defun atom-name (display atom-id) (declare (type display display) (type resource-id atom-id)) (declare (clx-values keyword)) (if (zerop atom-id) nil (or (id-atom atom-id display) (let ((keyword (kintern (with-buffer-request-and-reply (display +x-getatomname+ nil :sizes (16)) ((resource-id atom-id)) (values (string-get (card16-get 8) +replysize+)))))) (declare (type keyword keyword)) (setf (atom-id keyword display) atom-id) keyword)))) ;;; For binary compatibility with older code (defun lookup-xatom (display atom-id) (declare (type display display) (type resource-id atom-id)) (atom-name display atom-id)) (defun change-property (window property data type format &key (mode :replace) (start 0) end transform) ; Start and end affect sub-sequence extracted from data. ; Transform is applied to each extracted element. (declare (type window window) (type xatom property type) (type (member 8 16 32) format) (type sequence data) (type (member :replace :prepend :append) mode) (type array-index start) (type (or null array-index) end) (type (or null (function (t) integer)) transform)) (unless end (setq end (length data))) (let* ((display (window-display window)) (length (index- end start)) (property-id (intern-atom display property)) (type-id (intern-atom display type))) (declare (type display display) (type array-index length) (type resource-id property-id type-id)) (with-buffer-request (display +x-changeproperty+) ((data (member :replace :prepend :append)) mode) (window window) (resource-id property-id type-id) (card8 format) (card32 length) (progn (ecase format (8 (sequence-put 24 data :format card8 :start start :end end :transform transform)) (16 (sequence-put 24 data :format card16 :start start :end end :transform transform)) (32 (sequence-put 24 data :format card32 :start start :end end :transform transform))))))) (defun delete-property (window property) (declare (type window window) (type xatom property)) (let* ((display (window-display window)) (property-id (intern-atom display property))) (declare (type display display) (type resource-id property-id)) (with-buffer-request (display +x-deleteproperty+) (window window) (resource-id property-id)))) (defun get-property (window property &key type (start 0) end delete-p (result-type 'list) transform) ;; Transform is applied to each integer retrieved. (declare (type window window) (type xatom property) (type (or null xatom) type) (type array-index start) (type (or null array-index) end) (type generalized-boolean delete-p) (type t result-type) ;a sequence type (type (or null (function (integer) t)) transform)) (declare (clx-values data (or null type) format bytes-after)) (let* ((display (window-display window)) (property-id (intern-atom display property)) (type-id (and type (intern-atom display type)))) (declare (type display display) (type resource-id property-id) (type (or null resource-id) type-id)) (multiple-value-bind (reply-format reply-type bytes-after data) (with-buffer-request-and-reply (display +x-getproperty+ nil :sizes (8 32)) (((data boolean) delete-p) (window window) (resource-id property-id) ((or null resource-id) type-id) (card32 start) (card32 (index- (or end 64000) start))) (let ((reply-format (card8-get 1)) (reply-type (card32-get 8)) (bytes-after (card32-get 12)) (nitems (card32-get 16))) (values reply-format reply-type bytes-after (and (plusp nitems) (ecase reply-format (0 nil) ;; (make-sequence result-type 0) ;; Property not found. (8 (sequence-get :result-type result-type :format card8 :length nitems :transform transform :index +replysize+)) (16 (sequence-get :result-type result-type :format card16 :length nitems :transform transform :index +replysize+)) (32 (sequence-get :result-type result-type :format card32 :length nitems :transform transform :index +replysize+))))))) (values data (and (plusp reply-type) (atom-name display reply-type)) reply-format bytes-after)))) (defun rotate-properties (window properties &optional (delta 1)) ;; Positive rotates left, negative rotates right (opposite of actual protocol request). (declare (type window window) (type sequence properties) ;; sequence of xatom (type int16 delta)) (let* ((display (window-display window)) (length (length properties)) (sequence (make-array length))) (declare (type display display) (type array-index length)) (with-vector (sequence vector) ;; Atoms must be interned before the RotateProperties request ;; is started to allow InternAtom requests to be made. (dotimes (i length) (setf (aref sequence i) (intern-atom display (elt properties i)))) (with-buffer-request (display +x-rotateproperties+) (window window) (card16 length) (int16 (- delta)) ((sequence :end length) sequence)))) nil) (defun list-properties (window &key (result-type 'list)) (declare (type window window) (type t result-type)) ;; a sequence type (declare (clx-values (clx-sequence keyword))) (let ((display (window-display window))) (multiple-value-bind (seq) (with-buffer-request-and-reply (display +x-listproperties+ nil :sizes 16) ((window window)) (values (sequence-get :result-type result-type :length (card16-get 8) :index +replysize+))) ;; lookup the atoms in the sequence (if (listp seq) (do ((elt seq (cdr elt))) ((endp elt) seq) (setf (car elt) (atom-name display (car elt)))) (dotimes (i (length seq) seq) (setf (aref seq i) (atom-name display (aref seq i)))))))) (defun selection-owner (display selection) (declare (type display display) (type xatom selection)) (declare (clx-values (or null window))) (let ((selection-id (intern-atom display selection))) (declare (type resource-id selection-id)) (multiple-value-bind (window) (with-buffer-request-and-reply (display +x-getselectionowner+ 12 :sizes 32) ((resource-id selection-id)) (values (resource-id-or-nil-get 8))) (and window (lookup-window display window))))) (defun set-selection-owner (display selection owner &optional time) (declare (type display display) (type xatom selection) (type (or null window) owner) (type timestamp time)) (let ((selection-id (intern-atom display selection))) (declare (type resource-id selection-id)) (with-buffer-request (display +x-setselectionowner+) ((or null window) owner) (resource-id selection-id) ((or null card32) time)) owner)) (defsetf selection-owner (display selection &optional time) (owner) ;; A bit strange, but retains setf form. `(set-selection-owner ,display ,selection ,owner ,time)) (defun convert-selection (selection type requestor &optional property time) (declare (type xatom selection type) (type window requestor) (type (or null xatom) property) (type timestamp time)) (let* ((display (window-display requestor)) (selection-id (intern-atom display selection)) (type-id (intern-atom display type)) (property-id (and property (intern-atom display property)))) (declare (type display display) (type resource-id selection-id type-id) (type (or null resource-id) property-id)) (with-buffer-request (display +x-convertselection+) (window requestor) (resource-id selection-id type-id) ((or null resource-id) property-id) ((or null card32) time)))) (defun send-event (window event-key event-mask &rest args &key propagate-p display &allow-other-keys) ;; Additional arguments depend on event-key, and are as specified further below ;; with declare-event, except that both resource-ids and resource objects are ;; accepted in the event components. The display argument is only required if the ;; window is :pointer-window or :input-focus. (declare (type (or window (member :pointer-window :input-focus)) window) (type event-key event-key) (type (or null event-mask) event-mask) (type generalized-boolean propagate-p) (type (or null display) display) (dynamic-extent args)) (unless event-mask (setq event-mask 0)) (unless display (setq display (window-display window))) (let ((internal-event-code (get-event-code event-key)) (external-event-code (get-external-event-code display event-key))) (declare (type card8 internal-event-code external-event-code)) ;; Ensure keyword atom-id's are cached (dolist (arg (cdr (assoc event-key '((:property-notify :atom) (:selection-clear :selection) (:selection-request :selection :target :property) (:selection-notify :selection :target :property) (:client-message :type)) :test #'eq))) (let ((keyword (getf args arg))) (intern-atom display keyword))) ;; Make the sendevent request (with-buffer-request (display +x-sendevent+) ((data boolean) propagate-p) (length 11) ;; 3 word request + 8 words for event = 11 ((or (member :pointer-window :input-focus) window) window) (card32 (encode-event-mask event-mask)) (card8 external-event-code) (progn (apply (svref *event-send-vector* internal-event-code) display args) (setf (buffer-boffset display) (index+ buffer-boffset 44)))))) (defun grab-pointer (window event-mask &key owner-p sync-pointer-p sync-keyboard-p confine-to cursor time) (declare (type window window) (type pointer-event-mask event-mask) (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) (type (or null window) confine-to) (type (or null cursor) cursor) (type timestamp time)) (declare (clx-values grab-status)) (let ((display (window-display window))) (with-buffer-request-and-reply (display +x-grabpointer+ nil :sizes 8) (((data boolean) owner-p) (window window) (card16 (encode-pointer-event-mask event-mask)) (boolean (not sync-pointer-p) (not sync-keyboard-p)) ((or null window) confine-to) ((or null cursor) cursor) ((or null card32) time)) (values (member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen))))) (defun ungrab-pointer (display &key time) (declare (type timestamp time)) (with-buffer-request (display +x-ungrabpointer+) ((or null card32) time))) (defun grab-button (window button event-mask &key (modifiers :any) owner-p sync-pointer-p sync-keyboard-p confine-to cursor) (declare (type window window) (type (or (member :any) card8) button) (type modifier-mask modifiers) (type pointer-event-mask event-mask) (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) (type (or null window) confine-to) (type (or null cursor) cursor)) (with-buffer-request ((window-display window) +x-grabbutton+) ((data boolean) owner-p) (window window) (card16 (encode-pointer-event-mask event-mask)) (boolean (not sync-pointer-p) (not sync-keyboard-p)) ((or null window) confine-to) ((or null cursor) cursor) (card8 (if (eq button :any) 0 button)) (pad8 1) (card16 (encode-modifier-mask modifiers)))) (defun ungrab-button (window button &key (modifiers :any)) (declare (type window window) (type (or (member :any) card8) button) (type modifier-mask modifiers)) (with-buffer-request ((window-display window) +x-ungrabbutton+) (data (if (eq button :any) 0 button)) (window window) (card16 (encode-modifier-mask modifiers)))) (defun change-active-pointer-grab (display event-mask &optional cursor time) (declare (type display display) (type pointer-event-mask event-mask) (type (or null cursor) cursor) (type timestamp time)) (with-buffer-request (display +x-changeactivepointergrab+) ((or null cursor) cursor) ((or null card32) time) (card16 (encode-pointer-event-mask event-mask)))) (defun grab-keyboard (window &key owner-p sync-pointer-p sync-keyboard-p time) (declare (type window window) (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) (type timestamp time)) (declare (clx-values grab-status)) (let ((display (window-display window))) (with-buffer-request-and-reply (display +x-grabkeyboard+ nil :sizes 8) (((data boolean) owner-p) (window window) ((or null card32) time) (boolean (not sync-pointer-p) (not sync-keyboard-p))) (values (member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen))))) (defun ungrab-keyboard (display &key time) (declare (type display display) (type timestamp time)) (with-buffer-request (display +x-ungrabkeyboard+) ((or null card32) time))) (defun grab-key (window key &key (modifiers 0) owner-p sync-pointer-p sync-keyboard-p) (declare (type window window) (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) (type (or (member :any) card8) key) (type modifier-mask modifiers)) (with-buffer-request ((window-display window) +x-grabkey+) ((data boolean) owner-p) (window window) (card16 (encode-modifier-mask modifiers)) (card8 (if (eq key :any) 0 key)) (boolean (not sync-pointer-p) (not sync-keyboard-p)))) (defun ungrab-key (window key &key (modifiers 0)) (declare (type window window) (type (or (member :any) card8) key) (type modifier-mask modifiers)) (with-buffer-request ((window-display window) +x-ungrabkey+) (data (if (eq key :any) 0 key)) (window window) (card16 (encode-modifier-mask modifiers)))) (defun allow-events (display mode &optional time) (declare (type display display) (type (member :async-pointer :sync-pointer :replay-pointer :async-keyboard :sync-keyboard :replay-keyboard :async-both :sync-both) mode) (type timestamp time)) (with-buffer-request (display +x-allowevents+) ((data (member :async-pointer :sync-pointer :replay-pointer :async-keyboard :sync-keyboard :replay-keyboard :async-both :sync-both)) mode) ((or null card32) time))) (defun grab-server (display) (declare (type display display)) (with-buffer-request (display +x-grabserver+))) (defun ungrab-server (display) (with-buffer-request (display +x-ungrabserver+))) (defmacro with-server-grabbed ((display) &body body) ;; The body is not surrounded by a with-display. (let ((disp (if (symbolp display) display (gensym)))) `(let ((,disp ,display)) (declare (type display ,disp)) (unwind-protect (progn (grab-server ,disp) ,@body) (ungrab-server ,disp))))) (defun query-pointer (window) (declare (type window window)) (declare (clx-values x y same-screen-p child mask root-x root-y root)) (let ((display (window-display window))) (with-buffer-request-and-reply (display +x-querypointer+ 26 :sizes (8 16 32)) ((window window)) (values (int16-get 20) (int16-get 22) (boolean-get 1) (or-get 12 null window) (card16-get 24) (int16-get 16) (int16-get 18) (window-get 8))))) (defun pointer-position (window) (declare (type window window)) (declare (clx-values x y same-screen-p)) (let ((display (window-display window))) (with-buffer-request-and-reply (display +x-querypointer+ 24 :sizes (8 16)) ((window window)) (values (int16-get 20) (int16-get 22) (boolean-get 1))))) (defun global-pointer-position (display) (declare (type display display)) (declare (clx-values root-x root-y root)) (with-buffer-request-and-reply (display +x-querypointer+ 20 :sizes (16 32)) ((window (screen-root (first (display-roots display))))) (values (int16-get 16) (int16-get 18) (window-get 8)))) (defun motion-events (window &key start stop (result-type 'list)) (declare (type window window) (type timestamp start stop) (type t result-type)) ;; a type specifier (declare (clx-values (repeat-seq (integer x) (integer y) (timestamp time)))) (let ((display (window-display window))) (with-buffer-request-and-reply (display +x-getmotionevents+ nil :sizes 32) ((window window) ((or null card32) start stop)) (values (sequence-get :result-type result-type :length (index* (card32-get 8) 3) :index +replysize+))))) (defun translate-coordinates (src src-x src-y dst) ;; Returns NIL when not on the same screen (declare (type window src) (type int16 src-x src-y) (type window dst)) (declare (clx-values dst-x dst-y child)) (let ((display (window-display src))) (with-buffer-request-and-reply (display +x-translatecoords+ 16 :sizes (8 16 32)) ((window src dst) (int16 src-x src-y)) (and (boolean-get 1) (values (int16-get 12) (int16-get 14) (or-get 8 null window)))))) (defun warp-pointer (dst dst-x dst-y) (declare (type window dst) (type int16 dst-x dst-y)) (with-buffer-request ((window-display dst) +x-warppointer+) (resource-id 0) ;; None (window dst) (int16 0 0) (card16 0 0) (int16 dst-x dst-y))) (defun warp-pointer-relative (display x-off y-off) (declare (type display display) (type int16 x-off y-off)) (with-buffer-request (display +x-warppointer+) (resource-id 0) ;; None (resource-id 0) ;; None (int16 0 0) (card16 0 0) (int16 x-off y-off))) (defun warp-pointer-if-inside (dst dst-x dst-y src src-x src-y &optional src-width src-height) ;; Passing in a zero src-width or src-height is a no-op. ;; A null src-width or src-height translates into a zero value in the protocol request. (declare (type window dst src) (type int16 dst-x dst-y src-x src-y) (type (or null card16) src-width src-height)) (unless (or (eql src-width 0) (eql src-height 0)) (with-buffer-request ((window-display dst) +x-warppointer+) (window src dst) (int16 src-x src-y) (card16 (or src-width 0) (or src-height 0)) (int16 dst-x dst-y)))) (defun warp-pointer-relative-if-inside (x-off y-off src src-x src-y &optional src-width src-height) ;; Passing in a zero src-width or src-height is a no-op. ;; A null src-width or src-height translates into a zero value in the protocol request. (declare (type window src) (type int16 x-off y-off src-x src-y) (type (or null card16) src-width src-height)) (unless (or (eql src-width 0) (eql src-height 0)) (with-buffer-request ((window-display src) +x-warppointer+) (window src) (resource-id 0) ;; None (int16 src-x src-y) (card16 (or src-width 0) (or src-height 0)) (int16 x-off y-off)))) (defun set-input-focus (display focus revert-to &optional time) (declare (type display display) (type (or (member :none :pointer-root) window) focus) (type (member :none :pointer-root :parent) revert-to) (type timestamp time)) (with-buffer-request (display +x-setinputfocus+) ((data (member :none :pointer-root :parent)) revert-to) ((or window (member :none :pointer-root)) focus) ((or null card32) time))) (defun input-focus (display) (declare (type display display)) (declare (clx-values focus revert-to)) (with-buffer-request-and-reply (display +x-getinputfocus+ 16 :sizes (8 32)) () (values (or-get 8 window (member :none :pointer-root)) (member8-get 1 :none :pointer-root :parent)))) (defun query-keymap (display &optional bit-vector) (declare (type display display) (type (or null (bit-vector 256)) bit-vector)) (declare (clx-values (bit-vector 256))) (with-buffer-request-and-reply (display +x-querykeymap+ 40 :sizes 8) () (values (bit-vector256-get 8 8 bit-vector)))) (defun create-pixmap (&key pixmap (width (required-arg width)) (height (required-arg height)) (depth (required-arg depth)) (drawable (required-arg drawable))) (declare (type (or null pixmap) pixmap) (type card8 depth) ;; required (type card16 width height) ;; required (type drawable drawable)) ;; required (declare (clx-values pixmap)) (let* ((display (drawable-display drawable)) (pixmap (or pixmap (make-pixmap :display display))) (pid (allocate-resource-id display pixmap 'pixmap))) (setf (pixmap-id pixmap) pid) (with-buffer-request (display +x-createpixmap+) (data depth) (resource-id pid) (drawable drawable) (card16 width height)) pixmap)) (defun free-pixmap (pixmap) (declare (type pixmap pixmap)) (let ((display (pixmap-display pixmap))) (with-buffer-request (display +x-freepixmap+) (pixmap pixmap)) (deallocate-resource-id display (pixmap-id pixmap) 'pixmap))) (defun clear-area (window &key (x 0) (y 0) width height exposures-p) ;; Passing in a zero width or height is a no-op. ;; A null width or height translates into a zero value in the protocol request. (declare (type window window) (type int16 x y) (type (or null card16) width height) (type generalized-boolean exposures-p)) (unless (or (eql width 0) (eql height 0)) (with-buffer-request ((window-display window) +x-cleartobackground+) ((data boolean) exposures-p) (window window) (int16 x y) (card16 (or width 0) (or height 0))))) (defun copy-area (src gcontext src-x src-y width height dst dst-x dst-y) (declare (type drawable src dst) (type gcontext gcontext) (type int16 src-x src-y dst-x dst-y) (type card16 width height)) (with-buffer-request ((drawable-display src) +x-copyarea+ :gc-force gcontext) (drawable src dst) (gcontext gcontext) (int16 src-x src-y dst-x dst-y) (card16 width height))) (defun copy-plane (src gcontext plane src-x src-y width height dst dst-x dst-y) (declare (type drawable src dst) (type gcontext gcontext) (type pixel plane) (type int16 src-x src-y dst-x dst-y) (type card16 width height)) (with-buffer-request ((drawable-display src) +x-copyplane+ :gc-force gcontext) (drawable src dst) (gcontext gcontext) (int16 src-x src-y dst-x dst-y) (card16 width height) (card32 plane))) (defun create-colormap (visual-info window &optional alloc-p) (declare (type (or visual-info resource-id) visual-info) (type window window) (type generalized-boolean alloc-p)) (declare (clx-values colormap)) (let ((display (window-display window))) (when (typep visual-info 'resource-id) (setf visual-info (visual-info display visual-info))) (let* ((colormap (make-colormap :display display :visual-info visual-info)) (id (allocate-resource-id display colormap 'colormap))) (setf (colormap-id colormap) id) (with-buffer-request (display +x-createcolormap+) ((data boolean) alloc-p) (card29 id) (window window) (card29 (visual-info-id visual-info))) colormap))) (defun free-colormap (colormap) (declare (type colormap colormap)) (let ((display (colormap-display colormap))) (with-buffer-request (display +x-freecolormap+) (colormap colormap)) (deallocate-resource-id display (colormap-id colormap) 'colormap))) (defun copy-colormap-and-free (colormap) (declare (type colormap colormap)) (declare (clx-values colormap)) (let* ((display (colormap-display colormap)) (new-colormap (make-colormap :display display :visual-info (colormap-visual-info colormap))) (id (allocate-resource-id display new-colormap 'colormap))) (setf (colormap-id new-colormap) id) (with-buffer-request (display +x-copycolormapandfree+) (resource-id id) (colormap colormap)) new-colormap)) (defun install-colormap (colormap) (declare (type colormap colormap)) (with-buffer-request ((colormap-display colormap) +x-installcolormap+) (colormap colormap))) (defun uninstall-colormap (colormap) (declare (type colormap colormap)) (with-buffer-request ((colormap-display colormap) +x-uninstallcolormap+) (colormap colormap))) (defun installed-colormaps (window &key (result-type 'list)) (declare (type window window) (type t result-type)) ;; CL type (declare (clx-values (clx-sequence colormap))) (let ((display (window-display window))) (flet ((get-colormap (id) (lookup-colormap display id))) (with-buffer-request-and-reply (display +x-listinstalledcolormaps+ nil :sizes 16) ((window window)) (values (sequence-get :result-type result-type :length (card16-get 8) :transform #'get-colormap :index +replysize+)))))) (defun alloc-color (colormap color) (declare (type colormap colormap) (type (or stringable color) color)) (declare (clx-values pixel screen-color exact-color)) (let ((display (colormap-display colormap))) (etypecase color (color (with-buffer-request-and-reply (display +x-alloccolor+ 20 :sizes (16 32)) ((colormap colormap) (rgb-val (color-red color) (color-green color) (color-blue color)) (pad16 nil)) (values (card32-get 16) (make-color :red (rgb-val-get 8) :green (rgb-val-get 10) :blue (rgb-val-get 12)) color))) (stringable (let* ((string (string color)) (length (length string))) (with-buffer-request-and-reply (display +x-allocnamedcolor+ 24 :sizes (16 32)) ((colormap colormap) (card16 length) (pad16 nil) (string string)) (values (card32-get 8) (make-color :red (rgb-val-get 18) :green (rgb-val-get 20) :blue (rgb-val-get 22)) (make-color :red (rgb-val-get 12) :green (rgb-val-get 14) :blue (rgb-val-get 16))))))))) (defun alloc-color-cells (colormap colors &key (planes 0) contiguous-p (result-type 'list)) (declare (type colormap colormap) (type card16 colors planes) (type generalized-boolean contiguous-p) (type t result-type)) ;; CL type (declare (clx-values (clx-sequence pixel) (clx-sequence mask))) (let ((display (colormap-display colormap))) (with-buffer-request-and-reply (display +x-alloccolorcells+ nil :sizes 16) (((data boolean) contiguous-p) (colormap colormap) (card16 colors planes)) (let ((pixel-length (card16-get 8)) (mask-length (card16-get 10))) (values (sequence-get :result-type result-type :length pixel-length :index +replysize+) (sequence-get :result-type result-type :length mask-length :index (index+ +replysize+ (index* pixel-length 4)))))))) (defun alloc-color-planes (colormap colors &key (reds 0) (greens 0) (blues 0) contiguous-p (result-type 'list)) (declare (type colormap colormap) (type card16 colors reds greens blues) (type generalized-boolean contiguous-p) (type t result-type)) ;; CL type (declare (clx-values (clx-sequence pixel) red-mask green-mask blue-mask)) (let ((display (colormap-display colormap))) (with-buffer-request-and-reply (display +x-alloccolorplanes+ nil :sizes (16 32)) (((data boolean) contiguous-p) (colormap colormap) (card16 colors reds greens blues)) (let ((red-mask (card32-get 12)) (green-mask (card32-get 16)) (blue-mask (card32-get 20))) (values (sequence-get :result-type result-type :length (card16-get 8) :index +replysize+) red-mask green-mask blue-mask))))) (defun free-colors (colormap pixels &optional (plane-mask 0)) (declare (type colormap colormap) (type sequence pixels) ;; Sequence of integers (type pixel plane-mask)) (with-buffer-request ((colormap-display colormap) +x-freecolors+) (colormap colormap) (card32 plane-mask) (sequence pixels))) (defun store-color (colormap pixel spec &key (red-p t) (green-p t) (blue-p t)) (declare (type colormap colormap) (type pixel pixel) (type (or stringable color) spec) (type generalized-boolean red-p green-p blue-p)) (let ((display (colormap-display colormap)) (flags 0)) (declare (type display display) (type card8 flags)) (when red-p (setq flags 1)) (when green-p (incf flags 2)) (when blue-p (incf flags 4)) (etypecase spec (color (with-buffer-request (display +x-storecolors+) (colormap colormap) (card32 pixel) (rgb-val (color-red spec) (color-green spec) (color-blue spec)) (card8 flags) (pad8 nil))) (stringable (let* ((string (string spec)) (length (length string))) (with-buffer-request (display +x-storenamedcolor+) ((data card8) flags) (colormap colormap) (card32 pixel) (card16 length) (pad16 nil) (string string))))))) (defun store-colors (colormap specs &key (red-p t) (green-p t) (blue-p t)) ;; If stringables are specified for colors, it is unspecified whether all ;; stringables are first resolved and then a single StoreColors protocol request is ;; issued, or whether multiple StoreColors protocol requests are issued. (declare (type colormap colormap) (type sequence specs) (type generalized-boolean red-p green-p blue-p)) (etypecase specs (list (do ((spec specs (cddr spec))) ((endp spec)) (store-color colormap (car spec) (cadr spec) :red-p red-p :green-p green-p :blue-p blue-p))) (vector (do ((i 0 (+ i 2)) (len (length specs))) ((>= i len)) (store-color colormap (aref specs i) (aref specs (1+ i)) :red-p red-p :green-p green-p :blue-p blue-p))))) (defun query-colors (colormap pixels &key (result-type 'list)) (declare (type colormap colormap) (type sequence pixels) ;; sequence of integer (type t result-type)) ;; a type specifier (declare (clx-values (clx-sequence color))) (let ((display (colormap-display colormap))) (with-buffer-request-and-reply (display +x-querycolors+ nil :sizes (8 16)) ((colormap colormap) (sequence pixels)) (let ((sequence (make-sequence result-type (card16-get 8)))) (advance-buffer-offset +replysize+) (dotimes (i (length sequence) sequence) (setf (elt sequence i) (make-color :red (rgb-val-get 0) :green (rgb-val-get 2) :blue (rgb-val-get 4))) (advance-buffer-offset 8)))))) (defun lookup-color (colormap name) (declare (type colormap colormap) (type stringable name)) (declare (clx-values screen-color true-color)) (let* ((display (colormap-display colormap)) (string (string name)) (length (length string))) (with-buffer-request-and-reply (display +x-lookupcolor+ 20 :sizes 16) ((colormap colormap) (card16 length) (pad16 nil) (string string)) (values (make-color :red (rgb-val-get 14) :green (rgb-val-get 16) :blue (rgb-val-get 18)) (make-color :red (rgb-val-get 8) :green (rgb-val-get 10) :blue (rgb-val-get 12)))))) (defun create-cursor (&key (source (required-arg source)) mask (x (required-arg x)) (y (required-arg y)) (foreground (required-arg foreground)) (background (required-arg background))) (declare (type pixmap source) ;; required (type (or null pixmap) mask) (type card16 x y) ;; required (type (or null color) foreground background)) ;; required (declare (clx-values cursor)) (let* ((display (pixmap-display source)) (cursor (make-cursor :display display)) (cid (allocate-resource-id display cursor 'cursor))) (setf (cursor-id cursor) cid) (with-buffer-request (display +x-createcursor+) (resource-id cid) (pixmap source) ((or null pixmap) mask) (rgb-val (color-red foreground) (color-green foreground) (color-blue foreground)) (rgb-val (color-red background) (color-green background) (color-blue background)) (card16 x y)) cursor)) (defun create-glyph-cursor (&key (source-font (required-arg source-font)) (source-char (required-arg source-char)) mask-font mask-char (foreground (required-arg foreground)) (background (required-arg background))) (declare (type font source-font) ;; Required (type card16 source-char) ;; Required (type (or null font) mask-font) (type (or null card16) mask-char) (type color foreground background)) ;; required (declare (clx-values cursor)) (let* ((display (font-display source-font)) (cursor (make-cursor :display display)) (cid (allocate-resource-id display cursor 'cursor)) (source-font-id (font-id source-font)) (mask-font-id (if mask-font (font-id mask-font) 0))) (setf (cursor-id cursor) cid) (unless mask-char (setq mask-char 0)) (with-buffer-request (display +x-createglyphcursor+) (resource-id cid source-font-id mask-font-id) (card16 source-char) (card16 mask-char) (rgb-val (color-red foreground) (color-green foreground) (color-blue foreground)) (rgb-val (color-red background) (color-green background) (color-blue background))) cursor)) (defun free-cursor (cursor) (declare (type cursor cursor)) (let ((display (cursor-display cursor))) (with-buffer-request (display +x-freecursor+) (cursor cursor)) (deallocate-resource-id display (cursor-id cursor) 'cursor))) (defun recolor-cursor (cursor foreground background) (declare (type cursor cursor) (type color foreground background)) (with-buffer-request ((cursor-display cursor) +x-recolorcursor+) (cursor cursor) (rgb-val (color-red foreground) (color-green foreground) (color-blue foreground)) (rgb-val (color-red background) (color-green background) (color-blue background)) )) (defun query-best-cursor (width height drawable) (declare (type card16 width height) (type (or drawable display) drawable)) (declare (clx-values width height)) ;; Drawable can be a display for compatibility. (multiple-value-bind (display drawable) (if (type? drawable 'drawable) (values (drawable-display drawable) drawable) (values drawable (screen-root (display-default-screen drawable)))) (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16) ((data 0) (window drawable) (card16 width height)) (values (card16-get 8) (card16-get 10))))) (defun query-best-tile (width height drawable) (declare (type card16 width height) (type drawable drawable)) (declare (clx-values width height)) (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16) ((data 1) (drawable drawable) (card16 width height)) (values (card16-get 8) (card16-get 10))))) (defun query-best-stipple (width height drawable) (declare (type card16 width height) (type drawable drawable)) (declare (clx-values width height)) (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16) ((data 2) (drawable drawable) (card16 width height)) (values (card16-get 8) (card16-get 10))))) (defun query-extension (display name) (declare (type display display) (type stringable name)) (declare (clx-values major-opcode first-event first-error)) (let ((string (string name))) (with-buffer-request-and-reply (display +x-queryextension+ 12 :sizes 8) ((card16 (length string)) (pad16 nil) (string string)) (and (boolean-get 8) ;; If present (values (card8-get 9) (card8-get 10) (card8-get 11)))))) (defun list-extensions (display &key (result-type 'list)) (declare (type display display) (type t result-type)) ;; CL type (declare (clx-values (clx-sequence string))) (with-buffer-request-and-reply (display +x-listextensions+ size :sizes 8) () (values (read-sequence-string buffer-bbuf (index- size +replysize+) (card8-get 1) result-type +replysize+)))) (defun change-keyboard-control (display &key key-click-percent bell-percent bell-pitch bell-duration led led-mode key auto-repeat-mode) (declare (type display display) (type (or null (member :default) int16) key-click-percent bell-percent bell-pitch bell-duration) (type (or null card8) led key) (type (or null (member :on :off)) led-mode) (type (or null (member :on :off :default)) auto-repeat-mode)) (when (eq key-click-percent :default) (setq key-click-percent -1)) (when (eq bell-percent :default) (setq bell-percent -1)) (when (eq bell-pitch :default) (setq bell-pitch -1)) (when (eq bell-duration :default) (setq bell-duration -1)) (with-buffer-request (display +x-changekeyboardcontrol+ :sizes (32)) (mask (integer key-click-percent bell-percent bell-pitch bell-duration) (card32 led) ((member :off :on) led-mode) (card32 key) ((member :off :on :default) auto-repeat-mode)))) (defun keyboard-control (display) (declare (type display display)) (declare (clx-values key-click-percent bell-percent bell-pitch bell-duration led-mask global-auto-repeat auto-repeats)) (with-buffer-request-and-reply (display +x-getkeyboardcontrol+ 32 :sizes (8 16 32)) () (values (card8-get 12) (card8-get 13) (card16-get 14) (card16-get 16) (card32-get 8) (member8-get 1 :off :on) (bit-vector256-get 20)))) ;; The base volume should ;; be considered to be the "desired" volume in the normal case; that is, a ;; typical application should call XBell with 0 as the percent. Rather ;; than using a simple sum, the percent argument is instead used as the ;; percentage of the remaining range to alter the base volume by. That is, ;; the actual volume is: ;; if percent>=0: base - [(base * percent) / 100] + percent ;; if percent<0: base + [(base * percent) / 100] (defun bell (display &optional (percent-from-normal 0)) ;; It is assumed that an eventual audio extension to X will provide more complete control. (declare (type display display) (type int8 percent-from-normal)) (with-buffer-request (display +x-bell+) (data (int8->card8 percent-from-normal)))) (defun pointer-mapping (display &key (result-type 'list)) (declare (type display display) (type t result-type)) ;; CL type (declare (clx-values sequence)) ;; Sequence of card (with-buffer-request-and-reply (display +x-getpointermapping+ nil :sizes 8) () (values (sequence-get :length (card8-get 1) :result-type result-type :format card8 :index +replysize+)))) (defun set-pointer-mapping (display map) ;; Can signal device-busy. (declare (type display display) (type sequence map)) ;; Sequence of card8 (when (with-buffer-request-and-reply (display +x-setpointermapping+ 2 :sizes 8) ((data (length map)) ((sequence :format card8) map)) (values (boolean-get 1))) (x-error 'device-busy :display display)) map) (defsetf pointer-mapping set-pointer-mapping) (defun change-pointer-control (display &key acceleration threshold) ;; Acceleration is rationalized if necessary. (declare (type display display) (type (or null (member :default) number) acceleration) (type (or null (member :default) integer) threshold)) (flet ((rationalize16 (number) ;; Rationalize NUMBER into the ratio of two signed 16 bit numbers (declare (type number number)) (declare (clx-values numerator denominator)) (do* ((rational (rationalize number)) (numerator (numerator rational) (ash numerator -1)) (denominator (denominator rational) (ash denominator -1))) ((or (= numerator 1) (and (< (abs numerator) #x8000) (< denominator #x8000))) (values numerator (min denominator #x7fff)))))) (declare (inline rationalize16)) (let ((acceleration-p 1) (threshold-p 1) (numerator 0) (denominator 1)) (declare (type card8 acceleration-p threshold-p) (type int16 numerator denominator)) (cond ((eq acceleration :default) (setq numerator -1)) (acceleration (multiple-value-setq (numerator denominator) (rationalize16 acceleration))) (t (setq acceleration-p 0))) (cond ((eq threshold :default) (setq threshold -1)) ((null threshold) (setq threshold -1 threshold-p 0))) (with-buffer-request (display +x-changepointercontrol+) (int16 numerator denominator threshold) (card8 acceleration-p threshold-p))))) (defun pointer-control (display) (declare (type display display)) (declare (clx-values acceleration threshold)) (with-buffer-request-and-reply (display +x-getpointercontrol+ 16 :sizes 16) () (values (/ (card16-get 8) (card16-get 10)) ; Should we float this? (card16-get 12)))) (defun set-screen-saver (display timeout interval blanking exposures) ;; Timeout and interval are in seconds, will be rounded to minutes. (declare (type display display) (type (or (member :default) int16) timeout interval) (type (member :on :off :default :yes :no) blanking exposures)) (case blanking (:yes (setq blanking :on)) (:no (setq blanking :off))) (case exposures (:yes (setq exposures :on)) (:no (setq exposures :off))) (when (eq timeout :default) (setq timeout -1)) (when (eq interval :default) (setq interval -1)) (with-buffer-request (display +x-setscreensaver+) (int16 timeout interval) ((member8 :on :off :default) blanking exposures))) (defun screen-saver (display) ;; Returns timeout and interval in seconds. (declare (type display display)) (declare (clx-values timeout interval blanking exposures)) (with-buffer-request-and-reply (display +x-getscreensaver+ 14 :sizes (8 16)) () (values (card16-get 8) (card16-get 10) (member8-get 12 :on :off :default) (member8-get 13 :on :off :default)))) (defun activate-screen-saver (display) (declare (type display display)) (with-buffer-request (display +x-forcescreensaver+) (data 1))) (defun reset-screen-saver (display) (declare (type display display)) (with-buffer-request (display +x-forcescreensaver+) (data 0))) (defun add-access-host (display host &optional (family :internet)) ;; A string must be acceptable as a host, but otherwise the possible types for ;; host are not constrained, and will likely be very system dependent. ;; This implementation uses a list whose car is the family keyword ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes. (declare (type display display) (type (or stringable list) host) (type (or null (member :internet :decnet :chaos) card8) family)) (change-access-host display host family nil)) (defun remove-access-host (display host &optional (family :internet)) ;; A string must be acceptable as a host, but otherwise the possible types for ;; host are not constrained, and will likely be very system dependent. ;; This implementation uses a list whose car is the family keyword ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes. (declare (type display display) (type (or stringable list) host) (type (or null (member :internet :decnet :chaos) card8) family)) (change-access-host display host family t)) (defun change-access-host (display host family remove-p) (declare (type display display) (type (or stringable list) host) (type (or null (member :internet :decnet :chaos) card8) family)) (unless (consp host) (setq host (host-address host family))) (let ((family (car host)) (address (cdr host))) (with-buffer-request (display +x-changehosts+) ((data boolean) remove-p) (card8 (encode-type (or null (member :internet :decnet :chaos) card32) family)) (card16 (length address)) ((sequence :format card8) address)))) (defun access-hosts (display &optional (result-type 'list)) ;; The type of host objects returned is not constrained, except that the hosts must ;; be acceptable to add-access-host and remove-access-host. ;; This implementation uses a list whose car is the family keyword ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes. (declare (type display display) (type t result-type)) ;; CL type (declare (clx-values (clx-sequence host) enabled-p)) (with-buffer-request-and-reply (display +x-listhosts+ nil :sizes (8 16)) () (let* ((enabled-p (boolean-get 1)) (nhosts (card16-get 8)) (sequence (make-sequence result-type nhosts))) (advance-buffer-offset +replysize+) (dotimes (i nhosts) (let ((family (card8-get 0)) (len (card16-get 2))) (setf (elt sequence i) (cons (if (< family 3) (svref '#(:internet :decnet :chaos) family) family) (sequence-get :length len :format card8 :result-type 'list :index (+ buffer-boffset 4)))) (advance-buffer-offset (+ 4 (* 4 (ceiling len 4)))))) (values sequence enabled-p)))) (defun access-control (display) (declare (type display display)) (declare (clx-values generalized-boolean)) ;; True when access-control is ENABLED (with-buffer-request-and-reply (display +x-listhosts+ 2 :sizes 8) () (boolean-get 1))) (defun set-access-control (display enabled-p) (declare (type display display) (type generalized-boolean enabled-p)) (with-buffer-request (display +x-changeaccesscontrol+) ((data boolean) enabled-p)) enabled-p) (defsetf access-control set-access-control) (defun close-down-mode (display) ;; setf'able ;; Cached locally in display object. (declare (type display display)) (declare (clx-values (member :destroy :retain-permanent :retain-temporary nil))) (display-close-down-mode display)) (defun set-close-down-mode (display mode) ;; Cached locally in display object. (declare (type display display) (type (member :destroy :retain-permanent :retain-temporary) mode)) (setf (display-close-down-mode display) mode) (with-buffer-request (display +x-changeclosedownmode+ :sizes (32)) ((data (member :destroy :retain-permanent :retain-temporary)) mode)) mode) (defsetf close-down-mode set-close-down-mode) (defun kill-client (display resource-id) (declare (type display display) (type resource-id resource-id)) (with-buffer-request (display +x-killclient+) (resource-id resource-id))) (defun kill-temporary-clients (display) (declare (type display display)) (with-buffer-request (display +x-killclient+) (resource-id 0))) (defun no-operation (display) (declare (type display display)) (with-buffer-request (display +x-nooperation+))) cl-clx-sbcl-0.7.4.20160323.orig/excldep.c0000644000175000017500000000346612715665272015423 0ustar pdmpdm/* * Allegro CL dependent C helper routines for CLX */ /* * This code requires select and interval timers. * This means you probably need BSD, or a version * of Unix with select and interval timers added. */ #include #include #include #include #define ERROR -1 #define INTERRUPT -2 #define TIMEOUT 0 #define SUCCESS 1 #ifdef FD_SETSIZE #define NUMBER_OF_FDS FD_SETSIZE /* Highest possible file descriptor */ #else #define NUMBER_OF_FDS 32 #endif /* Length of array needed to hold all file descriptor bits */ #define CHECKLEN ((NUMBER_OF_FDS+8*sizeof(int)-1) / (8 * sizeof(int))) extern int errno; /* * This function waits for input to become available on 'fd'. If timeout is * 0, wait forever. Otherwise wait 'timeout' seconds. If input becomes * available before the timer expires, return SUCCESS. If the timer expires * return TIMEOUT. If an error occurs, return ERROR. If an interrupt occurs * while waiting, return INTERRUPT. */ int fd_wait_for_input(fd, timeout) register int fd; register int timeout; { struct timeval timer; register int i; int checkfds[CHECKLEN]; if (fd < 0 || fd >= NUMBER_OF_FDS) { fprintf(stderr, "Bad file descriptor argument: %d to fd_wait_for_input\n", fd); fflush(stderr); } for (i = 0; i < CHECKLEN; i++) checkfds[i] = 0; checkfds[fd / (8 * sizeof(int))] |= 1 << (fd % (8 * sizeof(int))); if (timeout) { timer.tv_sec = timeout; timer.tv_usec = 0; i = select(32, checkfds, (int *)0, (int *)0, &timer); } else i = select(32, checkfds, (int *)0, (int *)0, (struct timeval *)0); if (i < 0) /* error condition */ if (errno == EINTR) return (INTERRUPT); else return (ERROR); else if (i == 0) return (TIMEOUT); else return (SUCCESS); } cl-clx-sbcl-0.7.4.20160323.orig/clx.asd0000644000175000017500000001673312715665272015113 0ustar pdmpdm;;; -*- Lisp -*- mode ;;; Original copyright message from defsystem.lisp: ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Portions Copyright (C) 1987 Texas Instruments Incorporated. ;;; Portions Copyright (C) 1988, 1989 Franz Inc, Berkeley, Ca. ;;; ;;; Permission is granted to any individual or institution to use, ;;; copy, modify, and distribute this software, provided that this ;;; complete copyright and permission notice is maintained, intact, in ;;; all copies and supporting documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" ;;; without express or implied warranty. ;;; ;;; Franz Incorporated provides this software "as is" without express ;;; or implied warranty. (defpackage :clx-system (:use :cl :asdf)) (in-package :clx-system) (pushnew :clx-ansi-common-lisp *features*) (defclass clx-source-file (cl-source-file) ()) (defclass xrender-source-file (clx-source-file) ()) ;;; CL-SOURCE-FILE, not CLX-SOURCE-FILE, so that we're not accused of ;;; cheating by rebinding *DERIVE-FUNCTION-TYPES* :-) (defclass example-source-file (cl-source-file) ()) (defclass legacy-file (static-file) ()) (defsystem CLX :description "An implementation of the X Window System protocol in Lisp." :depends-on (#+sbcl sb-bsd-sockets) :version "0.7.2" :serial t :default-component-class clx-source-file :components ((:file "package") (:file "depdefs") (:file "clx") #-(or openmcl allegro lispworks) (:file "dependent") #+openmcl (:file "dep-openmcl") #+allegro (:file "dep-allegro") #+lispworks (:file "dep-lispworks") (:file "macros") (:file "bufmac") (:file "buffer") (:file "display") (:file "gcontext") (:file "input") (:file "requests") (:file "fonts") (:file "graphics") (:file "text") (:file "attributes") (:file "translate") (:file "keysyms") (:file "manager") (:file "image") (:file "resource") #+allegro (:file "excldep" :pathname "excldep.lisp") (:module extensions :pathname #.(make-pathname :directory '(:relative)) :components ((:file "shape") (:file "big-requests") (:file "xvidmode") (:xrender-source-file "xrender") (:file "glx") (:file "gl" :depends-on ("glx")) (:file "dpms") (:file "xtest") (:file "screensaver") (:file "xinerama"))) (:module demo :default-component-class example-source-file :components ((:file "bezier") ;; KLUDGE: this requires "bezier" for proper operation, ;; but we don't declare that dependency here, because ;; asdf doesn't load example files anyway. (:file "beziertest") (:file "clclock") (:file "clipboard") (:file "clx-demos") (:file "gl-test") ;; FIXME: compiling this generates 30-odd spurious code ;; deletion notes. Find out why, and either fix or ;; workaround the problem. (:file "mandel") (:file "menu") (:file "zoid"))) (:module test :default-component-class example-source-file :components ((:file "image") ;; KLUDGE: again, this depends on "zoid" (:file "trapezoid"))) (:static-file "NEWS") (:static-file "CHANGES") (:static-file "README") (:static-file "README-R5") (:legacy-file "exclMakefile") (:legacy-file "exclREADME") (:legacy-file "exclcmac" :pathname "exclcmac.lisp") (:legacy-file "excldepc" :pathname "excldep.c") (:legacy-file "sockcl" :pathname "sockcl.lisp") (:legacy-file "socket" :pathname "socket.c") (:legacy-file "defsystem" :pathname "defsystem.lisp") (:legacy-file "provide" :pathname "provide.lisp") (:legacy-file "cmudep" :pathname "cmudep.lisp") (:module manual ;; TODO: teach asdf how to process texinfo files :components ((:static-file "clx.texinfo"))) (:module debug :default-component-class legacy-file :components ((:file "debug" :pathname "debug.lisp") (:file "describe" :pathname "describe.lisp") (:file "event-test" :pathname "event-test.lisp") (:file "keytrans" :pathname "keytrans.lisp") (:file "trace" :pathname "trace.lisp") (:file "util" :pathname "util.lisp"))))) (defmethod perform ((o load-op) (f example-source-file)) ;; do nothing. We want to compile them when CLX is compiled, but ;; not load them when CLX is loaded. t) #+sbcl (defmethod perform :around ((o compile-op) (f xrender-source-file)) ;; RENDER would appear to be an inherently slow protocol; further, ;; it's not set in stone, and consequently we care less about speed ;; than we do about correctness. (handler-bind ((sb-ext:compiler-note #'muffle-warning)) (call-next-method))) #+sbcl (defmethod perform :around ((o compile-op) (f clx-source-file)) ;; a variety of accessors, such as AREF-CARD32, are not ;; declared INLINE. Without this (non-ANSI) ;; static-type-inference behaviour, SBCL emits an extra 100 ;; optimization notes (roughly one fifth of all of the ;; notes emitted). Since the internals are unlikely to ;; change much, and certainly the internals should stay in ;; sync, enabling this extension is a win. (Note that the ;; use of this does not imply that applications using CLX ;; calls that expand into calls to these accessors will be ;; optimized in the same way). (let ((sb-ext:*derive-function-types* t) (sadx (find-symbol "STACK-ALLOCATE-DYNAMIC-EXTENT" :sb-c)) (sadx-var (find-symbol "*STACK-ALLOCATE-DYNAMIC-EXTENT*" :sb-ext))) ;; deeply unportable stuff, this. I will be shot. We ;; want to enable the dynamic-extent declarations in CLX. (when (and sadx (sb-c::policy-quality-name-p sadx)) ;; no way of setting it back short of yet more yukky stuff (proclaim `(optimize (,sadx 3)))) (if sadx-var (progv (list sadx-var) (list t) (call-next-method)) (call-next-method)))) #+sbcl (defmethod perform :around (o (f clx-source-file)) ;; SBCL signals an error if DEFCONSTANT is asked to redefine a ;; constant unEQLly. For CLX's purposes, however, we are defining ;; structured constants (lists and arrays) not for EQLity, but for ;; the purposes of constant-folding operations such as (MEMBER FOO ;; +BAR+), so it is safe to abort the redefinition provided the ;; structured data is sufficiently equal. (handler-bind ((sb-ext:defconstant-uneql (lambda (c) ;; KLUDGE: this really means "don't warn me about ;; efficiency of generic array access, please" (declare (optimize (sb-ext:inhibit-warnings 3))) (let ((old (sb-ext:defconstant-uneql-old-value c)) (new (sb-ext:defconstant-uneql-new-value c))) (typecase old (list (when (equal old new) (abort c))) (string (when (and (typep new 'string) (string= old new)) (abort c))) (simple-vector (when (and (typep new 'simple-vector) (= (length old) (length new)) (every #'eql old new)) (abort c))) (array (when (and (typep new 'array) (equal (array-dimensions old) (array-dimensions new)) (equal (array-element-type old) (array-element-type new)) (dotimes (i (array-total-size old) t) (unless (eql (row-major-aref old i) (row-major-aref new i)) (return nil)))) (abort c)))))))) (call-next-method))) cl-clx-sbcl-0.7.4.20160323.orig/provide.lisp0000644000175000017500000000304212715665272016162 0ustar pdmpdm;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: Yes; Package: USER; -*- ;;;; Module definition for CLX ;;; This file is a Common Lisp Module description, but you will have to edit ;;; it to meet the needs of your site. ;;; Ideally, this file (or a file that loads this file) should be ;;; located in the system directory that REQUIRE searches. Thus a user ;;; would say ;;; (require :clx) ;;; to load CLX. If there is no such registry, then the user must ;;; put in a site specific ;;; (require :clx ) ;;; #-clx-ansi-common-lisp (in-package :user) #+clx-ansi-common-lisp (in-package :common-lisp-user) #-clx-ansi-common-lisp (provide :clx) (defvar *clx-source-pathname* (pathname "/src/local/clx/*.l")) (defvar *clx-binary-pathname* (let ((lisp (or #+lucid "lucid" #+akcl "akcl" #+kcl "kcl" #+ibcl "ibcl" (error "Can't provide CLX for this lisp."))) (architecture (or #+(or sun3 (and sun (or mc68000 mc68020))) "sun3" #+(or sun4 sparc) "sparc" #+(and hp (or mc68000 mc68020)) "hp9000s300" #+vax "vax" #+prime "prime" #+sunrise "sunrise" #+ibm-rt-pc "ibm-rt-pc" #+mips "mips" #+prism "prism" (error "Can't provide CLX for this architecture.")))) (pathname (format nil "/src/local/clx/~A.~A/" lisp architecture)))) (defvar *compile-clx* nil) (load (merge-pathnames "defsystem" *clx-source-pathname*)) (if *compile-clx* (compile-clx *clx-source-pathname* *clx-binary-pathname*) (load-clx *clx-binary-pathname*)) cl-clx-sbcl-0.7.4.20160323.orig/excldefsys.lisp0000644000175000017500000001352212715665272016667 0ustar pdmpdm;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*- ;;; ;;; Copyright (c) 1988, 1989 Franz Inc, Berkeley, Ca. ;;; ;;; Permission is granted to any individual or institution to use, copy, ;;; modify, and distribute this software, provided that this complete ;;; copyright and permission notice is maintained, intact, in all copies and ;;; supporting documentation. ;;; ;;; Franz Incorporated provides this software "as is" without express or ;;; implied warranty. ;;; (in-package :xlib :use '(:foreign-functions :lisp :excl)) #+allegro (require :defsystem "defsys") (eval-when (load) (require :clxexcldep "excldep")) ;; ;; The following is a suggestion. If you comment out this form be ;; prepared for possible deadlock, since no interrupts will be recognized ;; while reading from the X socket if the scheduler is not running. ;; (setq compiler::generate-interrupt-checks-switch (compile nil '(lambda (safety size speed) (declare (ignore size)) (or (< speed 3) (> safety 0))))) #+allegro (excl:defsystem :clx () |depdefs| (|clx| :load-before-compile (|depdefs|) :recompile-on (|depdefs|)) (|dependent| :load-before-compile (|depdefs| |clx|) :recompile-on (|clx|)) (|exclcmac| :load-before-compile (|depdefs| |clx| |dependent|) :recompile-on (|dependent|)) (|macros| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|) :recompile-on (|exclcmac|)) (|bufmac| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros|) :recompile-on (|macros|)) (|buffer| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac|) :recompile-on (|bufmac|)) (|display| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer|) :recompile-on (|buffer|)) (|gcontext| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) (|input| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| ) :recompile-on (|display|)) (|requests| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| |input|) :recompile-on (|display|)) (|fonts| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| ) :recompile-on (|display|)) (|graphics| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| |fonts|) :recompile-on (|fonts|)) (|text| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| |gcontext| |fonts|) :recompile-on (|gcontext| |fonts|) :load-after (|translate|)) ;; The above line gets around a compiler macro expansion bug. (|attributes| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) (|translate| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| |text|) :recompile-on (|display|)) (|keysyms| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| |translate|) :recompile-on (|translate|)) (|manager| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) (|image| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| ) :recompile-on (|display|)) ;; Don't know if l-b-c list is correct. XX (|resource| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) ) #+allegro (excl:defsystem :clx-debug (:default-pathname "debug/" :needed-systems (:clx) :load-before-compile (:clx)) |describe| |keytrans| |trace| |util|) (defun compile-clx (&optional pathname-defaults) (let ((*default-pathname-defaults* (or pathname-defaults *default-pathname-defaults*))) (declare (special *default-pathname-defaults*)) (compile-file "depdefs") (load "depdefs") (compile-file "clx") (load "clx") (compile-file "dependent") (load "dependent") (compile-file "macros") (load "macros") (compile-file "bufmac") (load "bufmac") (compile-file "buffer") (load "buffer") (compile-file "display") (load "display") (compile-file "gcontext") (load "gcontext") (compile-file "input") (load "input") (compile-file "requests") (load "requests") (compile-file "fonts") (load "fonts") (compile-file "graphics") (load "graphics") (compile-file "text") (load "text") (compile-file "attributes") (load "attributes") (load "translate") (compile-file "translate") ; work-around bug in 2.0 and 2.2 (load "translate") (compile-file "keysyms") (load "keysyms") (compile-file "manager") (load "manager") (compile-file "image") (load "image") (compile-file "resource") (load "resource") )) (defun load-clx (&optional pathname-defaults) (let ((*default-pathname-defaults* (or pathname-defaults *default-pathname-defaults*))) (declare (special *default-pathname-defaults*)) (load "depdefs") (load "clx") (load "dependent") (load "macros") (load "bufmac") (load "buffer") (load "display") (load "gcontext") (load "input") (load "requests") (load "fonts") (load "graphics") (load "text") (load "attributes") (load "translate") (load "keysyms") (load "manager") (load "image") (load "resource") )) cl-clx-sbcl-0.7.4.20160323.orig/translate.lisp0000644000175000017500000005727612715665273016532 0ustar pdmpdm;;; -*- 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 the keysym set named SET. SET is a keyword ;; (i.e., a symbol in the package named KEYWORD). When the function ;; KEYSYM-SET is called with a keysym, the SET of the keysym set to ;; which the keysym belongs is returned. ;; ;; If the range of keysyms defined by first-keysym and last-keysym ;; overlaps the range of an existing keysym set, then an error is ;; signaled. (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 :load-toplevel :execute) (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. ;; ;; FIXME: The above means that this shouldn't really be a macro at ;; all, but a compiler macro. Probably, anyway. (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 the new definition is added. ;; ;; 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 :load-toplevel :execute) (defconstant character-set-switch-keysym (keysym 255 126)) (defconstant left-shift-keysym (keysym 255 225)) (defconstant right-shift-keysym (keysym 255 226)) (defconstant left-control-keysym (keysym 255 227)) (defconstant right-control-keysym (keysym 255 228)) (defconstant caps-lock-keysym (keysym 255 229)) (defconstant shift-lock-keysym (keysym 255 230)) (defconstant left-meta-keysym (keysym 255 231)) (defconstant right-meta-keysym (keysym 255 232)) (defconstant left-alt-keysym (keysym 255 233)) (defconstant right-alt-keysym (keysym 255 234)) (defconstant left-super-keysym (keysym 255 235)) (defconstant right-super-keysym (keysym 255 236)) (defconstant left-hyper-keysym (keysym 255 237)) (defconstant right-hyper-keysym (keysym 255 238))) ;;----------------------------------------------------------------------------- ;; 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))))) cl-clx-sbcl-0.7.4.20160323.orig/xvidmode.lisp0000644000175000017500000007063312715665273016344 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- ;;; --------------------------------------------------------------------------- ;;; Title: XFree86 video mode extension ;;; Created: 2003 03 28 15:28 ;;; Author: Iban Hatchondo ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2003 by Iban Hatchondo ;;; ;;; 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. ;;; ;;; THIS IS NOT AN X CONSORTIUM STANDARD OR AN X PROJECT TEAM SPECIFICATION ;;; DESCRIPTION ;;; ;;; These functions provide an interface to the server extension ;;; XFree86-VidModeExtension which allows the video modes to be ;;; queried, adjusted dynamically and the mode switching to be ;;; controlled. ;;; [ personal notes ] ;;; ;;; The documentation on this extension is very poor, probably, ;;; because it is not an X standard nor an X project team spec. ;;; Because of that, it need to be tested on some XFree 3.3.6, ;;; and XFree 4.3.x to ensure that all request are correctly ;;; constructed as well as to indentify any obsolete/wrong ;;; functions I made. (in-package :xlib) (export '(mode-info mode-info-dotclock mode-info-hdisplay mode-info-hsyncstart mode-info-hsyncend mode-info-htotal mode-info-hskew mode-info-vdisplay mode-info-vsyncstart mode-info-vsyncend mode-info-vtotal mode-info-flags mode-info-privsize mode-info-private make-mode-info xfree86-vidmode-query-version xfree86-vidmode-set-client-version xfree86-vidmode-get-permissions xfree86-vidmode-mod-mode-line xfree86-vidmode-get-mode-line xfree86-vidmode-get-all-mode-lines xfree86-vidmode-add-mode-line xfree86-vidmode-delete-mode-line xfree86-vidmode-validate-mode-line xfree86-vidmode-get-gamma xfree86-vidmode-set-gamma xfree86-vidmode-get-gamma-ramp xfree86-vidmode-set-gamma-ramp xfree86-vidmode-get-gamma-ramp-size xfree86-vidmode-lock-mode-switch xfree86-vidmode-switch-to-mode xfree86-vidmode-switch-mode xfree86-vidmode-select-next-mode xfree86-vidmode-select-prev-mode xfree86-vidmode-get-monitor xfree86-vidmode-get-viewport xfree86-vidmode-set-viewport xfree86-vidmode-get-dotclocks) :xlib) ;; current version numbers ;; ;; major 0 == uses parameter-to-wire functions in XFree86 libXxf86vm. ;; major 1 == uses parameter-to-wire functions hard-coded in xvidtune client. ;; major 2 == uses new protocol version in XFree86 4.0. (defconstant +xf86vidmode-major-version+ 2) (defconstant +xf86vidmode-minor-version+ 2) ;; requests number. (defconstant +query-version+ 0) (defconstant +get-mode-line+ 1) (defconstant +mod-mode-line+ 2) (defconstant +switch-mode+ 3) (defconstant +get-monitor+ 4) (defconstant +lock-mode-switch+ 5) (defconstant +get-all-mode-lines+ 6) (defconstant +add-mode-line+ 7) (defconstant +delete-mode-line+ 8) (defconstant +validate-mode-line+ 9) (defconstant +switch-to-mode+ 10) (defconstant +get-viewport+ 11) (defconstant +set-viewport+ 12) ;; new for version 2.x of this extension. (defconstant +get-dot-clocks+ 13) (defconstant +set-client-version+ 14) (defconstant +set-gamma+ 15) (defconstant +get-gamma+ 16) (defconstant +get-gamma-ramp+ 17) (defconstant +set-gamma-ramp+ 18) (defconstant +get-gamma-ramp-size+ 19) (defconstant +get-permisions+ 20) (define-extension "XFree86-VidModeExtension" :events (:xfree86-vidmode-notify) :errors (xf86-vidmode-bad-clock xf86-vidmode-bad-htimings xf86-vidmode-bad-vtimings xf86-vidmode-mode-unsuitable xf86-vidmode-extension-disabled xf86-vidmode-client-not-local xf86-vidmode-zoom-locked)) (define-condition xf86-vidmode-bad-clock (request-error) ()) (define-condition xf86-vidmode-bad-htimings (request-error) ()) (define-condition xf86-vidmode-bad-vtimings (request-error) ()) (define-condition xf86-vidmode-mode-unsuitable (request-error) ()) (define-condition xf86-vidmode-extension-disabled (request-error) ()) (define-condition xf86-vidmode-client-not-local (request-error) ()) (define-condition xf86-vidmode-zoom-locked (request-error) ()) (define-error xf86-vidmode-bad-clock decode-core-error) (define-error xf86-vidmode-bad-htimings decode-core-error) (define-error xf86-vidmode-bad-vtimings decode-core-error) (define-error xf86-vidmode-mode-unsuitable decode-core-error) (define-error xf86-vidmode-extension-disabled decode-core-error) (define-error xf86-vidmode-client-not-local decode-core-error) (define-error xf86-vidmode-zoom-locked decode-core-error) (declare-event :XFree86-VidMode-notify (card16 sequence) (window (window event-window)) ; the root window of event screen (int16 state) ; what happend (int16 kind) ; what happend (boolean forced-p) ; extents of a new region ((or null card32) time)) ; event timestamp (defstruct mode-info (dotclock 0 :type card32) (hdisplay 0 :type card16) (hsyncstart 0 :type card16) (hsyncend 0 :type card16) (htotal 0 :type card16) (hskew 0 :type card32) (vdisplay 0 :type card16) (vsyncstart 0 :type card16) (vsyncend 0 :type card16) (vtotal 0 :type card16) (flags 0 :type card32) (privsize 0 :type card32) (private nil :type sequence)) (defmacro vidmode-opcode (display) `(extension-opcode ,display "XFree86-VidModeExtension")) (declaim (inline screen-position)) (defun screen-position (screen display) (declare (type display display) (type screen screen)) (declare (clx-values position)) (let ((position (position screen (xlib:display-roots display)))) (if (not (numberp position)) (error "screen ~A not found in display ~A" screen display) position))) (declaim (inline __card32->card16__)) (defun __card32->card16__ (i) (declare (type card32 i)) #+clx-little-endian (progn (values (ldb (byte 16 0) i) (ldb (byte 32 16) i))) #-clx-little-endian (progn (values (ldb (byte 32 16) i) (ldb (byte 16 0) i)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; ;;;; public XFree86-VidMode Extension routines ;;;; ;;;; ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun xfree86-vidmode-query-version (display) "Determine the version of the extension built into the server. return two values major-version and minor-version in that order." (declare (type display display)) (with-buffer-request-and-reply (display (vidmode-opcode display) nil :sizes 16) ((data +query-version+)) (let ((major (card16-get 8)) (minor (card16-get 10))) (declare (type card16 major minor)) (when (>= major 2) (XFree86-VidMode-set-client-version display)) (values major minor)))) (defun xfree86-vidmode-set-client-version (display) (declare (type display display)) (with-buffer-request (display (vidmode-opcode display)) (data +set-client-version+) (card16 +xf86vidmode-major-version+) (card16 +xf86vidmode-minor-version+))) (defun xfree86-vidmode-get-permissions (dpy screen) (declare (type display dpy) (type screen screen)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-permisions+) (card16 (screen-position screen dpy)) (card16 0)) (values (card32-get 8)))) (defun xfree86-vidmode-mod-mode-line (display screen mode-line) "Change the settings of the current video mode provided the requested settings are valid (e.g. they don't exceed the capabilities of the monitor)." (declare (type display display) (type screen screen)) (let* ((major (xfree86-vidmode-query-version display)) (v (mode-info->v-card16 mode-line major))) (declare (type card16 major) (type simple-vector v)) (with-buffer-request (display (vidmode-opcode display)) (data +mod-mode-line+) (card32 (screen-position screen display)) ((sequence :format card16 :start 2) v)))) (defun xfree86-vidmode-get-mode-line (display screen) "Query the settings for the currently selected video mode. return a mode-info structure fields with the server answer. If there are any server private values (currently only applicable to the S3 server) the function will store it into the returned structure." (declare (clx-values mode-info) (type display display) (type screen screen)) (let ((major (xfree86-vidmode-query-version display)) (offset 8)) (declare (type fixnum offset) (type card16 major)) (with-buffer-request-and-reply (display (vidmode-opcode display) nil :sizes (8 16 32)) ((data +get-mode-line+) (card16 (screen-position screen display)) (card16 0)) (let ((mode-info (make-mode-info :dotclock (card32-get offset) :hdisplay (card16-get (incf offset 4)) :hsyncstart (card16-get (incf offset 2)) :hsyncend (card16-get (incf offset 2)) :htotal (card16-get (incf offset 2)) :hskew (if (< major 2) 0 (card16-get (incf offset 2))) :vdisplay (card16-get (incf offset 2)) :vsyncstart (card16-get (incf offset 2)) :vsyncend (card16-get (incf offset 2)) :vtotal (card16-get (incf offset 2)) :flags (card32-get (incf offset (if (< major 2) 2 4))))) (size (card32-get (incf offset (if (< major 2) 4 16))))) (declare (type card32 size)) (incf offset 4) (setf (mode-info-privsize mode-info) size (mode-info-private mode-info) (sequence-get :format card32 :index offset :length size :result-type 'list)) mode-info)))) (defun xfree86-vidmode-get-all-mode-lines (dpy screen) "Returns a list containing all video modes (as mode-info structure). The first element of the list corresponds to the current video mode." (declare (type display dpy) (type screen screen)) (multiple-value-bind (major minor) (xfree86-vidmode-query-version dpy) (declare (type card16 major minor)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-all-mode-lines+) (card16 (screen-position screen dpy))) (values ;; Note: There was a bug in the protocol implementation in versions ;; 0.x with x < 8 (the .private field wasn't being passed over the wire). ;; Check the server's version, and accept the old format if appropriate. (loop with bug-p = (and (= major 0) (< minor 8)) with offset of-type fixnum = 32 for i of-type card32 from 0 below (or (card32-get 8) 0) collect (let ((mode-info (make-mode-info :dotclock (card32-get offset) :hdisplay (card16-get (incf offset 4)) :hsyncstart (card16-get (incf offset 2)) :hsyncend (card16-get (incf offset 2)) :htotal (card16-get (incf offset 2)) :hskew (if (< major 2) 0 (card32-get (incf offset 2))) :vdisplay (card16-get (incf offset 4)) :vsyncstart (card16-get (incf offset 2)) :vsyncend (card16-get (incf offset 2)) :vtotal (card16-get (incf offset 2)) :flags (card32-get (incf offset (if (< major 2) 2 6))))) (size (card32-get (incf offset (if (< major 2) 4 16))))) (declare (type card32 size)) (incf offset 4) (when bug-p (setf size 0)) (setf (mode-info-privsize mode-info) size (mode-info-private mode-info) (sequence-get :format card32 :index offset :length size :result-type 'list)) (incf offset (* 4 size)) mode-info)))))) (defun xfree86-vidmode-add-mode-line (dpy scr new &key (after (make-mode-info))) (declare (type display dpy) (type screen scr)) (let* ((private (mode-info-private new)) (privsize (mode-info-privsize new)) (major (xfree86-vidmode-query-version dpy)) (i (if (< major 2) 14 22)) (v (make-array (- (+ (* 2 i) (* 2 privsize)) 2) :initial-element 0))) (declare (type card32 privsize) (type fixnum i) (type card16 major) (type simple-vector v)) (mode-info->v-card16 new major :encode-private nil :data v) (mode-info->v-card16 after major :encode-private nil :data v :index i) (setf i (- (* 2 i) 2)) ;; strore private info (sequence card32) according clx bytes order. (loop for card of-type card32 in private do (multiple-value-bind (w1 w2) (__card32->card16__ card) (setf (svref v (incf i)) w1 (svref v (incf i)) w2))) (with-buffer-request (dpy (vidmode-opcode dpy)) (data +add-mode-line+) (card32 (screen-position scr dpy)) ((sequence :format card16) v)))) (defun xfree86-vidmode-delete-mode-line (dpy scr mode-info) "Delete mode argument. The specified mode must match an existing mode. To be considered a match, all of the fields of the given mode-info structure must match, except the privsize and private fields. If the mode to be deleted is the current mode, a mode switch to the next mode will occur first. The last remaining mode can not be deleted." (declare (type display dpy) (type screen scr)) (let* ((major (xfree86-vidmode-query-version dpy)) (v (mode-info->v-card16 mode-info major))) (declare (type card16 major) (type simple-vector v)) (with-buffer-request (dpy (vidmode-opcode dpy)) (data +delete-mode-line+) (card32 (screen-position scr dpy)) ((sequence :format card16) v)))) (defconstant +mode-status+ '#(:MODE_BAD ; unspecified reason :MODE_ERROR ; error condition :MODE_OK ; Mode OK :MODE_HSYNC ; hsync out of range :MODE_VSYNC ; vsync out of range :MODE_H_ILLEGAL ; mode has illegal horizontal timings :MODE_V_ILLEGAL ; mode has illegal horizontal timings :MODE_BAD_WIDTH ; requires an unsupported linepitch :MODE_NO_MODE ; no mode with a maching name :MODE_NO_INTERLACE ; interlaced mode not supported :MODE_NO_DBLESCAN ; doublescan mode not supported :MODE_NO_VSCAN ; multiscan mode not supported :MODE_MEM ; insufficient video memory :MODE_VIRTUAL_X ; mode width too large for specified virtual size :MODE_VIRTUAL_Y ; mode height too large for specified virtual size :MODE_MEM_VIRT ; insufficient video memory given virtual size :MODE_NOCLOCK ; no fixed clock available :MODE_CLOCK_HIGH ; clock required is too high :MODE_CLOCK_LOW ; clock required is too low :MODE_CLOCK_RANGE ; clock/mode isn't in a ClockRange :MODE_BAD_HVALUE ; horizontal timing was out of range :MODE_BAD_VVALUE ; vertical timing was out of range :MODE_BAD_VSCAN ; VScan value out of range :MODE_HSYNC_NARROW ; horizontal sync too narrow :MODE_HSYNC_WIDE ; horizontal sync too wide :MODE_HBLANK_NARROW ; horizontal blanking too narrow :MODE_HBLANK_WIDE ; horizontal blanking too wide :MODE_VSYNC_NARROW ; vertical sync too narrow :MODE_VSYNC_WIDE ; vertical sync too wide :MODE_VBLANK_NARROW ; vertical blanking too narrow :MODE_VBLANK_WIDE ; vertical blanking too wide :MODE_PANEL ; exceeds panel dimensions :MODE_INTERLACE_WIDTH ; width too large for interlaced mode :MODE_ONE_WIDTH ; only one width is supported :MODE_ONE_HEIGHT ; only one height is supported :MODE_ONE_SIZE ; only one resolution is supported )) (defun decode-status-mode (status) (declare (type int32 status)) (svref +mode-status+ (+ status 2))) (defun xfree86-vidmode-validate-mode-line (dpy scr mode-info) "Checked the validity of a mode-info argument. If the specified mode can be used by the server (i.e. meets all the constraints placed upon a mode by the combination of the server, card, and monitor) the function returns :mode_ok otherwise it returns a keyword indicating the reason why the mode is invalid." (declare (type display dpy) (type screen scr)) (let* ((major (xfree86-vidmode-query-version dpy)) (v (mode-info->v-card16 mode-info major))) (declare (type card16 major) (type simple-vector v)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +validate-mode-line+) (card32 (screen-position scr dpy)) ((sequence :format card16) v)) (let ((status (integer-get 8))) (declare (type int32 status)) (when status (decode-status-mode status)))))) (defun xfree86-vidmode-get-gamma (display screen) (declare (type display display) (type screen screen)) (with-buffer-request-and-reply (display (vidmode-opcode display) nil :sizes (8 16 32)) ((data +get-gamma+) (card16 (screen-position screen display)) (card16 0) (card32 0) (card32 0) (card32 0) (card32 0) (card32 0) (card32 0)) (values (/ (the card32 (or (card32-get 8) 0)) 10000.0) (/ (the card32 (or (card32-get 12) 0)) 10000.0) (/ (the card32 (or (card32-get 16) 0)) 10000.0)))) (defun xfree86-vidmode-set-gamma (dpy scr &key (red 1.0) (green 1.0) (blue 1.0)) (declare (type display dpy) (type screen scr) (type (single-float 0.100f0 10.000f0) red green blue)) (with-buffer-request (dpy (vidmode-opcode dpy)) (data +set-gamma+) (card16 (screen-position scr dpy)) (card16 0) (card32 (truncate (* red 10000))) (card32 (truncate (* green 10000))) (card32 (truncate (* blue 10000))) (card32 0) (card32 0) (card32 0))) (defun xfree86-vidmode-get-gamma-ramp (dpy scr size) (declare (type display dpy) (type screen scr) (type card16 size)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-gamma-ramp+) (card16 (screen-position scr dpy)) (card16 size)) (let ((rep-size (* (the card16 (or (card16-get 8) 0)) 2))) (declare (type fixnum rep-size)) (unless (zerop rep-size) (let* ((off1 (+ 32 rep-size (* 2 (mod rep-size 2)))) (off2 (+ off1 rep-size (* 2 (mod rep-size 2))))) (declare (type fixnum off1 off2)) (values (sequence-get :format card16 :length (card16-get 8) :index 32 :result-type 'list) (sequence-get :format card16 :length (card16-get 8) :index off1 :result-type 'list) (sequence-get :format card16 :length (card16-get 8) :index off2 :result-type 'list))))))) (defun xfree86-vidmode-set-gamma-ramp (dpy scr size &key red green blue) (declare (type (or null simple-vector) red green blue) (type card16 size) (type display dpy) (type screen scr)) (with-buffer-request (dpy (vidmode-opcode dpy)) (data +set-gamma-ramp+) (card16 (screen-position scr dpy)) (card16 size) ((sequence :format card16) (if (zerop (mod size 2)) (concatenate 'vector red green blue) (concatenate 'vector red '#(0) green '#(0) blue '#(0)))))) (defun xfree86-vidmode-get-gamma-ramp-size (dpy screen) (declare (type display dpy) (type screen screen)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-gamma-ramp-size+) (card16 (screen-position screen dpy)) (card16 0)) (card16-get 8))) (defun xfree86-vidmode-lock-mode-switch (display screen lock-p) "Allow or disallow mode switching whether the request to switch modes comes from a call to the mode switching functions or from one of the mode switch key sequences (e.g. Ctrl-Alt-+ Ctrl-Alt--)." (declare (type display display) (type screen screen) (type boolean lock-p)) (with-buffer-request (display (vidmode-opcode display)) (data +lock-mode-switch+) (card16 (screen-position screen display)) (card16 (if lock-p 1 0)))) (defun xfree86-vidmode-switch-to-mode (display screen mode-info) "Switch directly to the specified mode. The specified mode must match an existing mode. Matching is as specified in the description of the xf86-vidmode-delete-mode-line function." (declare (type display display) (type screen screen)) (multiple-value-bind (major minor) (xfree86-vidmode-query-version display) (declare (type card16 major minor)) ;; Note: There was a bug in the protocol implementation in versions ;; 0.x with x < 8 (the .private field wasn't being passed over the wire). ;; Check the server's version, and accept the old format if appropriate. (let ((bug-p (and (= major 0) (< minor 8))) (privsize (mode-info-privsize mode-info))) (declare (type boolean bug-p)) (and bug-p (setf (mode-info-privsize mode-info) 0)) (let ((v (mode-info->v-card16 mode-info major :encode-private bug-p))) (declare (type simple-vector v)) (and bug-p (setf (mode-info-privsize mode-info) privsize)) (with-buffer-request (display (vidmode-opcode display)) (data +switch-to-mode+) (card32 (screen-position screen display)) ((sequence :format card16) v)))))) (defun xfree86-vidmode-switch-mode (display screen zoom) "Change the video mode to next (or previous) video mode, depending of zoom sign. If positive, switch to next mode, else switch to prev mode." (declare (type display display) (type screen screen) (type card16 zoom)) (with-buffer-request (display (vidmode-opcode display)) (data +switch-mode+) (card16 (screen-position screen display)) (card16 zoom))) (defun xfree86-vidmode-select-next-mode (display screen) "Change the video mode to next video mode" (declare (type display display) (type screen screen)) (with-buffer-request (display (vidmode-opcode display)) (data +switch-mode+) (card16 (screen-position screen display)) (card16 1))) (defun xfree86-vidmode-select-prev-mode (display screen) "Change the video mode to previous video mode" (declare (type display display) (type screen screen)) (with-buffer-request (display (vidmode-opcode display)) (data +switch-mode+) (card16 (screen-position screen display)) (card16 #xFFFF))) (defun xfree86-vidmode-get-monitor (dpy screen) "Information known to the server about the monitor is returned. Multiple value return: hsync (list of hi, low, ...) vsync (list of hi, low, ...) vendor name model name The hi and low values will be equal if a discreate value was given in the XF86Config file." (declare (type display dpy) (type screen screen)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-monitor+) (card16 (screen-position screen dpy)) (card16 0)) (let* ((vendor-name-length (card8-get 8)) (model-name-length (card8-get 9)) (pad (- 4 (mod vendor-name-length 4))) (nhsync (card8-get 10)) (nvsync (card8-get 11)) (vindex (+ 32 (* 4 (+ nhsync nvsync)))) (mindex (+ vindex vendor-name-length pad)) (hsync (sequence-get :length nhsync :index 32 :result-type 'list)) (vsync (sequence-get :length nvsync :index (+ 32 (* nhsync 4)) :result-type 'list))) (declare (type card8 nhsync nvsync vendor-name-length model-name-length) (type fixnum pad vindex mindex)) (values (loop for i of-type card32 in hsync collect (/ (ldb (byte 16 0) i) 100.) collect (/ (ldb (byte 32 16) i) 100.)) (loop for i of-type card32 in vsync collect (/ (ldb (byte 16 0) i) 100.) collect (/ (ldb (byte 32 16) i) 100.)) (string-get vendor-name-length vindex) (string-get model-name-length mindex))))) (defun xfree86-vidmode-get-viewport (dpy screen) "Query the location of the upper left corner of the viewport into the virtual screen. The upper left coordinates will be returned as a multiple value." (declare (type display dpy) (type screen screen)) (multiple-value-bind (major minor) (xfree86-vidmode-query-version dpy) (declare (type card16 major minor)) ;; Note: There was a bug in the protocol implementation in versions ;; 0.x with x < 8 (no reply was sent, so the client would hang) ;; Check the server's version, and don't wait for a reply with older ;; versions. (when (and (= major 0) (< minor 8)) (format cl:*error-output* "running an old version ~a ~a~%" major minor) (return-from xfree86-vidmode-get-viewport nil)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-viewport+) (card16 (screen-position screen dpy)) (card16 0)) (values (card32-get 8) (card32-get 12))))) (defun xfree86-vidmode-set-viewport (dpy screen &key (x 0) (y 0)) "Set upper left corner of the viewport into the virtual screen to the x and y keyword parameters value (zero will be theire default value)." (declare (type display dpy) (type screen screen) (type card32 x y)) (with-buffer-request (dpy (vidmode-opcode dpy)) (data +set-viewport+) (card16 (screen-position screen dpy)) (card16 0) (card32 x) (card32 y))) (defun xfree86-vidmode-get-dotclocks (dpy screen) "Returns as a multiple value return the server dotclock informations: flags maxclocks clock list" (declare (type display dpy) (type screen screen)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-dot-clocks+) (card16 (screen-position screen dpy)) (card16 0)) (values (card32-get 8) ; flags (card32-get 16) ; max clocks (sequence-get :length (card32-get 12) :format card32 :index 32 :result-type 'list)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; ;;;; private utility routines ;;;; ;;;; ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun mode-info->v-card16 (mode-info major &key (encode-private t) (index 0) data) (declare (type integer index) (type card16 major) (type boolean encode-private) (type (or null simple-vector) data)) (let ((dotclock (mode-info-dotclock mode-info)) (hdisplay (mode-info-hdisplay mode-info)) (hsyncstart (mode-info-hsyncstart mode-info)) (hsyncend (mode-info-hsyncend mode-info)) (htotal (mode-info-htotal mode-info)) (hskew (mode-info-hskew mode-info)) (vdisplay (mode-info-vdisplay mode-info)) (vsyncstart (mode-info-vsyncstart mode-info)) (vsyncend (mode-info-vsyncend mode-info)) (vtotal (mode-info-vtotal mode-info)) (flags (mode-info-flags mode-info)) (privsize (mode-info-privsize mode-info)) (private (mode-info-private mode-info))) (declare (type card16 hdisplay hsyncstart hsyncend htotal hskew) (type card16 vdisplay vsyncstart vsyncend vtotal) (type card32 dotclock flags privsize) (type (or null sequence) private)) (let* ((size (+ (if (< major 2) 14 22) (* privsize 2))) (v (or data (make-array size :initial-element 0)))) (declare (type fixnum size) (type simple-vector v)) ;; store dotclock (card32) according clx bytes order. (multiple-value-bind (w1 w2) (__card32->card16__ dotclock) (setf (svref v index) w1 (svref v (incf index)) w2)) (setf (svref v (incf index)) hdisplay (svref v (incf index)) hsyncstart (svref v (incf index)) hsyncend (svref v (incf index)) htotal) (unless (< major 2) (setf (svref v (incf index)) hskew)) (setf (svref v (incf index)) vdisplay (svref v (incf index)) vsyncstart (svref v (incf index)) vsyncend (svref v (incf index)) vtotal) (unless (< major 2) (incf index)) ;; strore flags (card32) according clx bytes order. (multiple-value-bind (w1 w2) (__card32->card16__ flags) (setf (svref v (incf index)) w1 (svref v (incf index)) w2)) ;; strore privsize (card32) according clx bytes order. (multiple-value-bind (w1 w2) (__card32->card16__ privsize) (setf (svref v (incf index)) w1 (svref v (incf index)) w2)) ;; reserverd byte32 1 2 3 (unless (< major 2) (incf index 6)) ;; strore private info (sequence card32) according clx bytes order. (when encode-private (loop for i of-type int32 in private do (multiple-value-bind (w1 w2) (__card32->card16__ i) (setf (svref v (incf index)) w1 (svref v (incf index)) w2)))) v))) cl-clx-sbcl-0.7.4.20160323.orig/manual/0000755000175000017500000000000012715665272015077 5ustar pdmpdmcl-clx-sbcl-0.7.4.20160323.orig/manual/clx.texinfo0000644000175000017500000210006312715665272017265 0ustar pdmpdm\input texinfo @c -*-texinfo-*- @c $Id: clx.texinfo,v 1.3 2004/11/18 12:01:48 dan Exp $ @c %**start of header @setfilename clx.info @settitle Common LISP X Interface @setchapternewpage odd @c %**end of header @dircategory lisp @direntry * CLX: (clx). Common LISP X Interface @end direntry @copying The Common LISP X Interface (CLX) Copyright @copyright{} 1988, 1989 Texas Instruments Incorporated @quotation Permission is granted to any individual or institution to use, copy, modify and distribute this document, provided that this complete copyright and permission notice is maintained, intact, in all copies and supporting documentation. Texas Instruments Incorporated makes no representations about the suitability of this document or the software described herein for any purpose. It is provided "as is" without express or implied warranty. @end quotation @end copying @titlepage @title The Common Lisp X Interface (CLX) @page @vskip 0pt plus 1filll @insertcopying @end titlepage @contents @ifnottex @node Top, Acknowledgments, (dir), (dir) @top The Common LISP X Interface (CLX) @insertcopying @end ifnottex @menu * Acknowledgments:: * Introduction to CLX:: * Displays:: * Screens:: * Windows and Pixmaps:: * Graphics Contexts:: * Graphic Operations:: * Images:: * Font and Characters:: * Colors:: * Cursors:: * Atoms:: * Events and Input:: * Resources:: * Control Functions:: * Extensions:: * Errors:: * Undocumented:: * Glossary:: * Function Index:: * Type Index:: @detailmenu --- The Detailed Node Listing --- Introduction to CLX * The X Window System:: * A Quick Tour of CLX:: * Naming and Argument Conventions:: * Programming Considerations:: * Data Types:: The X Window System * Windows:: * Input Events:: A Quick Tour of CLX * A Simple Menu:: * Displaying the Menu:: * Menu Input:: * The Main Program:: * Debugging With CLX:: Displays * Opening the Display:: * Display Attributes:: * Managing the Output Buffer:: * Closing the Display:: Screens * Screens and Visuals:: * Screen Attributes:: Windows and Pixmaps * Drawables:: * Creating Windows:: * Window Attributes:: * Stacking Order:: * Window Hierarchy:: * Mapping Windows:: * Destroying Windows:: * Pixmaps:: Graphics Contexts * Creating Graphics Contexts:: * Graphics Context Attributes:: * Copying Graphics Contexts:: * Destroying Graphics Contexts:: * Graphics Context Cache:: Graphic Operations * Area and Plane Operations:: * Drawing Points:: * Drawing Lines:: * Drawing Rectangles:: * Drawing Arcs:: * Drawing Text:: Images * Image Types:: * Image Functions:: * Image Files:: * Direct Image Transfer:: Image Types * Basic Images:: * XY-Format Images:: * Z-Format Images:: Font and Characters * Opening Fonts:: * Listing Fonts:: * Font Attributes:: * Chracter Attributes:: * Querying Text Size:: Colors * Colormaps and Colors:: * Color Functions:: * Colormap Functions:: Colormap Functions * Creating Colormaps:: * Installing Colormaps:: * Allocating Colors:: * Finding Colors:: * Changing Colors:: * Colormap Attributes:: Cursors * Creating Cursors:: * Cursor Functions:: * Cursor Attributes:: Atoms, Properties and Selections * Atoms (Atoms):: * Properties:: * Selections:: Events and Input * Selecting Events:: * Processing Events:: * Managing the Event Queue:: * Sending Events:: * Pointer Position:: * Managing Input Focus:: * Grabbing the Pointer:: * Grabbing a Button:: * Grabbing the Keyboard:: * Grabbing a Key:: * Event Types:: * Releasing Queued Events:: Event Types * Keyboard and Pointer Events:: * Input Focus Events:: * Keyboard and Pointer State Events:: * Exposure Events:: * Window State Events:: * Structure Control Events:: * Client Communications Events:: * Declaring Event Types:: Resources * Resource Binings:: * Basic Resource Database Functions:: * Accessing Resource Values:: * Resource Database Files:: Accessing Resource Values * Complete Names and Classes:: * Matching Resource Names:: * Resource Access Functions:: Control Functions * Grabbing the Server:: * Pointer Control:: * Keyboard Control:: * Keyboard Encodings:: * Client Termination:: * Managing Host Access:: * Screen Saver:: Keyboard Encodings * Keycodes and Keysyms:: * Keyboard Mapping:: * Using Keycodes and Keysyms:: Extensions * Extensions (Extensions):: * SHAPE - The X11 Nonrectangular Window Shape Extension:: * RENDER - A new rendering system for X11:: * DPMS - The X11 Display Power Management Signaling Extension:: * BIG-REQUESTS - Big Requests Extension:: RENDER - A new rendering system for X11 * Picture formats:: * The picture object:: * Glyphs and Glyphsets:: * Using glyphs:: * Errors (Extensions):: Errors * Introduction (Errors):: @end detailmenu @end menu @node Acknowledgments, Introduction to CLX, Top, Top @chapter Acknowledgments Primary Interface Author: Robert W. Scheifler @display MIT Laboratory for Computer Science 545 Technology Square, Room 418 Cambridge, MA 02139 @email{rws@@zermatt.lcs.mit.edu} @end display Primary Implementation Author: LaMott Oren @display Texas Instruments PO Box 655474, MS 238 Dallas, TX 75265 @email{oren@@csc.ti.com} @end display Design Contributors: @itemize @bullet @item Dan Cerys, BBN @item Scott Fahlman, CMU @item Kerry Kimbrough, Texas Instruments @item Chris Lindblad, MIT @item Rob MacLachlan, CMU @item Mike McMahon, Symbolics @item David Moon, Symbolics @item LaMott Oren, Texas Instruments @item Daniel Weinreb, Symbolics @item John Wroclawski, MIT @item Richard Zippel, Symbolics @end itemize Documentation Contributors: @itemize @bullet @item Keith Cessna, Texas Instruments @item Kerry Kimbrough, Texas Instruments @item Mike Myjak @item LaMott Oren, Texas Instruments @item Dan Stenger, Texas Instruments @end itemize The X Window System is a trademark of MIT. UNIX is a trademark of AT&T Bell Laboratories. ULTRIX, ULTRIX-32, ULTRIX-32m, ULTRIX-32w, and VAX/VMS are trademarks of Digital Equipment Corporation. @node Introduction to CLX, Displays, Acknowledgments, Top @chapter Introduction to CLX This manual assumes a basic understanding of window systems and the Common Lisp programming language. To provide an introduction to the Common Lisp X Interface (CLX) programming, this section discusses the following: @itemize @bullet @item Overview of the X Window System @item Naming and argument conventions @item Programming considerations @end itemize @menu * The X Window System:: * A Quick Tour of CLX:: * Naming and Argument Conventions:: * Programming Considerations:: * Data Types:: @end menu @node The X Window System, A Quick Tour of CLX, Introduction to CLX, Introduction to CLX @section The X Window System The X Window System was developed at the Massachusetts Institute of Technology (MIT) and first released in 1985. Since then, the X Window System has become an industry-standard product available on virtually every type of bit-mapped workstation. The current version of X, Version 11, has been implemented for several different computer architectures, for a wide variety of display hardware, and also for many different operating systems. X Version 11 represents the fulfillment of the original design goals proposed by MIT, as follows: @table @asis @item Portable Support virtually any bitmap display and any interactive input device (including keyboards, mice, tablets, joysticks, and touch screens). Make it easy to implement the window system on different operating systems. @item Device-Independent Applications Avoid rewriting, recompiling, or even relinking in order to use different display/input hardware. Make it easy for an application to work on both monochrome and color hardware. @item Network Transparent Let an application run on one computer while using another computer's display, even if the other computer has a different operating system or hardware architecture. @item Multitasking Support multiple applications being displayed simultaneously. @item No User Interface Policy Since no one agrees on what constitutes the best user interface, make it possible for a broad range of user interface styles (or policies) to be implemented, external to the window system and to the application programs. @item Cheap Windows Windows should be abundant, and ubiquitous. Provide overlapping windows and a simple mechanism for window hierarchy. @item High-Performance Graphics Provide powerful interfaces for synthesizing 2-D images (geometric primitives, high-quality text with multiple typefaces, and scanned images). @item Extensible Include a mechanism for adding new capabilities. Allow separate sites to develop independent extensions without becoming incompatible with remote applications. @end table Some of these goals lead directly to the basic X architecture -- the client-server model. The basic window system is implemented by the X @emph{server} program. An application program (the @emph{client}) sends window system @emph{requests} to the X server through a reliable two-way byte-stream. In general, the server and the client can be executing on separate host computers, in which case the byte-stream is implemented via some network protocol (TCP, DECnet(tm), Chaosnet, and so forth). The X server, which is connected to several client programs running concurrently, executes client requests in round-robin fashion. The server is responsible for drawing client graphics on the display screen and for making sure that graphics output to a window stays inside its boundary. The other primary job of the X server is to channel input from the keyboard, pointer, and other input devices back to the appropriate client programs. Input arrives at the client asynchronously in the form of input @emph{events} representing up/down transitions of keys or pointer buttons, changes in the pointer position, and so on. In some cases, a request generates a return value (or @emph{reply}) from the server, which is another kind of client input. Replies and input events are received via the same byte-stream connecting the client with the server. @menu * Windows:: * Input Events:: @end menu @node Windows, Input Events, The X Window System, The X Window System @subsection Windows The X Window System supports one or more screens containing overlapping windows and subwindows. A @emph{screen} is a physical monitor and hardware, which can be either color or black and white. There can be multiple screens per display workstation. A single server can provide display services for any number of screens. A set of screens for a single user with one keyboard and one mouse is called a @emph{display}. All windows in an X server are arranged in a strict hierarchy. At the top of the hierarchy are the @emph{root windows}, which cover each of the display screens. Each root window is either partially or completely covered by child windows. All windows, except for root windows, have parents. Any window can in turn have its own children. In this way, an application program can create a window tree of arbitrary depth on each screen. A child window can be larger than its parent. That is, part or all of the child window can extend beyond the boundaries of the parent. However, all output to a window is clipped by the boundaries of its parent window. If several children of a window have overlapping locations, one of the children is considered to be on top of/or raised over the others, @emph{obscuring} them. Window output to areas that are covered by other windows is suppressed. A window has a border that is zero or more pixels in width and can be any pattern (pixmap) or solid color. A window usually has a background pattern that is drawn by the X server. Each window has its own coordinate system. Child windows obscure their parents unless the child windows have no background. Graphics operations in the parent window are usually clipped by the children. X also provides objects called @emph{pixmaps} for off-screen storage of graphics. Single-plane pixmaps (that is, of depth 1) are sometimes referred to as @emph{bitmaps}. Both pixmaps and windows can be used interchangeably in most graphics functions. Pixmaps are also used in various graphics operations to define patterns, or @emph{tiles}. Windows and pixmaps together are referred to as @emph{drawables}. @node Input Events, , Windows, The X Window System @subsection Input Events The X input mechanism is conceptually simple yet quite powerful. Most events are attached to a particular window (that is, contain an identifier for the window receiving the event). A client program can receive multiple window input streams, all multiplexed over the single byte-stream connection to the server. Clients can tailor their input by expressing interest in only certain event types. The server uses special event types to send important messages to the client. For example, the client can elect to receive an @var{:enter-notify} (@pxref{:enter-notify}) event when the pointer cursor moves into a certain window. Another vital message from the server is an @var{:exposure} (@pxref{:exposure}) event. This is a signal to the client indicating that at least some portion of the window has suddenly become visible (perhaps the user moved another window which had been overlapping it). The client is then responsible for doing what is necessary to redisplay the window's image. Client programs must be prepared to regenerate the contents of windows in this way on demand. Input is also subject to policy decisions about which client window receives keyboard and pointer events. Since the pointer is free to roam between windows, just clicking on a window is often enough to send a pointer event to that window. Keyboard events, however, must go to a keyboard focus window which has to be designated in some other way. Usually, the arbiter of such input management policy is a program called the @emph{window manager}. The window manager gives the human user a way to make a window the keyboard focus, to manage the layout of windows on the screen, to represent windows with icons, and so forth. In fact, the window manager client determines most of the so-called look and feel of the X Window System. @node A Quick Tour of CLX, Naming and Argument Conventions, The X Window System, Introduction to CLX @section A Quick Tour of CLX The X Window System is defined by the X Window System Protocol Specification, a detailed description of the encoding and the meaning of requests and events sent between a client and a server. This standard protocol does not depend on any particular programming language. As a result, each programming language must define its own functional interface for using the X protocol. The standard X interface used by Common Lisp programmers is called CLX. CLX is a set of data types, functions, and macros which allow a Common Lisp client program to interact with an X server to send requests and to receive input events and replies. For the most part, CLX functions are closely tied to the underlying requests in the X protocol. Many CLX functions simply add requests to an output buffer. These requests later execute asynchronously on the X display server. However, some functions of CLX lie outside the scope of the protocol--for example, reading events and managing a clientside event queue. CLX is also responsible for important batching and caching tasks that minimize network communication. The following paragraphs show an example of a CLX client program. All CLX functions and macros are shown in upper case. Note that some of the terms used are unique to X, while other terms that are common to other window systems have different meanings in X. It may be helpful to refer to the glossary when you are uncertain of a term's meaning in the context of the X Window System. @menu * A Simple Menu:: * Displaying the Menu:: * Menu Input:: * The Main Program:: * Debugging With CLX:: @end menu @node A Simple Menu, Displaying the Menu, A Quick Tour of CLX, A Quick Tour of CLX @subsection A Simple Menu The example client program creates and displays a simple pop-up menu consisting of a column of strings--a title string followed by selectable menu item strings. The implementation uses one window to represent the entire menu, plus a set of subwindows, one for each menu item. Here is the definition of a structure which represents such a menu. @lisp (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 if unchanged since displayed @end lisp The @code{window} slot will contain the @var{window} (@pxref{window}) object that represents the menu. The @code{item-} @code{alist} represents the relationship between the menu items and their associated subwindows. Each entry in @code{item-alist} is a list whose first element is a (sub)window object and whose second element is the corresponding item string. A @var{window} (@pxref{window}) object is an instance of a CLX-defined data type which represents X windows. A @var{window} (@pxref{window}) object actually carries two pieces of information: an X window ID integer and a @var{display} (@pxref{display}) object. A @var{display} (@pxref{display}) is another CLX-defined data type that represents a connection to a specific X display server. The @code{gcontext} slot contains an instance of a CLX data type known as a @emph{graphics context}. A graphics context is a set of display attribute values, such as foreground color, fill style, line style, text font, and so forth. Each X graphics request (and hence each CLX graphics function call) must supply a graphics context to use in displaying the request. The menu's @code{gcontext} will thus hold all of the attribute values used during menu display. The first thing to do is make an instance of a @code{menu} object: @lisp (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)))) @end lisp @var{create-window} (@pxref{create-window}) is one of the most important CLX functions, since it creates and returns a @var{window} (@pxref{window}) object. Several of its options are shown here. The default window class is @var{:input-output}, but X provides for @var{:input-only} windows, too. Every window must have a parent window, except for a system-defined @emph{root window}, which represents an entire display screen. The @var{:event-mask} keyword value, a CLX @var{event-mask} (@pxref{event-mask}) data type, says that an input event will be received for the menu window when the window is exposed and also when the pointer cursor leaves the window. The window border is a pattern-filled or (as in this case) a solid-colored boundary which is maintained automatically by the X server; a client cannot draw in a window's border, since all graphics requests are relative to the origin (upper-left corner) of the window's interior and are clipped by the server to this inside region. Turning on the @var{:save-under} option is a hint to the X server that, when this window is made visible, it may be more efficient to save the pixels it obscures, rather than require several client programs to refresh their windows when the pop-up menu disappears. This is a way to work around X's client-managed refresh policy when only a small amount of screen space is needed temporarily. Why is @var{:override-redirect} turned on for the menu window? This is actually a little unusual, because it prevents any window manager client from @emph{redirecting} the position of the menu when it is popped up. Remember that the window manager represents the user's policy for controlling the positions of his windows, so this kind of redirection is ordinarily correct. However, in this case, as a favor to the user, the menu avoids redirection in order to pop up the menu at a very specific location; that is, under the pointer cursor. What about the item subwindows? The @code{menu-set-item-list} function in the following example creates them whenever the menu's item list is changed. The upper-left x and y coordinates and the width and height are not important yet, because they are computed just before the menu is displayed. This function also calls @var{create-window} (@pxref{create-window}), demonstrating the equal treatment of parent and children windows in the X window hierarchy. @lisp (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))))) @end lisp @node Displaying the Menu, Menu Input, A Simple Menu, A Quick Tour of CLX @subsection Displaying the Menu The @code{menu-recompute-geometry} function (shown in the following example) handles the job of calculating the size of the menu, based on its current item list and its current text font. CLX provides a way to inquire the geometrical properties of a font object (for example, its ascent and descent from the baseline) and also a @var{text-extents} (@pxref{text-extents}) function. @var{text-extents} (@pxref{text-extents}) returns the geometry of a given string as displayed in a given font. Notice the use of the @var{with-state} (@pxref{with-state}) macro when setting a window's geometry attributes. CLX strives to preserve the familiar @code{setf} style of accessing individual window attributes, even though an attribute access actually involves sending a request to a (possibly remote) server and/or waiting for a reply. @var{with-state} (@pxref{with-state}) tells CLX to batch together all read and write accesses to a given window, using a local cache to minimize the number of server requests. This CLX feature can result in a dramatic improvement in client performance without burdening the programmer interface. @code{menu-recompute-geometry} causes all the item subwindows to become @emph{mapped}. Mapping a window means attempting to make it visible on the screen. However, a subwindow will not actually be @emph{visible} until it and all of its ancestors are mapped. Even then, another window might be covering up the subwindow. @lisp (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) *menu-item-margin*)) (item-width 0) (items (menu-item-alist menu)) menu-width) ;; Find max item string width (setf item-width (+ *menu-item-margin* (dolist (next-item items item-width) (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*))) (let ((window (menu-window menu))) ;; Update width and height of menu window (WITH-STATE (window) (setf (DRAWABLE-WIDTH window) menu-width (DRAWABLE-HEIGHT window) (* (1+ (length items)) item-height))) ;; Update width, height, position of item windows (let ((item-left (round (- menu-width item-width) 2)) (next-item-top (- item-height (round *menu-item-margin* 2)))) (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 item-height)))) ;; 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)))) @end lisp Of course, the sample client must know how to draw/redraw the menu and its items, so the function @code{menu-refresh} is defined next to handle that task (shown in the following example). Note that the location of window output is given relative to the window origin. Windows and subwindows have different coordinate systems. The location of the origin (upper-left corner) of a subwindow's coordinate system is given with respect to its parent window's coordinate system. Negative coordinates are valid, although only output to the +x/+y quadrant of a window's coordinate system will ever be visible. @lisp (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) (let ((box-margin (round *menu-item-margin* 2))) (dolist (item (menu-item-alist menu)) (DRAW-IMAGE-GLYPHS (first item) gcontext box-margin ;start x (+ baseline-y box-margin) ;start y (second item)))))) @end lisp @var{with-gcontext} (@pxref{with-gcontext}) is a CLX macro that allows you temporarily to modify a graphics context within the dynamic scope of the macro body. @var{draw-image-glyphs} (@pxref{draw-image-glyphs}) is a CLX text drawing function which produces a terminal-like rendering: foreground character on a background block. (More sophisticated text rendering functions are also available.) The strange use of @emph{glyphs} instead of @emph{string} here actually highlights an important fact: X and Common Lisp have totally different concepts of a character. A Common Lisp character is an object whose implementation can comprehend a vast universe of text complexities (typefaces, type styles, international character sets, symbols, and so forth). However, to X, a string is just a sequence of integer indexes into the array of bitmaps represented by a CLX font object. In general, @var{draw-image-glyphs} (@pxref{draw-image-glyphs}), @var{text-extents} (@pxref{text-extents}), and other CLX text functions accept a @var{:translate} keyword argument. Its value is a function which translates the characters of a string argument into the appropriate font-and-index pairs needed by CLX. This example relies upon the default translation function, which simply uses @var{char-code} to compute an index into the current font. @node Menu Input, The Main Program, Displaying the Menu, A Quick Tour of CLX @subsection Menu Input Now that a menu can be displayed, the sample client program must define how the menu will process user input. The @code{menu-choose} function (shown in the following example) has the classic structure of an X client program. First, do some initialization (for example, present the menu at a given location). Then, enter an input event loop. Read an input event, process it, and repeat the loop until a termination event is received. The @var{event-case} (@pxref{event-case}) macro continues reading an event from the menu window's display object until one of its clauses returns non-@var{nil}. These clauses specify the action to be taken for each event type and also bind values from the event report to local variables, such as the @var{event-window} receiving the event. Notice that the @var{:force-output-p} option is enabled, causing @var{event-case} (@pxref{event-case}) to begin by sending any client requests which CLX has not yet output to the server. To improve performance, CLX quietly queues up requests and periodically sends them off in a batch. However, in an interactive feedback loop such as this, it is important to keep the display crisply up-to-date. @lisp (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 (menu-highlight-item menu (find window items :key #'first)) 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 (menu-unhighlight-item menu (find window items :key #'first))) 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))) @end lisp The event loop in @code{menu-choose} demonstrates an idiom used in all X programs: the contents of a window are displayed (in this case, by calling @code{menu-refresh}) only when an @var{:exposure} (@pxref{:exposure}) event is received, signaling that the server has actually made the window @emph{viewable}. The handling of @var{:exposure} (@pxref{:exposure}) in @code{menu-choose} also implements a little trick for improving efficiency. In general, when a window is exposed after being previously obscured (perhaps only partially), the server is free to send several @var{:exposure} (@pxref{:exposure}) events, one for each rectangular tile of the exposed region. For small windows like this menu, it is not worth the trouble to redraw the image one tile at a time. So the code above just ignores all but the last tile exposure and redraws everything in one call to @code{menu-refresh}. @node The Main Program, Debugging With CLX, Menu Input, A Quick Tour of CLX @subsection The Main Program After all the preceding build-up and the other functions referenced (but not shown here) have been implemented, the code for the main client program is very small. @lisp (defun just-say-lisp (host &optional (font-name "fg-16")) (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)) ;; Create a menu as a child of the root window. (a-menu (create-menu (SCREEN-ROOT screen) 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 (loop ;; Determine the current root window position of the pointer (multiple-value-bind (x y) (QUERY-POINTER (SCREEN-ROOT screen)) (let ((choice (menu-choose a-menu x y))) (when (string-equal "Lisp" choice) (return))))) (CLOSE-DISPLAY display)))) @end lisp Note that the main program event loop lies in the body of an @var{unwind-protect} form. This is a good programming technique because, without this protection, an unexpected error could cause the program to terminate without freeing the @emph{server resources} it has created. Server resources are CLX objects which refer to objects actually stored on the X server. Examples of these are @var{window} (@pxref{window}), @var{font} (@pxref{font}), @var{pixmap} (@pxref{pixmap}), @var{cursor} (@pxref{cursor}), @var{colormap} (@pxref{colormap}), and @var{gcontext} (@pxref{gcontext}) objects. These server resources are created and destroyed by user requests. Server resources created by a client are also destroyed when its display connection is closed. If client resources are repeatedly created without being destroyed, then the server will eventually run out of memory and fail. Most server resources are potentially sharable between applications. In fact, windows are manipulated explicitly by window manager programs. Fonts and cursors are typically shared automatically since the X server loads and unloads font storage as needed. @var{gcontext} (@pxref{gcontext}) objects are not ordinarily shared between client applications. @node Debugging With CLX, , The Main Program, A Quick Tour of CLX @subsection Debugging With CLX Typically, most CLX programs do not need to control the buffering of output requests directly. However, CLX programmers need to be aware of the asynchronous nature of client-server communication. It may be convenient to control the CLX output buffer more directly, especially during debugging. A client that wants a request to execute immediately instead of asynchronously can follow it with a call to @var{display-force-output} (@pxref{display-force-output}). This function @emph{blocks} (does not return) until all previously buffered output requests have been sent. Otherwise, the output buffer is always flushed by a call to any function which returns a value from the server or which waits for input (for example, @var{get-property} (@pxref{get-property}). Certain output requests can cause input events to be sent. For example, @var{map-window} (@pxref{map-window}) can cause @var{:exposure} (@pxref{:exposure}) events to be sent. Synchronizing output with the resulting input can be done with the @var{display-finish-output} (@pxref{display-finish-output}) function. This function blocks until all previously buffered output has been sent and all resulting input events have been received. Functions that return information from the server block until an explicit reply is received or an error occurs. If a nonblocking call results in an error, the error is generally not reported until later. All errors (synchronous and asynchronous) are processed by calling an error handler defined for the display. If the 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 since it is assumed that the handler either takes care of the error completely, or else signals. @node Naming and Argument Conventions, Programming Considerations, A Quick Tour of CLX, Introduction to CLX @section Naming and Argument Conventions Throughout CLX, a number of conventions for naming and syntax of the CLX functions have been followed. These conventions are intended to make the syntax of the functions more predictable. The major naming conventions are as follows: @itemize @bullet @item To better differentiate the CLX symbols from other symbols, they have all been placed in the package XLIB. External symbols have been explicitly exported. @item The @emph{display} argument, where used, is always first in the argument list. @item All server resource objects, where used, occur at the beginning of the argument list, immediately after the display variable. @item When a graphics context (@emph{gcontext}) is present together with another type of server resource (most commonly, a @emph{drawable}), the graphics context occurs in the argument list after the other server resource. Drawables out rank all other server resources. @item Source arguments always precede the destination arguments in the argument list. @item The @emph{x} argument always precedes the @emph{y} argument in the argument list. @item The @emph{width} argument always precedes the @emph{height} argument in the argument list. @item Where the @emph{x}, @emph{y}, @emph{width} and @emph{height} arguments are used together, the @emph{x} and @emph{y} arguments always precede the @emph{width} and @emph{height} arguments. @item Where a @emph{mask} is accompanied with a @emph{structure}, the mask always precedes the structure in the argument list. @end itemize @node Programming Considerations, Data Types, Naming and Argument Conventions, Introduction to CLX @section Programming Considerations The major programming considerations are as follows: @itemize @bullet @item Keyboards are the greatest variable between different manufacturer's workstations. If you want your program to be portable, you should be particularly conservative here. @item Many display systems have limited amounts of off-screen memory. If you can, you should minimize use of pixmaps and backing store. @item The user should have control of his screen real-estate. Therefore, you should write your applications to react to window management, rather than presume control of the entire screen. What you do inside of your top level window, however, is up to your application. @item Coordinates and sizes in X are actually 16-bit quantities. They usually are declared as an @var{int16} (@pxref{int16}) in the functions. Values larger than 16 bits can be truncated silently. Sizes (width and height) are unsigned quantities. @item The types @var{color} (@pxref{color}), @var{colormap} (@pxref{colormap}), @var{cursor} (@pxref{cursor}), @var{display} (@pxref{display}), @var{font} (@pxref{font}), @var{gcontext} (@pxref{gcontext}), @var{pixmap} (@pxref{pixmap}), @var{screen} (@pxref{screen}), and @var{window} (@pxref{window}) are defined solely by a functional interface. Even though they are treated like structures in this document, it is not specified whether they are implemented as structures or classes. Although some interfaces are described as functions, they are not required to be defined using @var{defun.} (It is a requirement that they be functions as opposed to macros or special forms.) @end itemize @node Data Types, , Programming Considerations, Introduction to CLX @section Data Types The following are some data type definitions that are commonly used in CLX function definitions. @deftp {Type} alist (key-type-and-name datum-type-and-name) 'list @var{alist} defines an association list. An association list is a sequence, containing zero or more repetitions of the given elements with each of the elements expressed as (@emph{type} @emph{name}). @end deftp @deftp {Type} angle `(number ,(* -2pi) ,(* 2pi)) @var{angle} defines an angle in units of radians and is bounded by (-2%pi;) and (2%pi;). Note that we are explicitly using a different angle representation than what is actually transmitted in the protocol. @end deftp @deftp {Type} arc-seq '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height) (angle angle1) (angle angle2)) @var{arc-seq} defines a six-tuple sequence of the form (@emph{x}, @emph{y}, @emph{width}, @emph{height}, @emph{angle1}, @emph{angle2}). The points @emph{x} and @emph{y} are signed, 16-bit quantities with a range from -32,768 to 32,767. The @emph{width} and @emph{height} values are unsigned, 16-bit quantities and range from 0 to 65,535. @emph{angle1} and @emph{angle2} are in units of radians, and bounded by (-2%pi;) and (2%pi;). @end deftp @deftp {Type} array-index `(integer 0 ,array-dimension-limit) @var{array-index} defines a type which is a subtype of the integers and can be used to describe all variables that can be array indices. The range is inclusive because start and end array index specifiers can be one (1) past the end. @end deftp @deftp {Type} bit-gravity '(member gravity*) A keyword that specifies which region of a window should be retained when the window is resized. @emph{gravity} -- One of the following: @itemize @c menu @item @var{:center} @item @var{:north} @item @var{:south} @item @var{:static} @item @var{:east} @item @var{:north-east} @item @var{:south-east :west} @item @var{:forget} @item @var{:north-west} @item @var{:south-west} @end itemize If a window is reconfigured without changing its inside width or height, then the contents of the window moves with the window and are not lost. Otherwise, the contents of a resized window are either moved or lost, depending on its bit-gravity attribute. See @var{window-bit-gravity}, in @ref{Window Attributes}, for additional information. @end deftp @deftp {Type} bitmap '(array bit (* *)) Specifies a two-dimensional array of bits. @end deftp @deftp {Structure} bitmap-format A structure that describes the storage format of a bitmap. The @var{bitmap-format} structure contains slots for @var{unit}, @var{pad}, and @var{lsb-first-p}. The @var{unit} member indicates the unit of increments used to maintain the bitmap data. The units available for use are 8, 16, or 32 bits. The @var{pad} member indicates how many bits are needed to pad the left edge of the scan-line. The @var{lsb-first-p} member is a predicate which indicates the ordering of bits with the bitmap unit. @end deftp @deftp {Slot of bitmap-format} unit Type: (@var{member} 8 16 32). The size of a contiguous grouping of bits, which can be 8, 16, or 32. The default is 8. @end deftp @deftp {Slot of bitmap-format} pad Type: (@var{member} 8 16 32). The number of bits to left-pad the scan-line, which can be 8, 16, or 32. The default is 8. @end deftp @deftp {Slot of bitmap-format} lsb-first-p Type: @var{boolean}. A predicate indicating whether the least significant bit comes first (@var{true}) or not (@var{nil}). @end deftp @deftp {Type} boolean '(or nil (not nil)) @var{boolean} defines a type which is all inclusive. It is used for variables that can take on a true (non-@var{nil}) or false (@var{nil}) value. @end deftp @deftp {Type} boole-constant `(member value*) @var{boole-constant} defines a type that is a set of the values associated with the 16 boolean operation-code constants for the Common Lisp language. It is used for the set of allowed source and destination combination functions in a graphics context. @emph{value} -- One of the following: @itemize @c menu @item @var{boole-1} @item @var{boole-c1} @item @var{boole-nand} @item @var{boole-xor} @item @var{boole-2} @item @var{boole-c2} @item @var{boole-nor} @item @var{boole-and} @item @var{boole-clr} @item @var{boole-orc1} @item @var{boole-andc1} @item @var{boole-eqv} @item @var{boole-orc2} @item @var{boole-andc2} @item @var{boole-ior} @item @var{boole-set} @end itemize @end deftp @deftp {Type} card8 '(unsigned-byte 8) An unsigned integer value that is a maximum of eight bits long. This gives a number of this type a range from 0 to 255. @end deftp @deftp {Type} card16 '(unsigned-byte 16) An unsigned integer value that is a maximum of 16 bits long. This gives a number of this type a range from 0 to 65,535. @end deftp @deftp {Type} card29 '(unsigned-byte 29) An unsigned integer value that is a maximum of 29 bits long. This gives a number of this type a range from 0 to 536,870,911. @end deftp @deftp {Type} card32 '(unsigned-byte 32) An unsigned integer value that is a maximum of 32 bits long. This gives a number of this type a range from 0 to 4,294,967,295. @end deftp @deftp {Type} color '(satisfies color-p) @anchor{color} A @var{color}. @xref{Color Functions}, for additional information. @end deftp @deftp {Type} colormap '(satisfies colormap-p) @anchor{colormap} A @var{colormap}. @xref{Colormap Functions}, for additional information. @end deftp @deftp {Type} cursor '(satisfies cursor-p) @anchor{cursor} A @var{cursor}. @xref{Cursors}, for additional information. @end deftp @deftp {Type} device-event-mask '(or mask32 (list device-event-mask-class)) @anchor{event-mask} Provides a way to specify a set of bits for an event bitmask. Two ways of specifying the bits are allowed: by setting the event bits in a 32 bit mask, or by listing the keyword names of the device related event bits in a list. @end deftp @deftp {Type} device-event-mask-class '(member event*) A keyword name, for a device related event, that corresponds to a particular bit in an event bitmask. The set of names is a subset of the names in the type @var{event-mask-class}. @emph{event} -- One of the following: @itemize @c menu @item @var{:button-1-motion} @item @var{:button-motion} @item @var{:button-2-motion} @item @var{:button-press} @item @var{:button-3-motion} @item @var{:key-press} @item @var{:button-4-motion} @item @var{:key-release} @item @var{:button-5-motion} @item @var{:pointer-motion} @end itemize @end deftp @deftp {Type} display '(satisfies display-p) @anchor{display} A connection to an X server. @xref{Displays}, for additional information. @end deftp @deftp {Type} drawable '(or window pixmap) Both @var{windows} and @var{pixmaps} can be used as sources and destinations in graphics operations. @var{windows} and @var{pixmaps} together are known as @emph{drawables}. However, an @var{:input-only} window cannot be used as a source or destination in a graphics operation. @end deftp @deftp {Type} draw-direction '(member :left-to-right :right-to-left) Defines a list of rotation directions for drawing arcs and fonts. @var{draw-direction} can have the values of @var{:left-to-right} or @var{:right-to-left}. @end deftp @deftp {Type} error-key '(member error*) Defines a list of all predefined errors. All errors (synchronous and asynchronous) are processed by calling an error handler in the display. The handler is called with the display as the first argument and the error-key as its second argument. @emph{error} -- One of the following: @itemize @c menu @item @var{:access} @item @var{:drawable} @item @var{:implementation} @item @var{:value} @item @var{:alloc} @item @var{:font} @item @var{:length} @item @var{:window} @item @var{:atom} @item @var{:gcontext} @item @var{:match} @item @var{:colormap} @item @var{:id-choice} @item @var{:name} @item @var{:cursor} @item @var{:illegal-request} @item @var{:pixmap} @end itemize @end deftp @deftp {Type} event-key '(member event-type*) Defines a list that specifies all predefined event-types. Clients are informed of information asynchronously by means of events. These events can be either asynchronously generated from devices or generated as side effects of client requests. @emph{event-type} -- One of the following: @itemize @c menu @item @var{:button-press} @item @var{:exposure} @item @var{:motion-notify} @item @var{:button-release} @item @var{:focus-in} @item @var{:no-exposure} @item @var{:circulate-notify} @item @var{:focus-out} @item @var{:property-notify} @item @var{:circulate-request} @item @var{:graphics-exposure} @item @var{:reparent-notify} @item @var{:client-message} @item @var{:gravity-notify} @item @var{:resize-request} @item @var{:colormap-notify} @item @var{:keymap-notify} @item @var{:selection-clear} @item @var{:configure-notify} @item @var{:key-press} @item @var{:selection-notify} @item @var{:configure-request} @item @var{:key-release} @item @var{:selection-request} @item @var{:create-notify} @item @var{:leave-notify} @item @var{:unmap-notify} @item @var{:destroy-notify} @item @var{:map-notify} @item @var{:visibility-notify} @item @var{:enter-notify} @item @var{:map-request} @end itemize @end deftp @deftp {Type} event-mask '(or mask32 (list event-mask-class)) Provides a way to specify a set of bits for an event bitmask. Two ways of specifying the bits are allowed: by setting the event bits in a 32 bit mask, or by listing the keyword names of the event bits in a list. @end deftp @deftp {Type} event-mask-class '(member event*) The elements of the type @var{event-mask-class} are keyword names that correspond to a particular bit in an event bitmask. @emph{event} -- One of the following: @itemize @c menu @item @var{:button-1-motion} @item @var{:enter-window} @item @var{:pointer-motion-hint} @item @var{:button-2-motion} @item @var{:exposure} @item @var{:property-change} @item @var{:button-3-motion} @item @var{:focus-change} @item @var{:resize-redirect} @item @var{:button-4-motion} @item @var{:key-press} @item @var{:structure-notify} @item @var{:button-5-motion} @item @var{:key-release} @item @var{:substructure-notify} @item @var{:button-motion} @item @var{:keymap-state} @item @var{:substructure-redirect} @item @var{:button-press} @item @var{:leave-window} @item @var{:visibility-change} @item @var{:button-release} @item @var{:owner-grab-button} @item @var{:colormap-change} @item @var{:pointer-motion} @end itemize @end deftp @defun make-event-keys event-mask Returns a list of @var{event-mask-class} keyword names for the event bits that are set in the specified event mask. @table @var @item event-mask An event mask (type @var{mask32}). @end table @end defun @defun make-event-mask &rest keys @table @var @item keys @var{event-mask-class} keywords. @end table Constructs an event mask from a set of @var{event-mask-class} keyword names. @table @var @item event-mask Type @var{mask32}. @end table @end defun @deftp {Type} font '(satisfies font-p) @anchor{font} A text font. @xref{Font and Characters}, for additional information. @end deftp @deftp {Type} fontable '(or stringable font) A @var{fontable} is either a @var{font} object or the name of one of the fonts in the font database. @end deftp @deftp {Type} font-props 'list A @var{list} that contains alternating keywords and integers. @end deftp @deftp {Type} gcontext '(satisfies gcontext-p) @anchor{gcontext} A graphics context. @xref{Graphics Contexts}, for additional information. @end deftp @deftp {Type} gcontext-key '(member type*) A list of predefined types for use in @var{gcontext} processing. Various information for graphics output is stored in a graphics context (GC or GContext), such as foreground pixel, background pixel, line width, clipping region, and so forth. @var{type} -- One of the following: @itemize @c menu @item @var{:arc-mode} @item @var{:exposures} @item @var{:line-width} @item @var{:background} @item @var{:fill-rule} @item @var{:plane-mask} @item @var{:cap-style :fill-style} @item @var{:stipple} @item @var{:clip-mask} @item @var{:font} @item @var{:subwindow-mode} @item @var{:clip-x} @item @var{:foreground} @item @var{:tile} @item @var{:clip-y} @item @var{:function} @item @var{:ts-x} @item @var{:dash-offset} @item @var{:join-style} @item @var{:ts-y} @item @var{:dashes} @item @var{:line-style} @end itemize @end deftp @deftp {Type} grab-status '(member grab-type*) There are two kinds of grabs: active and passive. An @emph{active grab} occurs when a single client grabs the keyboard and/or pointer explicitly. Clients can also grab a particular keyboard key or pointer button in a window. The grab activates when the key or button is actually pressed, and is called a @emph{passive grab}. Passive grabs can be very convenient for implementing reliable pop-up menus. @var{grab-type} -- One of the following: @itemize @c menu @item @var{:already-grabbed} @item @var{:frozen} @item @var{:invalid-time} @item @var{:not-viewable} @item @var{:success} @end itemize @end deftp @deftp {Type} image-depth '(integer 0 32) Used in determining the depth of a pixmap, window, or image. The value specifies the number of bits deep that a given pixel has within a given pixmap, window, or image. @end deftp @deftp {Type} index-size '(member :default 8 16) Used to control the element size of the destination buffer given to the translate function when drawing glyphs. If @var{:default} is specified, the size is based on the current font, if known; otherwise, 16 is used. @end deftp @deftp {Type} int8 '(signed-byte 8) A signed integer value that is a maximum of eight bits long. A number of this type can have a range from -128 to 127. @end deftp @deftp {Type} int16 '(signed-byte 16) @anchor{int16} A signed integer value that is a maximum of 16 bits long. A number of this type can have a range from -32,768 to 32,767. @end deftp @deftp {Type} int32 '(signed-byte 32) A signed integer value that is a maximum of 32 bits long. A number of this type can have a range from -2,147,483,648 to 2,147,483,647. @end deftp @deftp {Type} keysym 'card32 Used as an encoding of a symbol on a keycap on a keyboard. It is an unsigned integer value represented in a maximum of 32 bits long. A @var{keysym} type can have a range from 0 to 4,294,967,295. @end deftp @deftp {Type} mask16 ' card16 A positional bitmask that contains 16 boolean flags. @end deftp @deftp {Type} mask32 ' card32 A positional bitmask that contains 32 boolean flags. @end deftp @deftp {Type} modifier-key '(member modifier*) A keyword identifying one of the modifier keys on the keyboard device. @var{modifier} -- One of the following: @itemize @c menu @item @var{:shift} @item @var{:mod-2} @item @var{:lock} @item @var{:mod-3} @item @var{:control} @item @var{:mod-4} @item @var{:mod-1} @item @var{:mod-5} @end itemize @end deftp @deftp {Type} modifier-mask '(or (member :any) mask16 (list modifier-key)) A bitmask or list of keywords that specifies a set of modifier keys. The keyword @var{:any} is equivalent to any subset of modifier key. @end deftp @deftp {Type} pixarray '(or (array pixel (* *)) (array card16 (* *)) (array card8 (* *)) (array (unsigned-byte 4) (* *)) (array bit (* *))) Specifies a two-dimensional array of pixels. @end deftp @deftp {Type} pixel '(unsigned-byte 32) An unsigned integer value that is a maximum of 32 bits long. This gives a pixel type a value range from 0 to 4,294,967,295. Useful values are dependent on the class of colormap being used. @end deftp @deftp {Type} pixmap '(satisfies pixmap-p) @anchor{pixmap} A @var{pixmap}, @pxref{Pixmaps}), for additional information. @end deftp @deftp {Structure} pixmap-format A structure that describes the storage format of a pixmap. The @var{pixmap-format} structure contains slots for @var{depth}, @var{bits-per-pixel}, and @var{scanline-pad}. The @var{depth} member indicates the number of bit planes in the pixmap. The @var{bits-per-pixel} member indicates the number of bits used to represent a single pixel. For X, a pixel can be 1, 4, 8, 16, 24, or 32 bits wide. As for @var{bitmap-format}, the @var{scanline-pad} member indicates how many pixels are needed to pad the left edge of the scan-line. @end deftp @deftp {Slot of pixmap-format} depth Type: @var{image-depth}. The number of bit planes in the pixmap. @end deftp @deftp {Slot of pixmap-format} bits-per-pixel Type: (@var{member} 1 4 8 16 24 32). The number of consecutive bits used to encode a single pixel. The default is 8. @end deftp @deftp {Slot of pixmap-format} scanline-pad Type: (@var{member} 8 16 32). The number of bits to left-pad the scan-line, which can be 8, 16, or 32. The default is 8. @end deftp @deftp {Type} point-seq '(repeat-seq (int16 x) (int16 y)) The @var{point-seq} type is used to define sequences of (@var{x},@var{y}) pairs of points. The paired values are 16-bit, signed integer quantities. This gives the points in this type a range from -32,768 to 32,767. @end deftp @deftp {Type} pointer-event-mask '(or mask32 (list pointer-event-mask-class)) Provides a way to specify a set of bits for an event bitmask. Two ways of specifying the bits are allowed: by setting the event bits in a 32 bit mask, or by listing the keyword names of the pointer related event bits in a list. @end deftp @deftp {Type} pointer-event-mask-class '(member event*) A keyword name, for a pointer related event, that corresponds to a particular bit in an event bitmask. The set of names is a subset of the names in the type @var{event-mask-class}. @var{event} -- One of the following: @itemize @c menu @item @var{:button-1-motion} @item @var{:button-motion} @item @var{:leave-window} @item @var{:button-2-motion} @item @var{:button-press} @item @var{:pointer-motion} @item @var{:button-3-motion} @item @var{:button-release} @item @var{:pointer-motion-hint} @item @var{:button-4-motion} @item @var{:enter-window} @item @var{:button-5-motion} @item @var{:keymap-state} @end itemize @end deftp @deftp {Type} rect-seq '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)) @var{rect-seq} defines a four-tuple sequence of the form (@var{x}, @var{y}, @var{width}, @var{height}). The points @var{x} and @var{y} are signed, 16-bit quantities with a range from -32,768 to 32,767. The @var{width} and @var{height} values are unsigned, 16-bit quantities and range from 0 to 65,535. @end deftp @deftp {Type} repeat-seq (&rest elts) 'sequence A subtype used to define repeating sequences. @end deftp @deftp {Type} resource-id 'card29 A numeric identifier that is assigned by the server to a server resource object. @end deftp @deftp {Type} rgb-val '(float 0.0 1.0) An @var{rgb-val} is a floating-point value between 0 and 1 that specifies a saturation for a red, green, or blue additive primary. The 0 value indicates no saturation and 1 indicates full saturation. @end deftp @deftp {Type} screen '(satisfies screen-p) @anchor{screen} A display screen. @xref{Screens}, for further information. @end deftp @deftp {Type} seg-seq '(repeat-seq (int16 x1) (int16 y1) (int16 x2) (int16 y2)) Defines sequences of (@var{x1}, @var{y1}, @var{x2}, @var{y2}) sets of points. The point values are 16-bit, signed integer quantities. This gives the points in this type a range from -32,768 to 32,767. @end deftp @deftp {Type} state-mask-key '(or modifier-key (member button*)) A keyword identifying one of the display modifier keys or pointer buttons whose state is reported in device events. @var{button} -- One of the following: @itemize @c menu @item @var{:button-1} @item @var{:button-4} @item @var{:button-2} @item @var{:button-5} @item @var{:button-3} @end itemize @end deftp @defun make-state-keys state-mask @table @var @item state-mask A 16-bit mask of type @var{mask16}. @end table Returns a list of @var{state-mask-key} symbols corresponding to the @var{state-mask}. A symbol belongs to the returned list if, and only if, the corresponding @var{state-mask} bit is 1. @table @var @item state-keywords Type @var{list}. @end table @end defun @defun make-state-mask &rest keys @table @var @item keys A list of @var{state-mask-key} symbols. @end table Returns a 16-bit @var{mask} representing the given @var{state-mask-key} symbols. The returned @var{mask} contains a 1 bit for each keyword. @table @var @item mask Type @var{mask16}. @end table @end defun @deftp {Type} stringable '(or string symbol) Used for naming something. This type can be either a string or a @var{symbol} whose @var{symbol-name} is used as the string containing the name. The case of the characters in the string is ignored when comparing stringables. @end deftp @deftp {Type} timestamp '(or null card32) An encoding of a time. @var{nil} stands for the current time. @end deftp @deftp {Structure} visual-info A structure that represents a visual type. The elements of this structure are @var{id}, @var{class}, @var{red-mask}, @var{green-mask}, @var{blue-mask}, @var{bits-per-rgb}, and @var{colormap-entries}. @end deftp @deftp {Slot of visual-info} id Type: @var{card29}. A unique identification number. @end deftp @deftp {Slot of visual-info} class Type: (member :direct-color :gray-scale :pseudo-color :static-color :static-gray :true-color). The class of the visual type. @end deftp @deftp {Slots of visual-info} red-mask @deftpx {Slots of visual-info} green-mask @deftpx {Slots of visual-info} blue-mask Type: @var{pixel}. The @var{red-mask}, @var{green-mask}, and @var{blue-mask} elements are only meaningful for the @var{:direct-color} and @var{:true-color} classes. Each mask has one contiguous set of bits with no intersections. @end deftp @deftp {Slot of visual-info} bits-per-rgb Type: @var{card8}. Specifies the log base 2 of the approximate number of distinct color values ( individually) of red, green, and blue. Actual RGB values are unsigned 16-bit numbers. @end deftp @deftp {Slot of visual-info} colormap-entries Type: @var{card16}. Defines the number of available colormap entries in a newly created colormap. For @var{:direct-color} and @var{:true-color}, this is the size of an individual pixel subfield. @end deftp @deftp {Type} win-gravity '(member gravity*) A keyword that specifies how to reposition a window when its parent is resized. @var{gravity} -- One of the following: @itemize @c menu @item @var{:center} @item @var{:north-west} @item @var{:static} @item @var{:east} @item @var{:south} @item @var{:unmap} @item @var{:north} @item @var{:south-east} @item @var{:west} @item @var{:north-east} @item @var{:south-west} @end itemize If a parent window is reconfigured without changing its inside width or height, then all child windows move with the parent and are not changed. Otherwise, each child of the resized parent is moved, depending on the child's gravity attribute. See @var{window-gravity} (@pxref{Window Attributes})), for additional information. @end deftp @deftp {Type} window '(satisfies window-p) @anchor{window} A window. @xref{Windows and Pixmaps}, for additional information. @end deftp @deftp {Structure} wm-size-hints A structure that contains size hints for the window manager. @end deftp @deftp {Slot of wm-size-hints} x Type: (@var{or} @var{null} @var{int32}). This slot is obsolete. New window managers do not use it. @end deftp @deftp {Slot of wm-size-hints} y Type: (@var{or} @var{null} @var{int32}). This slot is obsolete. New window managers do not use it. @end deftp @deftp {Slot of wm-size-hints} width Type: (@var{or} @var{null} @var{card32}). This slot is obsolete. New window managers do not use it. They will use the @var{min-width} and @var{max-width} slots instead. @end deftp @deftp {Slot of wm-size-hints} height Type: (@var{or} @var{null} @var{card32}). This slot is obsolete. New window managers do not use it. They will use the @var{min-height} and @var{max-height} slots instead. @end deftp @deftp {Slot of wm-size-hints} min-width Type: (@var{or} @var{null} @var{card32}). This slot indicates the smallest width for which the application still works properly. @end deftp @deftp {Slot of wm-size-hints} min-height Type: (@var{or} @var{null} @var{card32}). This slot indicates the smallest height for which the application still works properly. @end deftp @deftp {Slot of wm-size-hints} max-width Type: (@var{or} @var{null} @var{card32}). This slot indicates the largest width for which the application still works properly. @end deftp @deftp {Slot of wm-size-hints} max-height Type: (@var{or} @var{null} @var{card32}). This slot indicates the largest height for which the application still works properly. @end deftp @deftp {Slot of wm-size-hints} width-inc Type: (@var{or} @var{null} @var{card32}). This slot defines an arithmetic progression of widths (minimum to maximum) into which the window prefers to be resized. @end deftp @deftp {Slot of wm-size-hints} height-inc Type: (@var{or} @var{null} @var{card32}). This slot defines an arithmetic progression of heights (minimum to maximum) into which the window prefers to be resized. @end deftp @deftp {Slot of wm-size-hints} min-aspect Type: (@var{or} @var{null} @var{number}). This slot specifies the minimum aspect ratio (the fraction @var{x} size divided by @var{y} size) preferred by the application. @end deftp @deftp {Slot of wm-size-hints} max-aspect Type: (@var{or} @var{null} @var{number}). This slot specifies the maximum aspect ratio (the fraction @var{x} size divided by @var{y} size) preferred by the application. @end deftp @deftp {Slot of wm-size-hints} base-width Type: (@var{or} @var{null} @var{card32}). This slot specifies the desired width of the window. @end deftp @deftp {Slot of wm-size-hints} base-height Type: (@var{or} @var{null} @var{card32}). This slot specifies the desired height of the window. @end deftp @deftp {Slot of wm-size-hints} win-gravity Type: (@var{or} @var{null} @var{win-gravity}). The window manager will interpret the position of the window and its border width to position the point of the outer rectangle of the overall window specified by the value of this slot. The outer rectangle of the window includes any borders or decorations supplied by the window manager. In other words, if the window manager decides to place the window where the client asked, the position on the parent window's border named by the value of this slot will be placed where the client window would have been placed in the absence of a window manager. @end deftp @deftp {Type} xatom '(or string symbol) A name that has been assigned a corresponding unique ID by the server. @var{xatoms} are used to identify properties, selections, and types defined in the X server. An @var{xatom} can be either a @var{string} or @var{symbol} whose @var{symbol-name} is used as the @var{xatom} name. The case of the characters in the string are significant when comparing @var{xatoms}. @end deftp @node Displays, Screens, Introduction to CLX, Top @chapter Displays A particular X server, together with its screens and input devices, is called a @emph{display}. The CLX @var{display} object contains all the information about the particular display and its screens, as well as the state that is needed to communicate with the display over a particular connection. Before your program can use a display, you must establish a connection to the X server driving your display. Once you have established a connection, you then can use the CLX macros and functions discussed in this section to return information about the display. This section discusses how to: @itemize @bullet @item Open (connect) a display @item Obtain information about a display @item Access and change display attributes @item Close (disconnect) a display @end itemize @menu * Opening the Display:: * Display Attributes:: * Managing the Output Buffer:: * Closing the Display:: @end menu @node Opening the Display, Display Attributes, Displays, Displays @section Opening the Display The @var{open-display} and @var{open-default-display} functions are used to open a connection to an X server. @var{open-default-display} is an extension that is not present in the MIT CLX tree, but is preferred where available as it uses the same rules for display defaulting as the C Xlib bindings, and tends to get authorization right more often than @var{open-display} (particularly on ssh-forwarded connections) @defun open-display host &key :display :protocol @table @var @item host Specifies the name of the @emph{host} machine on which the server executes. A string must be acceptable as a @emph{host}, but otherwise the possible types are not constrained and will likely be very system dependent. @item :display An integer that specifies which display device on the @emph{host} should be used for this connection. This is needed since multiple displays can be controlled by a single X server. The default is display 0 (zero). @item :protocol A keyword argument that specifies which network protocol should be used for connecting to the server (for example, @var{:tcp}, @var{:dna}, or @var{:chaos}). The set of possible values and the default value are implementation specific. @end table Returns a @var{display} that serves as the connection to the X server and contains all the information about that X server. Authorization, if any, is assumed to come from the environment. After a successful call to @var{open-display}, all screens on the display can be used by the client application. @table @var @item display Type @var{display}. @end table @end defun @defun open-default-display &optional display-name @table @var @item display-name The display to connect to. Display names have the format @verbatim [protocol/] [hostname] : [:] displaynumber [.screennumber] @end verbatim There are two special cases in parsing, to match that done in the Xlib C language bindings @itemize @bullet @item If the hostname is @code{unix} or the empty string, any supplied protocol is ignored and a connection is made using the @code{local} transport. @item If a double colon separates @var{hostname} from @var{displaynumber}, the protocol is assumed to be @code{decnet}. @end itemize If @var{display-name} is not supplied, a default will be provided appropriate for the local environment: on a POSIX system - the only kind this CLX port runs on - the default display is taken from the environment variable @env{DISPLAY}. See also the section ``DISPLAY NAMES'' in X(7) @end table Open a connection to @var{display-name} or to the appropriate default display. @code{open-display-name} always attempts to do display authorization, following complicated rules that closely match the ones that the C Xlib bindings use. Briefly: the hostname is resolved to an address, then authorization data for the (protocol, host-address, displaynumber) triple is looked up in the file given by the environment variable @env{AUTHORITY_PATHNAME} (typically @file{$HOME/.Xauthority}). If the protocol is @code{:local}, or if the hostname resolves to the local host, authority data for the local machine's actual hostname - as returned by gethostname(3) - is used instead. @end defun @node Display Attributes, Managing the Output Buffer, Opening the Display, Displays @section Display Attributes The complete set of display attributes is discussed in the following paragraphs. @defun display-authorization-data display @table @var @item display A @var{display} object. @end table Returns the authorization data string for @var{display} that was transmitted to the server by @var{open-display} during connection setup. The data is specific to the particular authorization protocol that was used. The @var{display-authorization-name} function returns the protocol used. @table @var @item authorization-data Type @var{string}. @end table @end defun @defun display-authorization-name display @table @var @item display A @var{display} object. @end table Returns the authorization protocol namestring for @var{display} that was transmitted by @var{open-display} to the server during connection setup. The @var{authorization-name} indicates what authorization protocol the client expects the server to use. Specification of valid authorization mechanisms is not part of the X protocol. A server that implements a different protocol than the client expects, or a server that only implements the host-based mechanism, can simply ignore this information. If both name and data strings are empty, this is to be interpreted as "no explicit authorization." @table @var @item authorization-name Type @var{string}. @end table @end defun @defun display-bitmap-format display @anchor{display-bitmap-format} @table @var @item display A @var{display} object. @end table Returns the @emph{bitmap-format} information for the specified @emph{display}. @table @var @item bitmap-format Type @var{bitmap-format}. @end table @end defun @defun display-byte-order display @table @var @item display A @var{display} object. @end table Returns the @var{byte-order} to be employed in communication with the server for the given @var{display}. The possible values are as follows: @table @var @item :lsbfirst Values are transmitted least significant byte first. @item :msbfirst Values are transmitted most significant byte first. @end table Except where explicitly noted in the protocol, all 16-bit and 32-bit quantities sent by the client must be transmitted with this @var{byte-order}, and all 16-bit and 32-bit quantities returned by the server are transmitted with this @var{byte-order}. @table @var @item byte-order Either @var{:lsbfirst} or @var{:msbfirst}. @end table @end defun @defun display-display display @table @var @item display A @var{display} object. @end table Returns the @var{display-number} for the host associated with @var{display}. @table @var @item display-number Type @var{integer}. @end table @end defun @defun display-error-handler display @table @var @item display A @var{display} object. @end table Returns and (with @code{setf}) sets the @var{error-handler} function for the given @var{display}. CLX calls (one of) the display error handler functions to handle server errors returned to the connection. The default error handler, @var{default-error-handler}, signals conditions as they occur. @xref{Errors}, for a list of the conditions that CLX can signal. For more information about errors and error handling, refer to the section entitled Common Lisp Condition System in the @emph{Lisp Reference} manual. If the value of @var{error-handler} is a sequence, it is expected to contain a handler function for each specific error. The error code is used as an index into the sequence to fetch the appropriate handler function. If this element is a function, it is called for all errors. Any results returned by the handler are ignored since it is assumed the handler either takes care of the error completely or else signals. The arguments passed to the handler function are the @var{display} object, a symbol naming the type of error, and a set of keyword-value argument pairs that vary depending on the type of error. For all core errors, the keyword-value argument pairs are: @multitable @columnfractions 0.5 0.5 @item @var{:current-sequence} @tab @var{card16} @item @var{:major} @tab @var{card8} @item @var{:minor} @tab @var{card16} @item @var{:sequence} @tab @var{card16} @end multitable For @var{colormap}, @var{cursor}, @var{drawable}, @var{font}, @var{gcontext}, @var{id-choice}, @var{pixmap}, and @var{window} errors, the keyword-value pairs are the core error pairs plus: @multitable @columnfractions 0.5 0.5 @item @var{:resource-id} @tab @var{card32} @end multitable For @var{:atom} errors, the keyword-value pairs are the core error pairs plus: @multitable @columnfractions 0.5 0.5 @item @var{:atom-id} @tab @var{card32} @end multitable For @var{:value} errors, the keyword-value pairs are the core error pairs plus: @multitable @columnfractions 0.5 0.5 @item @var{:value} @tab @var{card32} @end multitable @table @var @item error-handler Type @var{function} or @var{sequence}. @end table @end defun @defun display-image-lsb-first-p display @table @var @item display A @var{display} object. @end table Although the server is generally responsible for byte swapping communication data to match the client, images (pixmaps/bitmaps) are always transmitted and received in formats (including byte order) specified by the server. Within images for each scan-line unit in bitmaps or for each pixel value in pixmaps, the leftmost bit in the image as displayed on the screen is either the least or most significant bit in the unit. For the given @var{display}, @var{display-image-lsb-first-p} returns non-@var{nil} if the leftmost bit is the least significant bit; otherwise, it returns @var{nil}. @table @var @item image-lsb-first-p Type @var{boolean}. @end table @end defun @defun display-keycode-range display @table @var @item display A @var{display} object. @end table Returns @var{min-keycode} and @var{max-keycode} as multiple values. See the @var{display-max-keycode} and @var{display-min-keycode} functions for additional information. @table @var @item min-keycode @itemx max-keycode Type @var{card8}. @end table @end defun @defun display-max-keycode display @table @var @item display A @var{display} object. @end table Returns the maximum keycode value for the specified @emph{display}. This value is never greater than 255. Not all keycodes in the allowed range are required to have corresponding keys. @table @var @item max-keycode Type @var{card8}. @end table @end defun @defun display-max-request-length display @table @var @item display A @var{display} object. @end table Returns the maximum length of a request, in four-byte units, that is accepted by the specified @emph{display}. Requests larger than this generate a length error, and the server will read and simply discard the entire request. This length is always at least 4096 (that is, requests of length up to and including 16384 bytes are accepted by all servers). @table @var @item max-request-length Type @var{card16}. @end table @end defun @defun display-min-keycode display @table @var @item display A @var{display} object. @end table Returns the minimum keycode value for the specified @var{display}. This value is never less than eight. Not all keycodes in the allowed range are required to have corresponding keys. @table @var @item min-keycode Type @var{card8}. @end table @end defun @defun display-motion-buffer-size display @table @var @item display A @var{display} object. @end table Returns the approximate size of the motion buffer for the specified @var{display}. The server can retain the recent history of pointer motion at a finer granularity than is reported by @var{:motion-notify} events. Such history is available through the @var{motion-events} function. @table @var @item motion-buffer-size Type @var{card32}. @end table @end defun @defun display-p display @table @var @item display-p Type @var{boolean}. @end table Returns non-@var{nil} if @emph{display} is a @var{display} object; @end defun @defun display-pixmap-formats display @table @var @item display A @var{display} object. @end table Returns the list of @var{pixmap-format} values for the given @emph{display}. This list contains one entry for each depth value. The entry describes the format used to represent images of that depth. An entry for a depth is included if any screen supports that depth, and all screens supporting that depth must support (only) the format for that depth. @table @var @item pixmap-formats Type @var{list}. @end table @end defun @defun display-plist display @table @var @item display A @var{display} object. @end table Returns and (with @code{setf}) sets the property list for the specified @emph{display}. This function provides a hook where extensions can add data. @table @var @item plist Type @var{list}. @end table @end defun @defun display-protocol-major-version display @table @var @item display A @var{display} object. @end table Returns the major version number of the X protocol associated with the specified @emph{display}. In general, the major version would increment for incompatible changes. The returned protocol version number indicates the protocol the server actually supports. This might not equal the version supported by the client. The server can (but need not) refuse connections from clients that offer a different version than the server supports. A server can (but need not) support more than one version simultaneously. @table @var @item protocol-major-version Type @var{card16}. @end table @end defun @defun display-protocol-minor-version display @table @var @item display A @var{display} object. @end table Returns the minor protocol revision number associated with the specified @emph{display}. In general, the minor version would increment for small upward compatible changes in the X protocol. @table @var @item protocol-minor-version Type @var{card16}. @end table @end defun @defun display-protocol-version display @table @var @item display A @var{display} object. @end table Returns @emph{protocol-major-version} and @emph{protocol-minor-version} as multiple values. See the @var{display-protocol-major-version} and @var{display-protocol-minor-version} functions for additional information. @table @var @item protocol-major-version @itemx protocol-minor-version @end table @end defun @defun display-resource-id-base display @table @var @item display A @var{display} object. @end table Returns the @emph{resource-id-base} value that was returned from the server during connection setup for the specified @emph{display}. This is used in combination with the @emph{resource-id-mask} to construct valid IDs for this connection. @table @var @item resource-id-base Type @var{resource-id}. @end table @end defun @defun display-resource-id-mask display @table @var @item display A @var{display} object. @end table Returns the @emph{resource-id-mask} that was returned from the server during connection setup for the specified @emph{display}. The @emph{resource-id-mask} contains a single contiguous set of bits (at least 18) which the client uses to allocate resource IDs for types @var{window}, @var{pixmap}, @var{cursor}, @var{font}, @var{gcontext}, and @var{colormap} by choosing a value with (only) some subset of these bits set, and @var{or}ing it with the @emph{resource-id-base}. Only values constructed in this way can be used to name newly created server resources over this connection. Server resource IDs never have the top three bits set. The client is not restricted to linear or contiguous allocation of server resource IDs. Once an ID has been freed, it can be reused, but this should not be necessary. An ID must be unique with respect to the IDs of all other server resources, not just other server resources of the same type. However, note that the value spaces of server resource identifiers, atoms, visualids, and keysyms are distinguished by context, and as such are not required to be disjoint (for example, a given numeric value might be both a valid window ID, a valid atom, and a valid keysym.) @table @var @item resource-id-mask Type @var{resource-id}. @end table @end defun @defun display-roots display @table @var @item display A @var{display} object. @end table Returns a list of all the @var{screen} structures available for the given @emph{display}. @table @var @item roots A list of screens. @end table @end defun @defun display-vendor display @table @var @item display A @var{display} object. @end table Returns @emph{vendor-name} and @emph{release-number} as multiple values. See the @var{display-vendor-name} and @var{display-release-number} functions for additional information. @table @var @item vendor-name @itemx release-number @end table @end defun @defun display-vendor-name display @table @var @item display A @var{display} object. @end table Returns a string that provides some vendor identification of the X server implementation associated with the specified @emph{display}. @table @var @item vendor-name Type @var{string}. @end table @end defun @defun display-version-number display @table @var @item display A @var{display} object. @end table Returns the X protocol version number for this implementation of CLX. @table @var @item version-number Type @var{card16}. @end table @end defun @defun display-xid display @table @var @item display A @var{display} object. @end table Returns the function that is used to allocate server resource IDs for this @emph{display}. @table @var @item resource-allocator Type @var{function}. @end table @end defun @defmac with-display display &body body This macro is for use in a multi-process environment. @var{with-display} provides exclusive access to the local @var{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 @var{with-display}), then synchronization need not (but can) occur immediately. Except where noted, all routines effectively contain an implicit @var{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 work correctly. This macro does not prevent concurrent event processing (@pxref{with-event-queue}). @table @var @item display A @var{display}. @end table @end defmac @node Managing the Output Buffer, Closing the Display, Display Attributes, Displays @section Managing the Output Buffer Most CLX functions cause output requests to be generated to an X server. Output requests are not transmitted immediately but instead are stored in an @emph{output buffer} for the appropriate display. Requests in the output buffer are typically sent only when the buffer is filled. Alternatively, buffered requests can be sent prior to processing an event in the input event queue (@pxref{Processing Events}). In either case, CLX sends the output buffer automatically without explicit instructions from the client application. However, in some cases, explicit control over the output buffer is needed, typically to ensure that the X server is in a consistent state before proceeding further. The @var{display-force-output} and @var{display-finish-output} functions allow a client program to synchronize with buffered output requests. @defun display-after-function display @table @var @item display A @var{display} object. @end table Returns and (with @code{setf}) sets the @emph{after-function} for the given @emph{display}. If @emph{after-function} is non-@var{nil}, it is a function that is called after every protocol request is generated, even those inside an explicit @var{with-display}, but never called from inside the @emph{after-function}. The function is called inside the effective @var{with-display} for the associated request. The default value is @var{nil}. This can be set, for example, to #'@var{display-force-output} or #' @var{display-finish-outpu}t. @table @var @item after-function Type @var{function} or @var{null}. @end table @end defun @defun display-force-output display @anchor{display-force-output} @table @var @item display A @var{display} object. @end table Forces any buffered output to be sent to the X server. @end defun @defun display-finish-output display @anchor{display-finish-output} @table @var @item display A @var{display} object. @end table Forces any buffered output to be sent to the X server and then waits until all requests display error handler. Any events generated by output requests are read and stored in the event queue. @end defun @node Closing the Display, , Managing the Output Buffer, Displays @section Closing the Display To close or disconnect a display from the X server, use @var{close-display}. @defun close-display display @table @var @item display A @var{display} object. @end table Closes the connection to the X server for the specified @var{display}. It destroys all server resources (@var{window}, @var{font}, @var{pixmap}, @var{colormap}, @var{cursor}, and @var{gcontext}), that the client application has created on this display, unless the close down mode of the server resource has been changed (@pxref{set-close-down-mode}). Therefore, these server resources should never be referenced again. In addition, this function discards any output requests that have been buffered but have not yet been sent. @end defun @node Screens, Windows and Pixmaps, Displays, Top @chapter Screens @menu * Screens and Visuals:: * Screen Attributes:: @end menu @node Screens and Visuals, Screen Attributes, Screens, Screens @section Screens and Visuals An X display supports graphical output to one or more @emph{screens}. Each screen has its own root window and window hierarchy. Each window belongs to exactly one screen and cannot simultaneously appear on another screen. The kinds of graphics hardware used by X screens can vary greatly in their support for color and in their methods for accessing raster memory. X uses the concept of a @emph{visual type} (usually referred to simply as a @emph{visual}) which uniquely identifies the hardware capabilities of a display screen. Fundamentally, a visual is represented by a @var{card29} integer ID, which uniquely identifies the visual type relative to a single display. CLX also represents a visual with a @var{visual-info} structure that contains other attributes associated with a visual (@pxref{Data Types}). A screen can support more than one depth (that is, pixel size), and for each supported depth, a screen may support more than one visual. However, it is more typical for a screen to have only a single depth and a single visual type. A visual represents various aspects of the screen hardware, as follows: @itemize @bullet @item A screen can be color or gray-scale. @item A screen can have a colormap that is either writable or read-only. @item A screen can have a single colormap or separate colormaps for each of the red, green, and blue components. With separate colormaps, a pixel value is decomposed into three parts to determine indexes into each of the red, green, and blue colormaps. @end itemize CLX supports the following classes of visual types: @var{:direct-color}, @var{:gray-scale}, @var{:pseudo-color}, @var{:static-color}, @var{:static-gray}, and @var{:true-color}. The following tables show how the characteristics of a screen determine the class of its visual type. For screens with a single colormap: @multitable {} {Color} {Gray-Scale} @item Read-only @tab @var{:static-color} @tab @var{:static-gray} @item Writable @tab @var{:pseudo-color} @tab @var{:gray-scale} @end multitable For screens with red, green, and blue colormaps: @multitable @columnfractions 0.3 0.3 0.3 @item Read-only @tab @var{:true-color} @tab @item Writable @tab @var{:direct-color} @tab @var{:gray-scale} @end multitable The visual class also indicates how screen colormaps are handled. @pxref{Colormaps and Colors}). @node Screen Attributes, , Screens and Visuals, Screens @section Screen Attributes In CLX, each display screen is represented by a @var{screen} structure. The @var{display-roots} function returns the list of @var{screen} structures for the display. The following paragraphs discuss the attributes of CLX @var{screen} structures. @defun screen-backing-stores screen @table @var @item screen A @var{screen}. @end table Returns a value indicating when the @emph{screen} supports backing stores, although it may be storage limited in the number of windows it can support at once. The value returned can be one of @var{:always}, @var{:never}, or @var{:when-mapped}. @table @var @item backing-stores-type One of @var{:always}, @var{:never}, or @var{:when-mapped}. @end table @end defun @defun screen-black-pixel screen @table @var @item screen A @var{screen}. @end table Returns the black pixel value for the specified @emph{screen}. @table @var @item black-pixel Type @var{pixel}. @end table @end defun @defun screen-default-colormap screen @table @var @item screen A @var{screen}. @end table Returns the @emph{default-colormap} for the specified @emph{screen}. The @emph{default-colormap} is initially associated with the root window. Clients with minimal color requirements creating windows of the same depth as the root may want to allocate from this map by default. Most routine allocations of color should be made out of this colormap. @table @var @item default-colormap Type @var{colormap}. @end table @end defun @defun screen-depths screen @table @var @item screen A @var{screen}. @end table Returns an association list that specifies what drawable depths are supported on the specified @emph{screen}. Elements of the returned association list have the form (depth @emph{visual}*), where each @emph{visual} is a @var{visual-info} structure. Pixmaps are supported for each depth listed, and windows of that depth are supported if at least one visual type is listed for the depth. A pixmap depth of one is always supported and listed, but windows of depth one might not be supported. A depth of zero is never listed, but zero-depth @var{:input-only} windows are always supported. @table @var @item depths Type @var{alist}. @end table @end defun @defun screen-event-mask-at-open screen @table @var @item screen A @var{screen}. @end table Returns the initial root event mask for the specified @emph{screen}. @table @var @item event-mask-at-open Type @var{mask32}. @end table @end defun @defun screen-height screen @table @var @item screen A @var{screen}. @end table Returns the @emph{height} of the specified @emph{screen} in pixel units. @table @var @item height Type @var{card16}. @end table @end defun @defun screen-height-in-millimeters screen @table @var @item screen A @var{screen}. @end table Returns the height of the specified @emph{screen} in millimeters. The returned height can be used with the width in millimeters to determine the physical size and the aspect ratio of the screen. @table @var @item height-in-millimeters Type @var{card16}. @end table @end defun @defun screen-max-installed-maps screen @table @var @item screen A @var{screen}. @end table Returns the maximum number of colormaps that can be installed simultaneously with @var{install-colormap}. @table @var @item max-installed-colormaps Type @var{card16}. @end table @end defun @defun screen-min-installed-maps screen @table @var @item screen A @var{screen}. @end table Returns the minimum number of colormaps that can be guaranteed to be installed simultaneously. @table @var @item min-installed-colormaps Type @var{card16}. @end table @end defun @defun screen-p screen @table @var @item screen-p Type @var{boolean}. @end table Returns non-@code{nil} if the @emph{screen} argument is a @end defun @defun screen-plist screen @table @var @item screen A @var{screen}. @end table Returns and (with @code{setf}) sets the property list for the specified @emph{screen}. This function provides a hook where extensions can add data. @table @var @item plist Type @var{list}. @end table @end defun @defun screen-root screen @table @var @item screen A @var{screen}. @end table Returns the @emph{root-window} for the specified @emph{screen}. This function is useful with functions that take a parent window as an argument. The class of the root window is always @var{:input-output}. @table @var @item root-window Type @var{window} or @var{null}. @end table @end defun @defun screen-root-depth screen @table @var @item screen A @var{screen}. @end table Returns the depth of the root window for the specified @emph{screen}. Other depths can also be supported on this @emph{screen}. @table @var @item root-window-depth Type @var{image-depth}. @end table @end defun @defun screen-root-visual screen @table @var @item screen A @var{screen}. @end table Returns the default visual type for the root window for the specified @emph{screen}. @table @var @item root-window-visual Type @var{card29}. @end table @end defun @defun screen-save-unders-p screen @table @var @item screen A screen. @end table If true, the server can support the save-under mode in @var{create-window} and in changing window attributes. @table @var @item save-unders-p Type @var{boolean}. @end table @end defun @defun screen-white-pixel screen @table @var @item screen A screen. @end table Returns the white pixel value for the specified @emph{screen}. @table @var @item white-pixel Type @var{pixel}. @end table @end defun @defun screen-width screen @table @var @item screen A screen. @end table Returns the width of the specified @emph{screen} in pixel units. @table @var @item width Type @var{card16}. @end table @end defun @defun screen-width-in-millimeters screen @table @var @item screen A screen. @end table Returns the width of the specified @emph{screen} in millimeters. The returned width can be used with the height in millimeters to determine the physical size and the aspect ratio of the screen. @table @var @item width-in-millimeters Type @var{card16}. @end table @end defun @node Windows and Pixmaps, Graphics Contexts, Screens, Top @chapter Windows and Pixmaps @menu * Drawables:: * Creating Windows:: * Window Attributes:: * Stacking Order:: * Window Hierarchy:: * Mapping Windows:: * Destroying Windows:: * Pixmaps:: @end menu @node Drawables, Creating Windows, Windows and Pixmaps, Windows and Pixmaps @section Drawables Both windows and pixmaps can be used as sources and destinations in graphics operations. These are collectively known as @emph{drawables}. The following functions apply to both windows and pixmaps. @defun drawable-display drawable @table @var @item drawable A @var{drawable} object. @end table Returns the display for the specified @emph{drawable}. @end defun @defun drawable-equal drawable-1 drawable-2 @table @var @item drawable-1 @itemx drawable-2 @var{drawable} objects. @end table Returns true if the two arguments refer to the same server resource, and @var{nil} if they do not. @end defun @defun drawable-id drawable @table @var @item drawable A @var{drawable} object. @end table Returns the unique resource ID assigned to the specified @var{drawable}. @table @var @item id Type @var{resource-id}. @end table @end defun @defun drawable-p drawable @table @var @item boole Type @var{boolean}. @end table Returns true if the argument is a @var{drawable} and @var{nil} otherwise. @end defun @defun drawable-plist drawable @table @var @item plist A property list. @end table Returns and (with @code{setf}) sets the property list for the specified @emph{drawable}. This function provides a hook where extensions can add data. @end defun @node Creating Windows, Window Attributes, Drawables, Windows and Pixmaps @section Creating Windows A window is a @var{drawable} that can also receive input events. CLX represents a window with a @var{window} object. The @var{create-window} function creates a new @var{window} object. @defun create-window &key :parent :x :y :width :height (:depth 0) (:border-width 0) (:class :copy) (:visual :copy) :background :border :gravity :bit-gravity :backing-store :backing-planes :backing-pixel :save-under :event-mask :do-not-propagate-mask :override-redirect :colormap :cursor @anchor{create-window} @table @var @item :parent The parent window. This argument is required. @item :x @itemx :y @var{int16} coordinates for the outside upper-left corner of the new window with respect to the origin (inside upper-left corner) of the @var{:parent}. These arguments are required. @item :width @itemx :height @var{card16} values for the size of the new window. These arguments are required. @item :depth A @var{card16} specifying the depth of the new window. @item :class One of @var{:input-outpu}t, @var{:input-only}, or @var{:copy}. @item :visual A @var{card29} ID specifying the visual type of the new window. @item :background @itemx :backing-pixel @itemx :backing-planes @itemx :backing-store @itemx :bit-gravity @itemx :border @itemx :border-width @itemx :colormap @itemx :cursor @itemx :do-not-propagate-mask @itemx :event @itemx :gravity @itemx :override-redirect @itemx :save-under Initial attribute values for the new window. If @var{nil}, the default value is defined by the X protocol.See paragraph @end table Creates and returns a window. A @var{:parent} window must be specified; the first window created by a client will have a root window as its @var{:parent}. The new window is initially unmapped and is placed on top of its siblings in the stacking order. A @var{:create-notify} event is generated by the server. The @var{:class} of a window can be @var{:input-output} or @var{:input-only}. Windows of class @var{:input-only} cannot be used as the destination drawable for graphics output and can never receive @var{:exposure} events, but otherwise operate the same as @var{:input-output} windows. The @var{:class} can also be @var{:copy}, in which case the new window has the same class as its @var{:parent}. For an @var{:input-output} window, the @var{:visual} and @var{:depth} must be a combination supported by the @var{:parent}'s screen, but the @var{:depth} need not be the same as the @var{:parent}'s. The @var{:parent} of an @var{:input-output} window must also be @var{:input-output}. A @var{:depth} of 0 means that the depth of the @var{:parent} is used. For an @var{:input-only} window, the @var{:depth} must be zero, and the @var{:visual} must be supported by the @var{:parent}'s screen. The @var{:parent} of an @var{:input-only} window can be of any class. The only attributes that can be given for an @var{:input-only} window are @var{:cursor}, @var{:do-not-propagate-mask}, @var{:event-mask}, @var{:gravity}, and @var{:override-redirect}. @table @var @item window Type @var{window}. @end table @end defun @node Window Attributes, Stacking Order, Creating Windows, Windows and Pixmaps @section Window Attributes The following paragraphs describe the CLX functions used to return or change window attributes. Using the @var{with-state} macro improves the performance of attribute access by batching related accesses in the minimum number of server requests. @defun drawable-border-width drawable @table @var @item drawable A @var{drawable} object. @end table Returns the @emph{border-width} of the @emph{drawable} in pixels. It always returns zero if the @emph{drawable} is a pixmap or an @var{:input-only} window. Used with @code{setf}, this function also changes the border width of the @var{:input-only} window. The default border width of a new window is zero. Changing just the border width leaves the outer left corner of a window in a fixed position but moves the absolute position of the window's origin. It is an error to make the border width of an @var{:input-only} window nonzero. When changing the border-width of a window, if the override-redirect attribute of the window is @var{:off} and some other client has selected @var{:substructure-redirect} on the parent, a @var{:configure-request} event is generated, and no further processing is performed. Otherwise, the border-width is changed. @table @var @item border-width Type @var{card16}. @end table @end defun @defun drawable-depth drawable @table @var @item drawable A @var{drawable} object. @end table Returns the depth of the specified @emph{drawable} (bits per pixel). @table @var @item depth Type @var{card8}. @end table @end defun @defun drawable-height drawable @table @var @item inside-height Type @var{card16}. @end table @end defun @defun drawable-width drawable @table @var @item drawable A @var{drawable} object. @end table These functions return the height or width of the @emph{drawable}. These coordinates define the inside size of the @emph{drawable}, in pixels. Used with @code{setf}, these functions also change the inside height or width of a window. However, the height or width of a pixmap cannot be changed. Changing the width and height resizes a window without changing its position or stacking priority. Changing the size of a mapped window may cause the window to lose its contents and generate an @var{:exposure} event. If a mapped window is made smaller, @var{:exposure} events are generated on windows that it formerly obscured. When changing the size of a window, if the override-redirect attribute of the window is @var{:off} and some other client has selected @var{:substructure-redirect} on the parent, a @var{:configure-request} event is generated, and no further processing is performed. Otherwise, if another client has selected @var{:resize-redirect} on the window, a @var{:resize-request} event is generated, and the current inside width and height are maintained. Note that the override-redirect attribute of the window has no effect on @var{:resize-redirect} and that @var{:substructure-redirect} on the parent has precedence over @var{:resize-redirect} on the window. When the inside size of the window is changed, the children of the window can move according to their window gravity. Depending on the window's bit gravity, the contents of the window can also be moved. @table @var @item inside-width Type @var{card16}. @end table @end defun @defun drawable-x drawable @table @var @item outside-left Type @var{int16}. @end table @end defun @defun drawable-y drawable @table @var @item drawable A @var{drawable} object. @end table These functions return the x or y coordinate of the specified @emph{drawable}. They always return zero if the @emph{drawable} is a pixmap. These coordinates define the location of the top left pixel of the window's border or of the window, if it has no border. Used with @code{setf}, these functions also change the x or y coordinate of a window. However, the x or y coordinate of a pixmap cannot be changed. Changing the x and y coordinates moves a window without changing its size or stacking priority. Moving a mapped window generates @var{:exposure} events on any formerly obscured windows. When changing the position of a window, if the override-redirect attribute of the window is @var{:off} and some other client has selected @var{:substructure-redirect} on the parent, a @var{:configure-request} event is generated, and no further processing is performed. Otherwise, the window is moved. @table @var @item outside-top Type @var{int16}. @end table @end defun @defun window-all-event-masks window @table @var @item window A @var{window}. @end table Returns the inclusive-or of the event masks selected on the specified @emph{window} by all clients. @table @var @item all-event-masks Type @var{mask32}. @end table @end defun @defun setf (window-background) window background @table @var @item window A @var{window}. @item background Either a @var{pixel}, a @var{pixmap}, @var{:none}, or @var{:parent-relative}. @end table Changes the @emph{background} attribute of the @emph{window} to the specified value. This operation is not allowed on an @var{:input-only} window. Changing the background does not cause the window contents to be changed. Note that the background of a window cannot be returned from the X server. The default background of a new window is @var{:none}. In general, the server automatically fills in exposed areas of the window when they are first made visible. A background pixmap is tiled to fill each area. However, if the background is @var{:none}, the server will not modify exposed areas. If the background is @var{:parent-relative}, the window and its parent must have the same depth. In this case, the window shares the same background as its parent. The parent's background is not copied and is reexamined whenever the window's background is required. If the background is @var{:parent-relative}, the background pixmap tile origin is the same as the parent's; otherwise, the tile origin is the window origin. @table @var @item background Either a @var{pixel}, a @var{pixmap}, @var{:none}, or @var{:parent-relative}. @end table @end defun @defun window-backing-pixel window @table @var @item window A @var{window}. @end table Returns and (with @code{setf}) changes the value of the backing-pixel attribute for the specified @emph{window}. Changing the backing-pixel attribute of a mapped window may have no immediate effect. The default backing-pixel of a new window is zero. @table @var @item backing-pixel Type @var{pixel}. @end table @end defun @defun window-backing-planes window @table @var @item window A @var{window}. @end table Returns and (with @code{setf}) changes the value of the backing-planes attribute for the specified @emph{window}. Changing the backing-planes attribute of a mapped window may have no immediate effect. The default backing-planes of a new window is all one's. @table @var @item backing-planes Type @var{pixel}. @end table @end defun @defun window-backing-store window @table @var @item window A @var{window}. @end table Returns and (with @code{setf}) changes the value of the backing-store attribute for the specified @emph{window}. Changing the backing-store attribute of an obscured window to @var{:when-mapped} or @var{:always} may have no immediate effect. The default backing-store of a new window is @var{:not-useful}. @table @var @item backing-store-type One of @var{:always}, @var{:not-useful}, or @var{:when-mapped}. @end table @end defun @defun window-bit-gravity window @table @var @item window A @var{window}. @end table Returns and (with @code{setf}) changes the bit-gravity attribute of the @emph{window}. If a window is reconfigured without changing its inside width or height, the contents of the window move with the window and are not lost. Otherwise, the contents of the resized window are either moved or lost, depending on its bit-gravity attribute. The default bit-gravity of a new window is @var{:forget}. For example, suppose a window's size is changed by @emph{W} pixels in width and @emph{H} pixels in height. The following table shows, for each bit-gravity value, the change in position (relative to the window origin) that results for each pixel of the window contents. @multitable {Bit-Gravity} {X Change} {Y Change} @item @var{:center} @tab @emph{W/}2 @tab @emph{H/}2 @item @var{:east} @tab @emph{W} @tab @emph{H/}2 @item @var{:north} @tab @emph{W/}2 @tab 0 @item @var{:north-east} @tab @emph{W} @tab 0 @item @var{:north-west} @tab 0 @tab 0 @item @var{:south} @tab @emph{W/}2 @tab @emph{H} @item @var{:south-east} @tab W @tab H @item @var{:south-west} @tab 0 @tab H @item @var{:west} @tab 0 @tab H/2 @end multitable A @var{:static} bit-gravity indicates the contents or window should not move relative to the origin of the root window. A server can choose to ignore the specified bit-gravity attribute and use @var{:forget} instead. A @var{:forget} bit-gravity attribute indicates that the window contents are always discarded after a size change, even if backing-store or save-under attributes are @var{:on}. The window's background is displayed (unless it is @var{:none}), and zero or more @var{:exposure} events are generated. @table @var @item bit-gravity Type @var{bit-gravity}. @end table @end defun @defun setf (window-border) window border @table @var @item window A @var{window}. @item border Either a @var{pixel}, a @var{pixmap}, or @var{:copy}. @end table Changes the @emph{border} attribute of the @emph{window} to the specified value. This operation is not allowed on an @var{:input-only} window. Changing the border attribute also causes the window border to be repainted. Note that the border of a window cannot be returned from the X server. The default border of a new window is @var{:copy}. A border pixmap is tiled to fill the border. The border pixmap tile origin is the same as the background tile origin. A border pixmap and the window must have the same root and depth. If the border is @var{:copy}, the parent's border is copied and used; subsequent changes to the parent's border do not affect the window border. @table @var @item border Either a @var{pixel}, a @var{pixmap}, or @var{:copy}. @end table @end defun @defun window-class window @table @var @item window A @var{window}. @end table Returns the @emph{class} of the specified @emph{window}. @table @var @item class Either @var{:input-output} or @var{:input-only}. @end table @end defun @defun window-colormap window @table @var @item window A @var{window}. @end table Returns and (with @code{setf}) changes the value of the colormap attribute for the specified @emph{window}. A value of @var{:copy} is never returned, since the parent's colormap attribute is actually copied, but the attribute can be set to @var{:copy} in a @code{setf} form. Changing the colormap of a window (defining a new map, not changing the contents of the existing map) generates a @var{:colormap-notify} event. Changing the colormap of a visible window may have no immediate effect on the screen (@pxref{install-colormap}). The default colormap of a new window is @var{:copy}. @table @var @item colormap Type @var{colormap} or @var{null}. @end table @end defun @defun window-colormap-installed-p window @table @var @item window A @var{window}. @end table Returns non-@var{nil} if the colormap associated with this @emph{window} is installed. Otherwise, this function returns @var{nil}. @table @var @item colormap-installed-p Type @var{boolean}. @end table @end defun @defun setf (window-cursor) window cursor @table @var @item window A @var{window}. @item cursor Either @var{cursor} or @var{:none}. @end table Changes the @emph{cursor} attribute of the @emph{window} to the specified value. Changing the cursor of a root window to @var{:none} restores the default cursor. Note that the cursor of window cannot be returned from the X server. The default cursor of a new window is @var{:none}. @table @var @item cursor Type @var{cursor} or @var{:none}. @end table @end defun @defun window-display window @table @var @item window A @var{window}. @end table Returns the @var{display} object associated with the specified @emph{window}. @table @var @item display Type @var{display}. @end table @end defun @defun window-do-not-propagate-mask window @table @var @item window A @var{window}. @end table Returns and (with @code{setf}) changes the do-not-propagate-mask attribute for the window. The default do-not-propagate-mask of a new window is zero. If a window receives an event from one of the user input devices, and if no client has selected to receive the event, the event can instead be propagated up the window hierarchy to the first ancestor for which some client has selected it. However, any event type selected by the do-not-propagate-mask is not be propagated. The types of events that can be selected by the do-not-propagate-mask are those of type @var{device-event-mask-class}. @xref{Selecting Events}. @table @var @item do-not-propagate-mask Type @var{mask32}. @end table @end defun @defun window-equal window-1 window-2 @table @var @item window-1 @itemx window-2 The windows to compare for equality. @end table Returns non-@var{nil} if the two arguments are the same window, and @var{nil} if they are not. @table @var @item equal-p Type @var{boolean}. @end table @end defun @defun window-event-mask window @table @var @item window A @var{window}. @end table Returns and (with @code{setf}) changes the value of the event-mask attribute for the @emph{window}. The default event-mask of a new window is zero. @table @var @item event-mask Type @var{mask32}. @end table @end defun @defun window-gravity window @table @var @item window A @var{window}. @end table Returns and (with @code{setf}) changes the gravity attribute of the @emph{window}. If a parent window is reconfigured without changing its inside width or height, then all child windows move with the parent and are not changed. Otherwise, each child of the resized parent is moved, depending on the child's gravity attribute. The default gravity of a new window is @var{:north-west}. For example, suppose the size of the window's parent is changed by @emph{W} pixels in width and @emph{H} pixels in height. The following table shows, for each possible gravity value, the resulting change in the window's position relative to its parent's origin. When the window is moved, two events are generated--a @var{:configure-notify} event followed by a @var{:gravity-notify} event. @multitable {Gravity} {X Change} {Y Change} @item @var{:center} @tab @emph{W/}2 @tab @emph{H/}2 @item @var{:east} @tab @emph{W} @tab @emph{H/}2 @item @var{:north} @tab @emph{W/}2 @tab 0 @item @var{:north-east} @tab @emph{W} @tab 0 @item @var{:north-west} @tab 0 @tab 0 @item @var{:south} @tab @emph{W/}2 @tab @emph{H} @item @var{:south-east} @tab W @tab H @item @var{:south-west} @tab 0 @tab H @item @var{:west} @tab 0 @tab H/2 @end multitable A @var{:static} gravity indicates that the position of the window should not move relative to the origin of the root window. An @var{:unmap} gravity is like @var{:north-west}, except the window is also unmapped and an @var{:unmap-notify} event is generated. This @var{:unmap-notify} event is generated after the @var{:configure-notify} event is generated for the parent. @table @var @item gravity Type @var{win-gravity}. @end table @end defun @defun window-id window @table @var @item window A @var{window}. @end table Returns the unique ID assigned to @emph{window}. @table @var @item id Type @var{resource-id}. @end table @end defun @defun window-map-state window @table @var @item window A @var{window}. @end table Returns the map state of @emph{window}. A window is @var{:unviewable} if it is mapped but some ancestor is unmapped. @table @var @item map-state One of @var{:unmapped}, @var{:unviewable}, or @var{:viewable}. @end table @end defun @defun window-override-redirect window @table @var @item window A @var{window}. @end table Returns and (with @code{setf}) changes the value of the override-redirect attribute for @emph{window}. The default override-redirect of a new window is @var{:off}. The override-redirect attribute determines whether or not attempts to change window geometry or parent hierarchy can be @emph{redirected} by a window manager or some other client. The functions that might be affected by the override-redirect attribute are @var{circulate-window-down}, @var{circulate-window-up}, @var{drawable-border-width}, @var{drawable-height}, @var{drawable-width}, @var{drawable-x}, @var{drawable-y}, @var{map-window}, and @var{window-priority}. @table @var @item override-redirect Either @var{:on} or @var{:off}. @end table @end defun @defun window-p object @table @var @item window-p Type @var{boolean}. @end table Returns non-@var{nil} if the @emph{object} argument is a window; otherwise, it returns @var{nil}. @end defun @defun window-plist window @table @var @item window A @var{window}. @end table Returns and (with @code{setf}) sets the property list for the specified @emph{window}. This function provides a hook where extensions can hang data. @table @var @item plist A property list. @end table @end defun @defun setf (window-priority window) (&optional sibling) mode @table @var @item window A @var{window}. @item sibling An optional argument specifying that @emph{window} is to be restacked relative to this sibling @var{window}. @item mode One of @var{:above}, @var{:below}, @var{:bottom-if}, @var{:opposite}, or @var{:top-if}. @end table Changes the stacking priority element of the @emph{window} to the specified value. It is an error if the @emph{sibling} argument is specified and is not actually a sibling of the window. Note that the priority of an existing window cannot be returned from the X server. When changing the priority of a window, if the override-redirect attribute of the window is @var{:off} and some other client has selected :substructure-redirect on the parent, a :configure-request event is generated, and no further processing is performed. Otherwise, the priority is changed. @table @var @item mode One of @var{:above}, @var{:below}, @var{:bottom-if}, @var{:opposite}, or @var{:top-if}. @end table @end defun @defun window-save-under window @table @var @item window A @var{window}. @end table Returns and (with @code{setf}) changes the value of the save-under attribute for the specified @emph{window}. Changing the save-under attribute of a mapped window may have no immediate effect. @table @var @item save-under Either @var{:on} or @var{:off}. @end table @end defun @defun window-visual window @table @var @item window A @var{window}. @end table Returns the @emph{visual-type} associated with the specified @emph{window}. @table @var @item visual-type Type @var{card29}. @end table @end defun @defmac with-state drawable &body body @anchor{with-state} Batches successive read and write accesses to window attributes and drawable geometry, in order to minimize the number of requests sent to the server. Batching occurs automatically within the dynamic extent of the @emph{body}. The @emph{body} is not executed within a @var{with-display} form. All window attributes can be returned or changed in a single request. Similarly, all drawable geometry values can be returned or changed in a single request. @var{with-state} combines accesses to these values into the minimum number of server requests necessary to guarantee that each read access returns the current server state of the @emph{drawable}. The number of server requests sent depends on the sequence of calls to reader and @code{setf} functions within the dynamic extent of the @emph{body}. There are two groups of reader and @code{setf} functions--the Window Attributes group and the Drawable Geometry group--as shown in Table 4-1. @multitable {Group} {Reader Functions} {Setf Functions} @item Window Attributes @tab @var{window-all-event-masks} @tab @var{window-background} @item @tab @var{window-backing-pixel} @tab @var{window-backing-pixel} @item @tab @var{window-backing-planes} @tab @var{window-backing-planes} @item @tab @var{window-backing-store} @tab @var{window-backing-store} @item @tab @var{window-bit-gravity} @tab @var{window-bit-gravity} @item @tab @var{window-class} @tab @var{window-border} @item @tab @var{window-colormap} @tab @var{window-colormap} @item @tab @var{window-colormap-installed-p} @tab @var{window-cursor} @item @tab @var{window-do-not-propagate-mask} @tab @var{window-do-not-propagate-mask} @item @tab @var{window-event-mask} @tab @var{window-event-mask} @item @tab @var{window-gravity} @tab @var{window-gravity} @item @tab @var{window-map-state} @tab @item @tab @var{window-override-redirect} @tab @var{window-override-redirect} @item @tab @var{window-save-under} @tab @var{window-save-under} @item @tab @var{window-visual} @tab @item Drawable Geometry @tab @var{drawable-border-width} @tab @var{drawable-border-width} @item @tab @var{drawable-depth} @tab @var{drawable-height} @item @tab @var{drawable-height} @tab @var{drawable-width} @item @tab @var{drawable-root} @tab @var{drawable-x} @item @tab @var{drawable-width} @tab @var{drawable-y} @item @tab @var{drawable-x} @tab @var{window-priority} @item @tab @var{drawable-y} @tab @end multitable The results from a sequence of calls to @code{setf} functions in a given group are cached and sent in a single server request, either upon exit from the @emph{body} or when a reader function from the corresponding group is called. @var{with-state} sends a single request to update all its cached values for the @emph{drawable} before the first call to a reader function within the @emph{body} and also before the first call to a reader function following a sequence of calls to @code{setf} functions from the corresponding group. @table @var @item drawable A @var{display}. @item body The forms in which attributes accesses are batched. @end table @end defmac @node Stacking Order, Window Hierarchy, Window Attributes, Windows and Pixmaps @section Stacking Order Sibling windows can @emph{stack} on top of each other. Windows above can @emph{obscure} or @emph{occlude} lower windows. This relationship between sibling windows is known as the stacking order. The @var{window-priority} function can be used to change the stacking order of a single window. CLX also provides functions to raise or lower children of a window. Raising a mapped window can generate @var{:exposure} events for the window and any mapped subwindows that were formerly obscured. Lowering a mapped window can generate @var{:exposure} events on any windows it formerly obscured. @defun circulate-window-down window @table @var @item window A @var{window}. @end table Lowers the highest mapped child of the specified @emph{window} that partially or completely occludes another child to the bottom of the stack. Completely unobscured children are unaffected. Exposure processing is performed on formerly obscured windows. If some other client has selected @var{:substructure-redirect} on the @emph{window}, a @var{:circulate-request} event is generated, and no further processing is performed. Otherwise, the child window is lowered and a @var{:circulate-notify} event is generated if the @emph{window} is actually restacked. @end defun @defun circulate-window-up window @table @var @item window A @var{window}. @end table Raises the lowest mapped child of the specified @emph{window} that is partially or completely occluded by another child to the top of the stack. Completely unobscured children are unaffected. Exposure processing is performed on formerly obscured windows. If another client has selected @var{:substructure-redirect} on the @emph{window}, a @var{:circulate-request} event is generated, and no further processing is performed. Otherwise, the child window is raised and a @var{:circulate-notify} event is generated if the @emph{window} is actually restacked. @end defun @node Window Hierarchy, Mapping Windows, Stacking Order, Windows and Pixmaps @section Window Hierarchy All the windows in X are arranged in a strict hierarchy. At the top of the hierarchy are the root windows, which cover the display screens. Each root window is partially or completely covered by its child windows. All windows, except for root windows, have parents. Child windows can have their own children. In this way, a tree of arbitrary depth on each screen can be created. CLX provides several functions for examining and modifying the window hierarchy. @defun drawable-root drawable @table @var @item drawable A @var{drawable}. @end table Returns the root window of the specified @emph{drawable}. @table @var @item root-window Type @var{window}. @end table @end defun @defun query-tree window &key (:result-type `list) @table @var @item window A @var{window}. @item :result-type A valid type specifier for a sub-type of @var{sequence}. The default is a @var{list}. @end table Returns the @emph{children} windows, the @emph{parent} window, and the @emph{root} window for the specified @emph{window}. The children are returned as a sequence of windows in current stacking order, from bottom-most (first) to top-most (last). The @var{:result-type} specifies the type of children sequence returned. @table @var @item children Type @var{sequence} of @var{window}. @item parent Type @var{window} or @var{null}. @item root Type @var{window}. @end table @end defun @defun reparent-window window parent x y @table @var @item window A @var{window}. @item parent The new parent @var{window}. @item x @itemx y The position (type @var{int16}) of the @emph{window} in its new @emph{parent}. These coordinates are relative to the @emph{parent}'s origin, and specify the new position of the upper, left, outer corner of the @emph{window}. @end table Changes a @emph{window}'s @emph{parent} within a single screen. There is no way to move a window between screens. The specified @emph{window} is reparented by inserting it as a child of the specified @emph{parent}. If the @emph{window} is mapped, an @var{unmap-window} operation is automatically performed on the specified @emph{window}. The @emph{window} is then removed from its current position in the hierarchy and inserted as the child of the specified @emph{parent}. The @emph{window} is placed on top in the stacking order with respect to sibling windows. After reparenting the specified @emph{window,} a @var{:reparent-notify} event is generated. The override-redirect attribute of the @emph{window} is passed on in this event. Window manager clients normally should ignore this event if this attribute is @var{:on}. @xref{Events and Input}, for more information on @var{:reparent-notify} event processing. Finally, if the specified @emph{window} was originally mapped, a @var{map-window} operation is automatically performed on it. The X server performs normal exposure processing on formerly obscured windows. It might not generate @var{:exposure} events for regions from the initial @var{unmap-window} operation if they are immediately obscured by the final @var{map-window} operation. It is an error if any of the following are true: @itemize @bullet @item The new @emph{parent} window is not on the same screen as the old parent window. @item The new @emph{parent} window is the specified @emph{window} or an inferior of the specified @emph{window}. @item The specified @emph{window} has a @var{:parent-relative} background attribute and the new @emph{parent} window is not the same depth as the specified @emph{window}. @end itemize @end defun @defun translate-coordinates source source-x source-y destination @table @var @item source A @var{window} defining the source coordinate system. @item source-x @itemx source-y Coordinates (@var{int16}) relative to the origin of the @emph{source} @var{window}. @item destination A @var{window} defining the destination coordinate system. @end table Returns the position defined by @emph{source-x} and @emph{source-y} (relative to the origin of the @emph{source} window), expressed as coordinates relative to the origin of the @emph{destination} window. @table @var @item destination-x Type @var{int16} or @var{null}. @item destination-y Type @var{int16} or @var{null}. @item destination-child Type @var{window} or @var{null}. @end table @end defun @node Mapping Windows, Destroying Windows, Window Hierarchy, Windows and Pixmaps @section Mapping Windows A window is considered mapped if a @var{map-window} call has been made on it. When windows are first created, they are not mapped because an application may wish to create a window long before it is mapped to the screen. A mapped window may not be visible on the screen for one of the following reasons: @itemize @bullet @item It is obscured by another opaque sibling window. @item One of its ancestors is not mapped. @item It is entirely clipped by an ancestor. @end itemize A subwindow will appear on the screen as long as all of its ancestors are mapped and not obscured by a sibling or clipped by an ancestor. Mapping a window that has an unmapped ancestor does not display the window, but marks it as eligible for display when the ancestor becomes mapped. Such a window is called unviewable. When all its ancestors are mapped, the window becomes viewable and remains visible on the screen if not obscured by any sibling or ancestor. Any output to a window not visible on the screen is discarded. @var{:exposure} events are generated for the window when part or all of it becomes visible on the screen. A client only receives the @var{:exposure} events if it has selected them. Mapping or unmapping a window does not change its stacking order priority. @defun map-window window @table @var @item window A @var{window}. @end table @anchor{map-window} Maps the @emph{window}. This function has no effect when the @emph{window} is already mapped. If the override-redirect attribute of the @emph{window} is @var{:off} and another client has selected @var{:substructure-redirect} on the parent window, the X server generates a @var{:map-request} event and the @var{map-window} function does not map the @emph{window}. Otherwise, the @emph{window} is mapped, and the X server generates a @var{:map-notify} event. If the @emph{window} becomes visible and no earlier contents for it are remembered, @var{map-window} tiles the window with its background. If no background was defined for the window, the existing screen contents are not altered, and the X server generates one or more @var{:exposure} events. If a backing-store was maintained while the window was unmapped, no @var{:exposure} events are generated. If a backing-store will now be maintained, a full window exposure is always generated. Otherwise, only visible regions may be reported. Similar tiling and exposure take place for any newly viewable inferiors. @var{map-window} generates @var{:exposure} events on each @var{:input-output} window that it causes to become visible. @end defun @defun map-subwindows window @table @var @item window A @var{window}. @end table Maps all child windows for a specified @emph{window} in top-to-bottom stacking order. The X server generates an @var{:exposure} event on each newly visible window. This function is much more efficient than mapping each child individually. @end defun @defun unmap-window window @table @var @item window A @var{window}. @end table Unmaps the specified @emph{window} and causes the X server to generate an @var{:unmap-notify} event. If the specified @emph{window} is already unmapped, @var{unmap-window} has no effect. Normal exposure processing on formerly obscured windows is performed. Any child window is no longer viewable. Unmapping the @emph{window} generates @var{:exposure} events on windows that were formerly obscured by @emph{window} and its children. @end defun @defun unmap-subwindows window @table @var @item window A @var{window}. @end table Unmaps all child windows for the specified @emph{window} in bottom to top stacking order. The X server generates an @var{:unmap-notify} event on each child and @var{:exposure} events on formerly obscured windows. Using this function is much more efficient than unmapping child windows individually. @end defun @node Destroying Windows, Pixmaps, Mapping Windows, Windows and Pixmaps @section Destroying Windows CLX provides functions to destroy a window or destroy all children of a window. Note that by default, windows are destroyed when a connection is closed. For further information, @xref{Closing the Display}, and @xref{Client Termination}. @defun destroy-window window @table @var @item window A @var{window}. @end table Destroys the specified @emph{window} as well as all of its inferiors. The windows should never again be referenced. If the specified @emph{window} is mapped, it is automatically unmapped. The window and all of its inferiors are then destroyed, and a @var{:destroy-notify} event is generated for each window. The ordering of the @var{:destroy-notify} events is such that for any given window being destroyed, @var{:destroy-notify} is generated on the window's inferiors before being generated on the window. The ordering among siblings and across sub-hierarchies is not otherwise constrained. If the @emph{window} is a root window, no windows are destroyed. Destroying a mapped window generates @var{:exposure} events on other windows that the mapped window obscured. @end defun @defun destroy-subwindows window @table @var @item window A @var{window}. @end table Destroys all inferiors of the specified @emph{window}, in bottom to top stacking order. The X server generates a @var{:destroy-notify} event for each window. This is much more efficient than deleting many windows individually. The inferiors should never be referenced again. @end defun @node Pixmaps, , Destroying Windows, Windows and Pixmaps @section Pixmaps A @emph{pixmap} is a three-dimensional array of bits. A pixmap is normally thought of as a two-dimensional array of pixels, where each pixel can be a value from 0 to 2@emph{n}-1, where @emph{n} is the depth of the pixmap. A pixmap can also be thought of as a stack of @emph{n} bitmaps. A @emph{bitmap} is a single bit pixmap of depth 1. CLX provides functions to: @itemize @bullet @item Create or free a pixmap @item Test if an object is a pixmap @item Test if two pixmap objects are equal @item Return the pixmap resource ID from a @var{pixmap} object @end itemize Note that pixmaps can only be used on the screen where they were created. Pixmaps are off-screen server resources that are used for a number of operations. These include defining patterns for cursors or as the source for certain raster operations. @defun create-pixmap &key :width :height :depth :drawable @table @var @item :width @itemx :height The nonzero width and height (type @var{card16}). @item :depth The depth (type @var{card8}) of the pixmap. @item :drawable A @var{drawable} which determines the screen where the pixmap will be used. @end table Creates a pixmap of the specified @var{:width}, @var{:height}, and @var{:depth}. It is valid to pass a window whose class is @var{:input-only} as the @var{:drawable} argument. The @var{:width} and @var{:height} arguments must be nonzero. The @var{:depth} must be supported by the screen of the specified @var{:drawable}. @table @var @item pixmap Type @var{pixmap}. @end table @end defun @defun free-pixmap pixmap @table @var @item pixmap A @var{pixmap}. @end table Allows the X server to free the pixmap storage when no other server resources reference it. The pixmap should never be referenced again. @end defun @defun pixmap-display pixmap @table @var @item pixmap A @var{pixmap}. @end table Returns the @var{display} object associated with the specified @emph{pixmap}. @table @var @item display Type @var{display}. @end table @end defun @defun pixmap-equal pixmap-1 pixmap-2 @table @var @item pixmap-1 @itemx pixmap-2 A three-dimensional array of bits to be tested. @end table Returns true if the two arguments refer to the same server resource, and @var{nil} if they do not. @end defun @defun pixmap-id pixmap @table @var @item pixmap A @var{pixmap}. @end table Returns the unique resource ID that has been assigned to the specified @emph{pixmap}. @table @var @item id Type @var{resource-id}. @end table @end defun @defun pixmap-p object @table @var @item pixmap Type @var{boolean}. @end table Returns true if the argument is a @var{pixmap} object and @var{nil} otherwise. @end defun @defun pixmap-plist pixmap @table @var @item pixmap A @var{pixmap}. @end table Returns and (with @code{setf}) sets the property list for the specified @emph{pixmap}. This function provides a hook where extensions can add data. @table @var @item plist A property list. @end table @end defun @node Graphics Contexts, Graphic Operations, Windows and Pixmaps, Top @chapter Graphics Contexts Clients of the X Window System specify the visual attributes of graphical output primitives by using @emph{graphics contexts}. A graphics context is a set of graphical attribute values such as foreground color, font, line style, and so forth. Like a window, a graphics context is another kind of X server resource which is created and maintained at the request of a client program. The client program, which may use several different graphics contexts at different times, is responsible for specifying a graphics context to use with each graphical output function. CLX represents a graphics context by an object of type @var{gcontext} and defines functions to create, modify, and manipulate @var{gcontext} objects. By default, CLX also records the contents of graphics contexts in a cache associated with each display. This local caching of graphics contexts has two important advantages: @enumerate @item Communication efficiency -- Changes to attribute values in a @var{gcontext} are first made only in the local cache. Just before a @var{gcontext} is actually used, CLX automatically sends any changes to the X server, batching all changes into a single request. @item Inquiring @var{gcontext} contents -- Accessor functions can be used to return the value of any individual @var{gcontext} component by reading the copy of the @var{gcontext} from the cache. This kind of inquiry is not supported by the basic X protocol. There is no way for a client program to request an X server to return the contents of a @var{gcontext}. @end enumerate Caching graphics contexts can result in a synchronization problem if more than one client program modifies a graphics context. However, this problem is unusual. Sharing a graphics context among several clients, while possible, is not expected to be useful and is not very easy to do. At any rate, a client program can choose to not cache a @var{gcontext} when it is created. Each client program must determine its own policy for creating and using graphics contexts. Depending on the display hardware and the server implementation, creating a new graphics context can be more or less expensive than modifying an existing one. In general, some amount of graphics context information can be cached in the display hardware, in which case modifying the hardware cache is faster than replacing it. Typical display hardware can cache only a small number of graphics contexts. Graphics output is fastest when only a few graphics contexts are used without heavy modifications. This section explains the CLX functions used to: @itemize @bullet @item Create a graphics context @item Return the contents of a graphics context @item Change the contents of a graphics context @item Copy a graphics context @item Free a graphics context @end itemize @menu * Creating Graphics Contexts:: * Graphics Context Attributes:: * Copying Graphics Contexts:: * Destroying Graphics Contexts:: * Graphics Context Cache:: @end menu @node Creating Graphics Contexts, Graphics Context Attributes, Graphics Contexts, Graphics Contexts @section Creating Graphics Contexts To create a graphics context, use @var{create-gcontext}. @defun create-gcontext &key :arc-mode :background (:cache-p t) :cap-style :clip-mask :clip-ordering :clip-x :clip-y :dash-offset :dashes :drawable :exposures :fill-rule :fill-style :font :foreground :function :join-style :line-style :line-width :plane-mask :stipple :subwindow-mode :tile :ts-x :ts-y @table @var @item :cache-p Specifies if this graphics context should be cached locally by CLX. If @var{nil} then the state is not cached, otherwise a local cache is kept. @item :drawable The @var{drawable} whose root and depth are to be associated with this graphics context. This is a required keyword argument. @item :arc-mode @itemx :background @itemx :cap-style @itemx :clip-mask @itemx :clip-ordering @itemx :clip-x @itemx :clip-y @itemx :dash-offset @itemx :dashes @itemx :exposures @itemx :fill-rule @itemx :fill-style @itemx :font @itemx :foreground @itemx :function @itemx :join-style @itemx :line-style @itemx :line-width @itemx :plane-mask @itemx :stipple @itemx :subwindow-mode @itemx :tile @itemx :ts-x @itemx :ts-y Initial attribute values for the graphics context. @end table Creates, initializes, and returns a graphics context (@var{gcontext}). The graphics context can only be used with destination drawables having the same root and depth as the specified @var{:drawable}. If @var{:cache-p} is non-@var{nil}, the graphics context state is cached locally, and changing a component has no effect unless the new value differs from the cached value. Changes to a graphics context (@code{setf} and @var{with-gcontext}) are always deferred regardless of the cache mode and sent to the server only when required by a local operation or by an explicit call to @var{force-gcontext-changes}. All of the graphics context components are set to the values that are specified by the keyword arguments, except that a value of @var{nil} causes the default value to be used. These default values are as follows: @multitable {Component} {Default Value} @item @var{arc-mode} @tab @var{:pie-slice} @item @var{background} @tab 1 @item @var{cap-style} @tab @var{:butt} @item @var{clip-mask} @tab @var{:none} @item @var{clip-ordering} @tab @var{:unsorted} @item @var{clip-x} @tab 0 @item @var{clip-y} @tab 0 @item @var{dash-offset} @tab 0 @item @var{dashes} @tab 4 (that is, the list '(4, 4)) @item @var{exposures} @tab @var{:on} @item @var{fill-rule} @tab @var{:even-odd} @item @var{fill-style} @tab @var{:solid} @item @var{font} @tab server dependent @item @var{foreground} @tab 0 @item @var{function} @tab @var{boole-1} @item @var{join-style} @tab @var{:miter} @item @var{line-style} @tab @var{:solid} @item @var{line-width} @tab 0 @item @var{plane-mask} @tab A bit mask of all ones @item @var{stipple} @tab Pixmap of unspecified size filled with ones @item @var{subwindow-mode} @tab @var{:clip-by-children} @item @var{tile} @tab Pixmap of an unspecified size filled with the foreground pixel (that is, the client-specified pixel if any, or else 0) @item @var{ts-x} @tab 0 @item @var{ts-y} @tab 0 @end multitable Note that foreground and background do not default to any values that are likely to be useful on a color display. Since specifying a @var{nil} value means use the default, this implies for clip-mask that an empty rectangle sequence cannot be specified as an empty list; @var{:none} must be used instead. Specifying a @var{stringable} for font causes an implicit @var{open-font} call to occur. @table @var @item gcontext Type @var{gcontext}. @end table @end defun @node Graphics Context Attributes, Copying Graphics Contexts, Creating Graphics Contexts, Graphics Contexts @section Graphics Context Attributes The following paragraphs describe the CLX functions used to return or change the attributes of a @var{gcontext}. Functions that return the contents of a @var{gcontext} return @var{nil} if the last value stored is unknown (for example, if the @var{gcontext} was not cached or if the @var{gcontext} was not created by the inquiring client). @defun gcontext-arc-mode gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns and (with @code{setf}) changes the arc-mode attribute of the specified graphics context. The arc-mode attribute of a graphics context controls the kind of filling, if any, to be done by the @var{draw-arcs} function. A value of @var{:chord} specifies that arcs are filled inward to the chord between the end points of the arc. @var{:pie-slice} specifies that arcs are filled inward to the center point of the arc, creating a pie slice effect. @table @var @item arc-mode Either @var{:chord} or @var{:pie-slice}. @end table @end defun @defun gcontext-background gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns and (with @code{setf}) changes the background attribute of the specified graphics context. The background attribute specifies the pixel value drawn for pixels that are not set in a bitmap and for pixels that are cleared by a graphics operation, such as the gaps in dashed lines. @table @var @item background Type @var{card32}. @end table @end defun @defun gcontext-cache-p gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns and (with @code{setf}) changes the local cache mode for the @emph{gcontext}. If true, the state of the @emph{gcontext} is cached by CLX and changes to its attributes have no effect unless the new value differs from its cached value. @table @var @item cache-p Type @var{boolean}. @end table @defun gcontext-cap-style gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns and (with @code{setf}) changes the cap-style attribute of the specified graphics context. The cap-style attribute of a graphics context defines how the end points of a path are drawn. The possible values and their interpretations are as follows: @multitable {Cap-Style} {Interpretations} @item @var{:butt} @tab Square at the end point (perpendicular to the slope of the line) with no projection beyond. @item @var{:not-last} @tab Equivalent to @var{:butt}, except that for a line-width of zero or one the final end point is not drawn. @item @var{:projecting} @tab Square at the end, but the path continues beyond the end point for a distance equal to half the line-width. This is equivalent to @var{:butt} for line-width zero or one. @item @var{:round} @tab A circular arc with the radius equal to 1/2 of the line-width, centered on the end point. This is equivalent to @var{:butt} for line-width zero or one. @end multitable The following table describes what happens when the end points of a line are identical. The effect depends on both the cap style and line width. @multitable {Cap-Style} {Line-Width} {Effect} @item @var{:butt} @tab thin @tab Device dependent, but the desired effect is that a single pixel is drawn. @item @var{:butt} @tab wide @tab Nothing is drawn. @item @var{:not-last} @tab thin @tab Device dependent, but the desired effect is that nothing is drawn. @item @var{:projecting} @tab thin @tab Same as @var{:butt} with thin line-width. @item @var{:projecting} @tab wide @tab The closed path is a square, aligned with the coordinate axes, centered at the end point, with sides equal to the line-width. @item @var{:round} @tab wide @tab The closed path is a circle, centered at the end point, with diameter equal to the line-width. @item @var{:round} @tab thin @tab Same as @var{:butt} with thin line-width. @end multitable @table @var @item cap-style One of @var{:butt}, @var{:not-last}, @var{:projecting}, or @var{:round}. @end table @end defun @defun gcontext-clip-mask gcontext &optional ordering @table @var @item gcontext A @var{gcontext}. @item ordering One of @var{:unsorted}, @var{:y-sorted}, @var{:yx-banded}, @var{:yx-sorted}, or @var{nil}. @end table Returns and (with @code{setf}) changes the clip-mask attribute of the graphics context. When changing the clip-mask attribute, the new clip-mask can be specified as a pixmap or a @var{rect-seq} or as the values @var{:none} or @var{nil}. The ordering argument can be specified only with @code{setf} when the new clip-mask is a @var{rect-seq}. The clip-mask attribute of a graphics context affects all graphics operations and is used to restrict output to the destination drawable. The clip-mask does not clip the source of a graphics operation. A value of @var{:none} for clip-mask indicates that no clipping is to be done. If a pixmap is specified as the clip-mask, it must have depth one and the same root as the specified graphics context. Pixels where the clip-mask has a one bit are drawn. Pixels outside the area covered by the clip-mask or where the clip-mask has a zero bit are not drawn. If a sequence of rectangles is specified as the clip-mask, the output is clipped to remain contained within the rectangles. The rectangles should be non-intersecting, or the results of graphics operations will be undefined. The rectangle coordinates are interpreted relative to the clip origin. Note that the sequence of rectangles can be empty, which effectively disables output. This is the opposite of setting the clip-mask to @var{:none}. If known by the client, the ordering of clip-mask rectangles can be specified to provide faster operation by the server. A value of @var{:unsorted} means the rectangles are in arbitrary order. A value of @var{:y-sorted} means that the rectangles are non-decreasing in their Y origin. A @var{:yx-sorted} value is like @var{:y-sorted} with the additional constraint that all rectangles with an equal Y origin are non-decreasing in their X origin. A @var{:yx-banded} value additionally constrains @var{:yx-sorted} by requiring that, for every possible Y scan line, all rectangles that include that scan line have an identical Y origins and Y extents. If incorrect ordering is specified, the X server may generate an error, but it is not required to do so. If no error is generated, the results of the graphics operations are undefined. @end defun @defun gcontext-clip-x gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns and (with @code{setf}) changes the clip-x attribute of the specified graphics context. The clip-x and clip-y attributes specify the origin for the clip-mask, whether it is a pixmap or a sequence of rectangles. These coordinates are interpreted relative to the origin of whatever destination drawable is specified in a graphics operation. @table @var @item clip-x Type @var{int16}. @end table @end defun @defun gcontext-clip-y gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns and (with @code{setf}) changes the clip-y attribute of the specified graphics context. The clip-x and clip-y attributes specify the origin for the clip-mask, whether it is a pixmap or a sequence of rectangles. These coordinates are interpreted relative to the origin of whatever destination drawable is specified in a graphics operation. @table @var @item clip-y Type @var{int16}. @end table @end defun @defun gcontext-dash-offset gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns and (with @code{setf}) changes the dash-offset attribute of the specified graphics context. The dash-offset attribute of a graphics context defines the phase of the pattern contained in the dashes attribute. This phase specifies how many elements (pixels) into the path the pattern should actually begin in any single graphics operation. Dashing is continuous through path elements combined with a join-style, but is reset to the dash-offset each time a cap-style is applied at a line end point. @table @var @item dash-offset Type @var{card16}. @end table @end defun @defun gcontext-dashes gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns and (with @code{setf}) changes the dashes attribute of the specified graphics context. The sequence must be non-empty and the elements must be non-zero @var{card8} values. The dashes attribute in a graphics context specifies the pattern that is used for graphics operations which use the dashed line styles. It is a non-@var{nil} sequence with each element representing the length of a single dash or space. The initial and alternating elements of the dashes are the even dashes, while the others are the odd dashes. An odd length sequence is equivalent to the same sequence concatenated with itself to produce an even length sequence. All of the elements of a dashes sequence must be non-zero. Specifying a single integer value, @emph{N}, for the dashes attribute is an abbreviated way of specifying a two element sequence with both elements equal to the specified value [@emph{N}, @emph{N}]. The unit of measure for dashes is the same as in the ordinary coordinate system. Ideally, a dash length is measured along the slope of the line, but server implementations are only required to match this ideal for horizontal and vertical lines. @table @var @item dashes Type @var{sequence} or @var{card8}. @end table @end defun @defun gcontext-display gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns the @var{display} object associated with the specified @emph{gcontext}. @table @var @item display Type @var{display}. @end table @end defun @defun gcontext-equal gcontext-1 gcontext-2 @table @var @item gcontext-1 @itemx gcontext-2 A @var{gcontext}. @end table Returns true if the two arguments refer to the same server resource, and @var{nil} if they do not. @table @var @item equal-p Type @var{boolean}. @end table @end defun @defun gcontext-exposures gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns and (with @code{setf}) changes the exposures attribute of the specified graphics context. The exposures attribute in a graphics context controls the generation of @var{:graphics-exposure} events for calls to the @var{copy-area} and @var{copy-plane} functions. If @var{:on}, @var{:graphics-exposure} events will be reported when calling the @var{copy-area} and @var{copy-plane} functions with this graphics context. Otherwise, if @var{:off}, the events will not be reported. @table @var @item exposures Either @var{:off} or @var{:on}. @end table @end defun @defun gcontext-fill-rule gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns and (with @code{setf}) changes the fill-rule attribute of the specified graphics context. The fill-rule attribute in a graphics context specifies the rule used to determine the interior of a filled area. It can be specified as either @var{:even-odd} or @var{:winding}. The @var{:even-odd} rule defines a point to be inside if any infinite ray starting at the point crosses the border an odd number of times. Tangencies do not count as a crossing. The @var{:winding} rule defines a point to be inside if any infinite ray starting at the point crosses an unequal number of clockwise and counterclockwise directed border segments. A clockwise directed border segment crosses the ray from left to right as observed from the point. A counterclockwise segment crosses the ray from right to left as observed from the point. The case where a directed line segment is coincident with the ray is uninteresting because you can simply choose a different ray that is not coincident with a segment. For both @var{:even-odd} and @var{:winding}, a point is infinitely small, and the border is an infinitely thin line. A pixel is inside if the center point of the pixel is inside, and the center point is not on the border. If the center point is on the border, the pixel is inside if, and only if, the polygon interior is immediately to its right (x increasing direction). Pixels with centers along a horizontal edge are a special case and are inside if, and only if, the polygon interior is immediately below (y increasing direction). @table @var @item fill-rule Either @var{:even-odd} or @var{:winding}. @end table @end defun @defun gcontext-fill-style gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns and (with @code{setf}) changes the fill-style attribute of the specified graphics context. The fill-style attribute of a graphics context defines the contents of the source for line, text, and fill graphics operations. It determines whether the source image is drawn with a solid color, a tile, or a stippled tile. The possible values and their meanings are as follows: @table @var @item :opaque-stippled Filled with a tile with the same width and height as stipple, but with the background value used everywhere stipple has a zero and the foreground pixel value used everywhere stipple has a one. @item :solid Filled with the foreground pixel value. @item :stippled Filled with the foreground pixel value masked by stipple. @item :tiled Filled with tile. @end table When drawing lines with line-style @var{:double-dash}, the filling of the odd dashes are controlled by the fill-style in the following manner: @table @var @item :opaque-stippled Same as for even dashes. @item :solid Filled with the background pixel value. @item :stippled Filled with the background pixel value masked by stipple. @item :tiled Filled the same as the even dashes. @end table @table @var @item fill-style One of @var{:opaque-stippled}, @var{:solid}, @var{:stippled}, or @var{:tiled}. @end table @end defun @defun gcontext-font gcontext &optional metrics-p @table @var @item gcontext A @var{gcontext}. @item metrics-p Specifies whether a pseudo-font is returned when the real font stored in the graphics context is not known. The default is @var{nil}, which means do not return a pseudo-font. @end table Returns and (with @code{setf}) changes the @emph{font} attribute of the specified graphics context. If the stored font is known, it is returned. If it is not known and the @emph{metrics-p} argument is @var{nil}, then @var{nil} is returned. If the font is not known and @emph{metrics-p} is true, then a pseudo-font is constructed and returned. For a constructed pseudo-font, full metric and property information can be obtained, but it does not have a name or a resource ID, and attempts to use it where a resource ID is required results in an invalid-font error. The font attribute in a graphics context defines the default text font used in text drawing operations. When setting the value of the font attribute, either a @var{font} object or a font name can be used. If a font name is passed, @var{open-font} is call automatically to get the @var{font} object. @table @var @item font Type @var{font} or @var{null}. @end table @end defun @end defun @defun gcontext-foreground gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns and (with @code{setf}) changes the foreground attribute of the specified graphics context. The foreground attribute of a graphics context specifies the pixel value drawn for set bits in a bitmap and for bits set by a graphics operation. @table @var @item foreground Type @var{card32}. @end table @end defun @defun gcontext-function gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns the @emph{function} of the specified graphics context. In all graphic operations, given a source pixel and a corresponding destination pixel, the resulting pixel drawn is computed bitwise on the bits of the source and destination pixels. That is, a logical operation is used to combine each bit plane of corresponding source and destination pixels. The graphics context function attribute specifies the logical operation used via one of the 16 operation codes defined by Common Lisp for the @var{boole} function. The following table shows each of the logical operation codes that can be given by the function attribute. For each operation code, its result is shown as a logical function of a source pixel @emph{S} and a destination pixel @emph{D}. @multitable {Symbol} {Result} @item @var{boole-1} @tab @emph{S} @item @var{boole-2} @tab @emph{D} @item @var{boole-andc1} @tab (logandc1 @emph{S D}) @item @var{boole-andc2} @tab (logandc2 @emph{S D}) @item @var{boole-and} @tab (logand @emph{S D}) @item @var{boole-c1} @tab (lognot @emph{S}) @item @var{boole-c2} @tab (lognot @emph{D}) @item @var{boole-clr} @tab 0 @item @var{boole-eqv} @tab (logeqv @emph{S D}) @item @var{boole-ior} @tab (logior @emph{S D}) @item @var{boole-nand} @tab (lognand @emph{S D}) @item @var{boole-nor} @tab (lognor @emph{S D}) @item @var{boole-orc1} @tab (logorc1 @emph{S D}) @item @var{boole-orc2} @tab (logorc2 @emph{S D}) @item @var{boole-set} @tab 1 @item @var{boole-xor} @tab (logxor @emph{S D}) @end multitable @table @var @item function Type @var{boole-constant}. @end table @end defun @defun gcontext-id gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns the unique ID that has been assigned to the specified graphics context. @table @var @item id Type @var{resource-id}. @end table @end defun @defun gcontext-join-style gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns and (with @code{setf}) changes the join-style attribute of the specified graphics context. The join-style attribute of a graphics context defines how the segment intersections are drawn for wide polylines. The possible values and their interpretations are as follows: @table @var @item :bevel Uses @var{:butt} end point styles with the triangular notch filled. @item :miter The outer edges of two lines extend to meet at an angle. @item :round A circular arc with diameter equal to the line-width, centered on the join point. @end table When the end points of a polyline segment are identical, the effect is as if the segment was removed from the polyline. When a polyline is a single point, the effect is the same as when the cap-style is applied at both end points. @table @var @item join-style One of @var{:bevel}, @var{:miter}, or @var{:round}. @end table @end defun @defun gcontext-line-style gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns and (with @code{setf}) changes the line-style attribute of the specified graphics context. The line-style attribute of a graphics context specifies how (which sections of) lines are drawn for a path in graphics operations. The possible values and their meanings are as follows: @table @var @item :solid The full path is drawn. @item :double-dash The full path is drawn, but the even dashes are filled differently than the odd dashes. The @var{:butt} style is used where even and odd dashes meet (see paragraph 5.4.7, Fill-Rule and Fill-Style). @item :on-off-dash Only the even dashes are drawn, with cap-style applied to all internal ends of the individual dashes, except @var{:not-last} is treated as @var{:butt}. @end table @table @var @item line-style One of @var{:dash}, @var{:double-dash}, or @var{:solid}. @end table @end defun @defun gcontext-line-width gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns the @emph{line-width} of the specified graphics context. The line-width is measured in pixels and can be greater than or equal to one (wide line) or can be the special value zero (thin line). Wide lines are drawn centered on the path described by the graphics operation. Unless otherwise specified by the join-style or cap-style, the bounding box of a wide line with end points [x1, y1], [x2, y2], and width w is a rectangle with vertices at the following real coordinates: [x1 - (w*@emph{sin}/2), y1 + (w*@emph{cos}/2)], [x1+ (w*@emph{sin}/2), y1 - (w*@emph{cos}/2)],@* [x2 - (w*@emph{sin}/2), y2 + (w*@emph{cos}/2)], [x2 + (w*@emph{sin}/2), y2 - (w*@emph{cos}/2)] where @emph{sin} is the sine of the angle of the line and @emph{cos} is the cosine of the angle of the line. A pixel is part of the line and, hence, is drawn if the center of the pixel is fully inside the bounding box (which is viewed as having infinitely thin edges). If the center of the pixel is exactly on the bounding box, it is part of the line if, and only if, the interior is immediately to its right (x increasing direction). Pixels with centers on a horizontal edge are a special case and are part of the line if, and only if, the interior is immediately below (y increasing direction). Thin lines (zero line-width) are always one pixel wide lines drawn using an unspecified, device dependent algorithm. There are only two constraints on this algorithm. @enumerate @item If a line is drawn unclipped from [x1,y1] to [x2,y2] and if another line is drawn unclipped from [x1+dx,y1+dy] to [x2+dx,y2+dy], a point [x,y] is touched by drawing the first line if, and only if, the point [x+dx,y+dy] is touched by drawing the second line. @item The effective set of points comprising a line cannot be affected by clipping. That is, a point is touched in a clipped line if, and only if, the point lies inside the clipping region and the point would be touched by the line when drawn unclipped. @end enumerate A wide line drawn from [x1,y1] to [x2,y2] always draws the same pixels as a wide line drawn from [x2,y2] to [x1,y1], not counting cap-style and join-style. Implementors are encouraged to make this property true for thin lines, but it is not required. A line-width of zero may differ from a line-width of one in which pixels are drawn. This permits the use of many manufacturer's line drawing hardware, which may run much faster than the more precisely specified wide lines. In general, drawing a thin line is faster than drawing a wide line of width one. However, because of their different drawing algorithms, thin lines may not mix well, aesthetically speaking, with wide lines. If it is desirable to obtain precise and uniform results across all displays, a client should always use a line-width of one, rather than a line-width of zero. @table @var @item line-width Type @var{card16}. @end table @end defun @defun gcontext-p gcontext @table @var @item gcontext Type @var{boolean}. @end table Returns non-@var{nil} if the argument is a graphics context and @end defun @defun gcontext-plane-mask gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns the @emph{plane-mask} of the specified graphics context. The plane-mask attribute of a graphics context specifies which bit planes of the destination drawable are modified during a graphic operation. The plane-mask is a pixel value in which a 1 bit means that the corresponding bit plane will be modified and a 0 bit means that the corresponding bit plane will not be affected during a graphic operations. Thus, the actual result of a graphic operation depends on both the function and plane-mask attributes of the graphics context and is given by the following expression: @lisp (logior (logand (boole function source destination) plane-mask) (logandc2 destination plane-mask)) @end lisp @table @var @item plane-mask Type @var{card32}. @end table @end defun @defun gcontext-plist gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns and (with @code{setf}) sets the property list for the specified @emph{gcontext}. This function provides a hook where extensions can add data. @table @var @item gcontext-p Type @var{list}. @end table @end defun @defun gcontext-stipple gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns the @emph{stipple} of the specified graphics context. The stipple attribute of a graphics context is a bitmap used to prevent certain pixels in the destination of graphics operations from being affected by tiling. The stipple and tile have the same origin. This origin point is interpreted relative to the origin of whatever destination drawable is specified in a graphics request. The stipple pixmap must have depth one and must have the same root as the graphics context. The tile pixmap must have the same root and depth as the graphics context. For stipple operations where the fill-style is @var{:stippled} (but not @var{:opaque-stippled}), the stipple pattern is tiled in a single plane and acts as an additional clip mask to be @var{and}ed with the clip-mask. Any size pixmap can be used for stipple or tile, although some sizes may be faster to use than others. Specifying a pixmap for stipple or tile in a graphics context might or might not result in a copy being made. If the pixmap is later used as the destination for a graphics operation, the change might or might not be reflected in the graphics context. If the pixmap is used both as the destination for a graphics operation and as a stipple or tile, the results are not defined. Some displays have hardware support for tiling or stippling with patterns of specific sizes. Tiling and stippling operations that restrict themselves to those sizes may run much faster than such operations with arbitrary size patterns. CLX provides functions to determine the best size for stipple or tile (see @var{query-best-stipple} and @var{query-best-tile}). @table @var @item stipple Type @var{pixmap}. @end table @end defun @defun gcontext-subwindow-mode gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns and (with @code{setf}) changes the subwindow-mode attribute of the specified graphics context. The subwindow-mode attribute of a graphics context specifies whether subwindows obscure the contents of their parent window during a graphics operation. For a value of @var{:clip-by-children}, both source and destination windows are clipped by all viewable @var{:input-output} class children. This clipping is in addition to the clipping provided by the clip-mode attribute. For a value of @var{:include-inferiors}, neither the source nor destination window is clipped by its inferiors. This results in the inclusion of subwindow contents in the source and the drawing through of subwindow boundaries of the destination. The use of @var{:include-inferiors} on a window of one depth with mapped inferiors of differing depth is not illegal, but the semantics are not defined by the core protocol. @table @var @item subwindow-mode One of @var{:clip-by-children} or @var{:include-inferiors}. @end table @end defun @defun gcontext-tile gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns the @emph{tile} of the specified graphics context. The tile attribute is a pixmap used to fill in areas for graphics operations. It is so named because copies of it are laid out side by side to fill the area. The stipple and tile have the same origin. This origin point is interpreted relative to the origin of whatever destination drawable is specified in a graphics request. The stipple pixmap must have depth one and must have the same root as the graphics context. The tile pixmap must have the same root and depth as the graphics context. For stipple operations where the fill-style is @var{:stippled} (but not @var{:opaque-stippled}), the stipple pattern is tiled in a single plane and acts as an additional clip mask to be @var{and}ed with the clip-mask. Any size pixmap can be used for stipple or tile, although some sizes may be faster to use than others. Specifying a pixmap for stipple or tile in a graphics context might or might not result in a copy being made. If the pixmap is later used as the destination for a graphics operation, the change might or might not be reflected in the graphics context. If the pixmap is used both as the destination for a graphics operation and as a stipple or tile, the results are not defined. Some displays have hardware support for tiling or stippling with patterns of specific sizes. Tiling and stippling operations that restrict themselves to those sizes may run much faster than such operations with arbitrary size patterns. CLX provides functions to determine the best size for stipple or tile (see @var{query-best-stipple} and @var{query-best-tile}). @table @var @item tile Type @var{pixmap}. @end table @end defun @defun gcontext-ts-x gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns the @emph{ts-x} attribute of the specified graphics context. The ts-x and ts-y attributes of a graphics context are the coordinates of the origin for tile pixmaps and the stipple. @table @var @item ts-x Type @var{int16}. @end table @end defun @defun gcontext-ts-y gcontext @table @var @item gcontext A @var{gcontext}. @end table Returns the @emph{ts-y} attribute of the specified graphics context. The ts-x and ts-y attributes of a graphics context are the coordinates of the origin for tile pixmaps and the stipple. @table @var @item ts-y Type @var{int16}. @end table @end defun @defun query-best-stipple width height drawable @table @var @item width @itemx height Specifies the width and height of the desired stipple pattern. @item drawable A @var{drawable}. @end table Returns the @emph{best-width} and @emph{best-height} for stipple pixmaps on the @emph{drawable}. The @emph{drawable} indicates the screen and possibly the window class and depth. An @var{:input-only} window cannot be specified as the @emph{drawable}. The size is returned as width and height values. @table @var @item best-width @itemx best-height Type @var{card16}. @end table @end defun @defun query-best-tile width height drawable @table @var @item width @itemx height Specifies the width and height of the desired tile pattern. @item drawable A @var{drawable}. @end table Returns the @emph{best-width} and @emph{best-height} for tile pixmaps on the @emph{drawable}. The @emph{drawable} indicates the screen and possibly the window class and depth. An @var{:input-only} window cannot be specified as the @emph{drawable}. The size is returned as width and height values. @table @var @item best-width @itemx best-height Type @var{card16}. @end table @end defun @node Copying Graphics Contexts, Destroying Graphics Contexts, Graphics Context Attributes, Graphics Contexts @section Copying Graphics Contexts CLX provides functions to copy some or all attribute values from one graphics context to another. These functions are generally more efficient than using @code{setf} to copy @var{gcontext} attributes individually. @defun copy-gcontext source destination @table @var @item source The source @var{gcontext}. @item destination The destination @var{gcontext}. @end table Copies all the values of the attributes of the source graphics context into the destination graphics context. The source and destination graphics contexts must have the same root and depth. @end defun @defun copy-gcontext-components source destination &rest keys @table @var @item source The source @var{gcontext}. @item destination The destination @var{gcontext}. @item keys The remaining arguments are keywords, of type @var{gcontext-key}, which specify which attributes of the graphics context are to be copied. @end table Copies the values of the specified attributes of the source graphics context to the destination graphics context. The source and destination graphics contexts must have the same root and depth. @end defun @node Destroying Graphics Contexts, Graphics Context Cache, Copying Graphics Contexts, Graphics Contexts @section Destroying Graphics Contexts To destroy a graphics context, use @var{free-gcontext.} @defun free-gcontext gcontext @table @var @item gcontext A @var{gcontext}. @end table Deletes the association between the assigned resource ID and the specified graphics context, and then destroys the graphics context. @end defun @node Graphics Context Cache, , Destroying Graphics Contexts, Graphics Contexts @section Graphics Context Cache CLX provides a set of functions to control the automatic graphics context caching mechanism. @defun force-gcontext-changes gcontext @table @var @item gcontext A @var{gcontext}. @end table Forces any delayed changes to the specified graphics context to be sent out to the server. Note that @var{force-gcontext-changes} is called by all of the graphics functions. @end defun @defmac with-gcontext gcontext &key :arc-mode :background :cap-style :clip-mask :clip-ordering :clip-x :clip-y :dashes :dash-offset :exposures :fill-rule :fill-style :font :foreground :function :join-style :line-style :line-width :plane-mask :stipple :subwindow-mode :tile :ts-x :ts-y &allow-other-keys &body body @anchor{with-gcontext} Changes the indicated graphics context components to the specified values only within the dynamic extent of the body. @var{with-gcontext} works on a per-process basis in a multiprocessing environment. The @emph{body} is not surrounded by a @var{with-display} form. If there is no local cache for the specified graphics context, or if some of the component states are unknown, @var{with-gcontext} does the save and restore by creating a temporary graphics context and copying components to and from it using @var{copy-gcontext-components}. @table @var @item gcontext A @var{gcontext}. @item :arc-mode @itemx :background @itemx :cap-style @itemx :clip-mask @itemx :clip-ordering @itemx :clip-x @itemx :clip-y @itemx :dashes @itemx :dash-offset @itemx :exposures @itemx :fill-rule @itemx :fill-style @itemx :font @itemx :foreground @itemx :function @itemx :join-style @itemx :line-style @itemx :line-width @itemx :plane-mask @itemx :stipple @itemx :subwindow-mode @itemx :tile @itemx :ts-x @itemx :ts-y These keyword arguments and associated values specify which graphics context components are to be changed. Any components not specified are left unmodified. @xref{Creating Graphics Contexts}, for more information. @item body The body of code which will have access to the altered graphics context. @end table @end defmac @node Graphic Operations, Images, Graphics Contexts, Top @chapter Graphic Operations Once connected to an X server, a client can use CLX functions to perform graphic operations on drawables. This section describes CLX functions to: @itemize @bullet @item Operate on areas and planes @item Draw points @item Draw lines @item Draw rectangles @item Draw arcs @item Draw text @end itemize @menu * Area and Plane Operations:: * Drawing Points:: * Drawing Lines:: * Drawing Rectangles:: * Drawing Arcs:: * Drawing Text:: @end menu @node Area and Plane Operations, Drawing Points, Graphic Operations, Graphic Operations @section Area and Plane Operations @var{clear-area} clears an area or an entire window to the background. Since pixmaps do not have backgrounds, they cannot be filled by using the functions described in the following paragraphs. Instead, you should use @var{draw-rectangle}, which sets the pixmap to a known value. @xref{Drawing Rectangles}, for information on @var{draw-rectangle}. @defun clear-area window &key (:x 0) (:y 0) :width :height :exposures-p @table @var @item window A @var{window}. @item :x @itemx :y Upper-left corner of the area to be cleared. These coordinates are relative to the @emph{window} origin. Type is @var{int16}. @item :width The width of the area to clear or @var{nil} to clear to the remaining width of the window. Type is @var{card16} or @var{null}. @item :height The height of the area to clear or @var{nil} to clear to the remaining height of the window. Type is @var{card16} or @var{null}. @item :exposures-p Specifies if @var{:exposure} events should be generated for the affected areas. Type @var{boolean}. @end table Draws a rectangular area in the specified @emph{window} with the background pixel or pixmap of the @emph{window}. The @var{:x} and @var{:y} coordinates are relative to the @emph{window} origin, and specify the upper-left corner of the rectangular area that is to be cleared. A @var{nil} or zero value for @var{:height} or @var{:width} clears the remaining area (height - y or width - x). If the @emph{window} has a defined background tile, the rectangle is tiled by using a plane-mask of all ones and a function of @var{:copy}. If the @emph{window} has background @var{:none}, the contents of the @emph{window} are not changed. In either case, if @var{:exposures-p} is non-@var{nil}, then one or more @var{:exposure} events are generated for regions of the rectangle that are either visible or are being retained in a backing store. To clear the entire area in a specified @emph{window}, use (@var{clear-area} @emph{window}). @end defun @defun copy-area source gcontext source-x source-y width height destination destination-x destination-y @table @var @item source Source @var{drawable}. @item gcontext The graphics context to use during the copy operation. @item source-x @itemx source-y The x and y coordinates of the upper-left corner of the area in the @emph{source} @var{drawable}. These coordinates are relative to the @emph{source} @var{drawable} origin. Type is @var{int16}. @item width @itemx height The width and height of the area being copied. These apply to both the @emph{source} and @emph{destination} areas. Type is @var{card16}. @item destination The destination @var{drawable}. @item destination-x @itemx destination-y The x and y coordinates of the upper left corner of the area in the @emph{destination} @var{drawable}. These coordinates are relative to the @emph{destination} @var{drawable} origin. Type is @var{int16}. @end table Copies the specified rectangular area from the @emph{source} @var{drawable} to the specified rectangular area of the @emph{destination} @var{drawable}, combining them as specified in the supplied graphics context (@emph{gcontext}). The @emph{x} and @emph{y} coordinates are relative to their respective drawable origin, with each pair specifying the upper left corner of the area. If either regions of the @emph{source} area are obscured and have not been retained in backing store, or regions outside the boundaries of the @emph{source} @var{drawable} are specified, those regions are not copied. Instead, the following occurs on all corresponding @emph{destination} regions that are either visible or are retained in backing store: @itemize @bullet @item If the @emph{destination} rectangle is a window with a background other than @var{:none}, these corresponding regions of the @emph{destination} are tiled, using plane-mask of all ones and function of @var{boole-1} (copy source), with that background. @item If the exposures attribute of the graphics context is @var{:on}, then @var{:graphics-exposure} events for all corresponding @emph{destination} regions are generated (regardless of tiling or whether the @emph{destination} is a window or a pixmap). @item If exposures is @var{:on} but no regions are exposed, a @var{:no-exposure} event is generated. Note that by default, exposures is @var{:on} for new graphics contexts. @xref{Graphics Contexts}, for further information. @end itemize @end defun @defun copy-plane source gcontext plane source-x source-y width height destination destination-x destination-y @table @var @item source The source @var{drawable}. @item gcontext The graphics context to use during the copy operation. @item plane Specifies the bit-plane of the @emph{source} @var{drawable}. Exactly one bit must be set. Type is @var{pixel}. @item source-x @itemx source-y The @emph{x} and @emph{y} coordinates of the upper-left corner of the area in the @emph{source} @var{drawable}. These coordinates are relative to the @emph{source} @var{drawable} origin. Type is @var{int16}. @item width @itemx height The width and height of the area being copied. These apply to both the @emph{source} and @emph{destination} areas. Type is @var{card16}. @item destination The destination @var{drawable}. @item destination-x @itemx destination-y The x and y coordinates of the upper-left corner of the destination area in the @emph{destination} @var{drawable}. These coordinates are relative to the @emph{destination} @var{drawable} origin. Type is @var{int16}. @end table Uses a single bit plane of the specified rectangular area of the @emph{source} @var{drawable} along with the specified graphics context (@emph{gcontext}) to modify the specified rectangle area of the @emph{destination} @var{drawabl}e. The drawables specified by the @emph{source} and @emph{destination} arguments must have the same root but need not have the same depth. Effectively, this operation forms a pixmap of the same depth as @emph{destination} and with a size specified by the @emph{source} area. It then uses the foreground and background from the graphics context (foreground where the bit-plane in @emph{source} contains a one bit, background where the bit-plane in @emph{source} contains a zero bit), and the equivalent of a @var{copy-area} operation is performed with all the same exposure semantics. This can also be thought of as using the specified region of the @emph{source} bit-plane as a stipple with a fillstyle of @var{:opaque-stippled} for filling a rectangular area of the @emph{destination}. @end defun @node Drawing Points, Drawing Lines, Area and Plane Operations, Graphic Operations @section Drawing Points The @var{draw-point} and @var{draw-points} functions make use of the following graphics context components: function, plane-mask, foreground, subwindow-mode, clip-x, clip-y, clip-ordering, clip-region and clip-mask. The @var{draw-point} function uses the foreground pixel and function components of the graphics context to draw a single point into the specified drawable, while @var{draw-points} draws multiple points into the specified drawable. These functions are not affected by the tile or stipple in the graphics context. @defun draw-point drawable gcontext x y @table @var @item drawable The destination @var{drawable}. @item gcontext The graphics context for drawing the point. @item x @itemx y The @emph{x} and @emph{y} coordinates of the point drawn. Type is @var{int16}. @end table Combines the foreground pixel in the @emph{gcontext} with the pixel in the @emph{drawable} specified by the @emph{x} and @emph{y} coordinates. @end defun @defun draw-points drawable gcontext points &optional relative-p @table @var @item drawable The destination @var{drawable}. @item gcontext The graphics context for drawing the points. @item points A list of points to be drawn in the order listed. The first point is always relative to the @emph{drawable}'s origin; if @emph{relative-p}, the rest of the points are drawn relative to the previous point, else they are drawn relative to the @emph{drawable}'s origin. Type is @var{point-seq}. @item relative-p Specifies the coordinate mode used for drawing the pixels either relative to the origin or to the previous point. Type @var{boolean}. @end table Combines the foreground pixels in the graphics context with the pixels at each point in the @emph{drawable}. The points are drawn in the order listed. @var{draw-points} requires a mode argument, @emph{relative-p} that indicates whether the points are relative to the destination origin or to the previous point. In either case, the first point is always relative to the destination origin. The rest of the points are relative either to the @emph{drawable}'s origin or to the previous point, depending on the value of @emph{relative-p}. @end defun @node Drawing Lines, Drawing Rectangles, Drawing Points, Graphic Operations @section Drawing Lines The @var{draw-line}, @var{draw-lines}, and @var{draw-segments} functions use the following graphics context components: background, cap-style, clip-x-origin, clip-y-origin, clip-mask, dash-list, dash-offset, fill-style, foreground, function, plane-mask, line-width, line-style, stipple, subwindow-mode, tile, ts-x-origin, and ts-y-origin. The @var{draw-lines} function also uses the join-style graphics context component. @defun draw-line drawable gcontext x1 y1 x2 y2 &optional relative-p @table @var @item drawable The destination @var{drawable}. @item gcontext The graphics context for drawing the line. @item x1 @itemx y1 @itemx x2 @itemx y2 The end points of the line. @item relative-p Specifies the coordinate mode used for drawing the line either relative to the origin or the previous point. In either case, the first point is always drawn relative to the @emph{drawable}'s origin. @end table Draws a line from the point @emph{x1},@emph{y1} to the point @emph{x2},@emph{y2}. When @emph{relative-p} is true, the first point is relative to the destination origin but the second point is relative to the first point. When @emph{relative-p} is @var{nil}, both points are relative to the destination origin. @end defun @defun draw-lines drawable gcontext points &key :relative-p :fill-p (:shape :complex) @table @var @item drawable The destination @var{drawable}. @item gcontext The graphics context for drawing the lines. @item points A list of points that define the lines. Type is @var{point-seq}. @item :relative-p The coordinate mode of the points. @item :fill-p When true, a filled polygon is drawn instead of a polyline. @item :shape A hint that allows the server to use the most efficient area fill algorithm. Either @var{:convex}, @var{:non-convex}, or @var{:complex}. @end table Draws a line between each pair of @emph{points} in the points list. The lines are drawn in the order listed and join correctly at all intermediate points. The join-style graphics context component defines the type of joint to use. When the first and last points coincide, the first and last lines also join correctly to produce a hollow polygon. When @var{:relative-p} is true, the first point is always relative to the destination origin, but the rest are relative to the previous point. When @var{:relative-p} is @var{nil}, the rest of the points are drawn relative to the destination origin. When @var{:fill-p} is true, the polygon defined by the @emph{points} list is filled. The @var{:shape} keyword provides the server with a hint about how to fill the polygon. @var{:shape} can be either @var{:complex} (by default), @var{:convex}, or @var{:non-convex}. The @var{:convex} operand is the simplest type of area and the fastest to fill. A fill area is convex if every straight line connecting any two interior points is entirely inside the area. For example, triangles and rectangles are convex polygons. The @var{:non-convex} operand is for filling an area that is not convex and is also not self-intersecting. Filling this type of area is harder than filling a convex area, but easier than filling one that is self-intersecting. For example, the shape of the letter "T" is non-convex and non-self-intersecting. The @var{:complex} operand is the most general (and therefore the hardest) type of fill area. A complex fill area can be non-convex and self-intersecting. For example, draw the outline of a bow tie, without lifting your pencil or tracing over an edge twice. This shape is non-convex and intersects itself at the knot in the middle. @var{NOTE:} Unless you are sure that a shape is @var{:convex} or @var{:non-convex}, it should always be drawn as a @var{:complex} shape. If @var{:convex} or @var{:non-convex} is specified incorrectly, the graphics result is undefined. @end defun @defun draw-segments drawable gcontext segments @table @var @item drawable The destination @var{drawable} to receive the line segments. @item gcontext Specifies the graphics context for drawing the lines. @item segments The points list for the segments to draw. Type is @var{seq}. @end table Draws multiple lines, not necessarily connected. @emph{segments} is a sequence of the form @{x1 y1 x2 y2@}*, in which each subsequence specifies the end points of a line segment. Line segments are drawn in the order given by @emph{segments}. Unlike @var{draw-lines}, no joining is performed at coincident end points. @end defun @node Drawing Rectangles, Drawing Arcs, Drawing Lines, Graphic Operations @section Drawing Rectangles The @var{draw-rectangle} and @var{draw-rectangles} functions draw hollow or filled outlines of the specified rectangle or rectangles as if a five-point polyline were specified for each rectangle, as follows: @display [x,y,] [x+width,y] [x+width,y+height] [x,y+height] [x,y] @end display @var{draw-rectangle} and @var{draw-rectangles} use the following graphics context components: background, function, plane-mask, foreground, subwindow-mode, cap-style, clip-x, clip-y, clip-ordering, clip-region and clip-mask, dash-list, dash-offset, fill-style, join-style, line-width, line-style, stipple, tile, ts-x-origin, and ts-y-origin. @defun draw-rectangle drawable gcontext x y width height &optional fill-p @table @var @item drawable The destination @var{drawable}. @item gcontext The graphics context for drawing the rectangle. @item x @itemx y The x and y coordinates that define the upper left corner of the rectangle. The coordinates are relative to the destination origin. Type is @var{int16}. @item width @itemx height Specifies the width and height that define the outline of the rectangle. Type is @var{card16}. @item fill-p Specifies whether the rectangle is filled or not. Type @var{boolean}. @end table Draws a rectangle defined by the @emph{x}, @emph{y}, @emph{width}, and @emph{height} arguments. @end defun @defun draw-rectangles drawable gcontext rectangles &optional fill-p @table @var @item drawable The destination @var{drawable}. @item gcontext The graphics context. @item rectangles A list specifying the upper left corner x and y, width and height of the rectangles. Type is @var{rect-seq}. @item fill-p Specified if the rectangles are filled or not. Type is @var{boolean}. @end table Draws the rectangles in the order listed in @emph{rectangles}. For the specified @emph{rectangle} or @emph{rectangles}, no pixel is drawn more than once. The x and y coordinates of each rectangle are relative to the destination origin and define the upper left corner of the rectangle. If rectangles intersect, the intersecting pixels are drawn multiple times. @end defun @node Drawing Arcs, Drawing Text, Drawing Rectangles, Graphic Operations @section Drawing Arcs @var{draw-arc} draws a single circular or an elliptical arc, while @var{draw-arcs} draws multiple circular or elliptical arcs. @var{draw-arc} and @var{draw-arcs} use the following graphics context components: arc-mode, background, cap-style, clip-x, clip-y, clip-mask, dash-list, dash-offset, fill-style, foreground, join-style, function, plane-mask, line-width, line-style, stipple, subwindow-mode, tile, ts-x-origin, and ts-y-origin. @defun draw-arc drawable gcontext x y width height angle1 angle2 &optional fill-p @table @var @item drawable The destination @var{drawable}. @item gcontext The graphics context for drawing the arc. @item x @itemx y The x and y coordinates of the arc rectangle relative to the origin of the @emph{drawable}. Type is @var{int16}. @item width @itemx height Specifies the width and height of the rectangle. These are the major and minor axes of the arc. Type is @var{card16}. @item angle1 Specifies the start of the arc in radians. Type is @var{angle}. @item angle2 Specifies the direction and end point of the arc. Type is @var{angle}. @item fill-p Specifies whether the arc is filled or not. Type @var{boolean}. @end table Draws either a circular or an elliptical arc. Also, outlined or filled arcs can be drawn. Each arc is specified by a rectangle (@emph{x}, @emph{y}, @emph{width}, and @emph{height}) and two angles (@emph{angle1} and @emph{angle2}). The angles are signed integers in radians, with positive indicating counterclockwise motion and negative indicating clockwise motion. The start of the arc is specified by @emph{angle1}, and the path and extent of the arc is specified by @emph{angle2} relative to the start of the arc. If the magnitude of @emph{angle2} is greater than 360 degrees, it is truncated to 360 degrees. The @emph{x} and @emph{y} coordinates of the rectangle are relative to the @emph{drawable}'s origin. For example, an arc specified as [@emph{x},@emph{y},@emph{width},@emph{height},@emph{angle1},@emph{angle2}] has the origin of the major and minor axes at: @display [@emph{x}+(@emph{width}/2),@emph{y}+(@emph{height}/2)] @end display The infinitely thin path describing the entire circle/ellipse intersects the horizontal axis at: @display [@emph{x},@emph{y}+(@emph{height}/2)] and [@emph{x}+@emph{width},@emph{y}+(@emph{height}/2)] @end display The intersection of the vertical axis is at: @display [@emph{x}+(@emph{width}/2),@emph{y}] and [@emph{x}+(@emph{width}/2),@emph{y}+@emph{height}] @end display These coordinates can be fractional; that is, they are not truncated to discrete coordinates. Note that the angle values are slightly different in CLX than in the X protocol specification. If @emph{fill-p} is @var{nil}, then only the outline of the arc is drawn. Otherwise, if @emph{fill-p} is true, @var{draw-arc} fills the area bounded by the arc outline and one or two line segments, depending on the arc-mode. If the arc-mode is @var{:chord}, the filled area is bounded by the arc outline and the line segment joining the arc end points. If the arc-mode is @var{:pie-slice}, the filled area is bounded by the arc outline and the two line segments joining each arc end point with the center point. @end defun @defun draw-arcs drawable gcontext arcs &optional fill-p @table @var @item drawable Specifies the @var{drawable} where you want the arcs drawn. @item gcontext Specifies the graphics context for drawing the arc. @item arcs A sequence containing the width, height, angle1, and angle2 arguments defining the arcs. See @var{draw-arc} for more detail. Type is @var{arc-seq}. @item fill-p Specifies whether the arcs are filled or not. Type is @var{boolean}. @end table Draws circular or elliptical, outlined or filled arcs. Each arc is specified by a rectangle and two angles. For a more detailed description, see @var{draw-arc}. The arcs are filled in the order listed. For any given arc, no pixel is drawn more than once. If regions intersect, the intersecting pixels are drawn multiple times. @end defun @node Drawing Text, , Drawing Arcs, Graphic Operations @section Drawing Text CLX provides functions for drawing text using text fonts provided by the X server. An X font is array of character bit maps indexed by integer codes. @xref{Font and Characters}, for a complete discussion of the CLX functions used to manage fonts and characters. Since Common Lisp programs typically represent text as sequences of characters (that is, strings), CLX text functions must be prepared to convert a Common Lisp character into the integer code used to index the appropriate character bitmap in a given font. The @var{:translate} argument to a text function is a function which performs this conversion. The default @var{:translate} function handles all characters that satisfy @var{graphic-char-p} by converting each character into its ASCII code. Note that the assumption made by the default @var{:translate} function--that is, that an X font indexes bitmaps by ASCII codes--is often valid, but other encodings are possible. In general, a @var{:translate} function can perform complex transformations. It can be used to convert non-character input, to handle non-ASCII character encodings, and to change the fonts used to access character bitmaps. The complete behavior of a @var{:translate} function is given below by describing a prototypical @var{translate-function}. CLX offers two different ways to draw text--filled text and block text. The @var{draw-glyph} and @var{draw-glyphs} functions create filled text, in which each character image is treated as an area to be filled according to the fill-style of the given graphics context, without otherwise disturbing the surrounding background. In addition, filled text sends a complex type of server request which allows a series of font indices, font changes, and horizontal position changes to be compiled into a single request. Filled text functions use the following graphics context attributes: background, clip-mask, clip-x-origin, clip-y-origin, fill-style, font, foreground, function, plane-mask, stipple, subwindow-mode, tile, ts-x-origin, ts-y-origin. Block text is a rendering style commonly used by display terminals, in which each character image appears in the foreground pixel inside a rectangular character cell drawn in the graphics context background pixel. The @var{draw-image-glyph} and @var{draw-image-glyphs} functions create block text. Block text functions use the following graphics context attributes: background, clip-mask, clip-x-origin, clip-y-origin, font, foreground, plane-mask, stipple, subwindow-mode, tile, ts-x-origin, ts-y-origin. @defun draw-glyph drawable gcontext x y element &key :translate :width (:size :default) @table @var @item drawable The destination @var{drawable}. @item gcontext The graphics context for drawing text. @item x @itemx y The left baseline position for the character drawn. @item element A character or other object to be translated into a font index. @item :translate A function to translate text to font indexes. Default is @var{#'translate-default}. @item :width The total pixel width of the character actually drawn, if known. @item :size Specifies the element size of the destination buffer given to @var{:translate} (8, 16, or @var{:default}). @end table Draws a single character of filled text represented by the given @emph{element}. The given @emph{x} and @emph{y} specify the left baseline position for the character. The first return value is true if the character is successfully translated and drawn, or @var{nil} if the @var{:translate} function did not translate it. The second return value gives the total pixel width of the character actually drawn, if known. Specifying a @var{:width} is a hint to improve performance. The @var{:width} is assumed to be the total pixel width of the character actually drawn. Specifying @var{:width} permits appending the output of subsequent calls to the same protocol request, provided @emph{gcontext} has not been modified in the interim. If @var{:width} is not specified, appending of subsequent output might not occur (unless @var{:translate} returns the character width). The @var{:size} specifies the element size of the destination buffer given to @var{:translate} (either 8, 16, or @var{:default}). If @var{:default} is specified, the size is based on the current font, if known; otherwise, 16 is used. @table @var @item output-p Type @var{boolean}. @item width Type @var{int32} or @var{null}. @end table @end defun @defun draw-glyphs drawable gcontext x y sequence &key (:start 0) :end :translate :width (:size :default) @table @var @item drawable The destination @var{drawable}. @item gcontext The graphics context for drawing text. @item x @itemx y The left baseline position for the character drawn. @item sequence A sequence of characters or other objects to be translated into font indexes. @item :start @itemx :end Start and end indexes defining the elements to draw. @item :translate A function to translate text to font indexes. Default is @var{#'translate-default}. @item :width The total total pixel width of the character actually drawn, if known. @item :size The element size of the destination buffer given to @var{:translate} (8, 16, or @var{:default}). @end table Draws the filled text characters represented by the given sequence. @var{:start} and @var{:end} define the elements of the sequence which are drawn. The given @emph{x} and @emph{y} specify the left baseline position for the first character. The first return value is @var{nil} if all characters are successfully translated and drawn; otherwise, the index of the first untranslated sequence element is returned. The second return value gives the total pixel width of the characters actually drawn, if known. Specifying a @var{:width} is a hint to improve performance. The @var{:width} is assumed to be the total pixel width of the character sequence actually drawn. Specifying @var{:width} permits appending the output of subsequent calls to the same protocol request, provided @emph{gcontext} has not been modified in the interim. If @var{:width} is not specified, appending of subsequent output might not occur (unless @var{:translate} returns the character width). The @var{:size} specifies the element size of the destination buffer given to@var{ :translate} (either 8, 16, or @var{:default}). If @var{:default} is specified, the size is based on the current font, if known; otherwise, 16 is used. @table @var @item new-start Type @var{array-index} or @var{null}. @item width Type @var{int32} or @var{null}. @end table @end defun @defun draw-image-glyph drawable gcontext x y element &key :translate :width (:size :default) @table @var @item drawable The destination @var{drawable}. @item gcontext The graphics context for drawing text. @item x @itemx y The left baseline position for the character drawn. @item element A character or other object to be translated into a font index. @item :translate A function to translate text to font indexes. Default is @var{#'translate-default}. @item :width The total pixel width of the character actually drawn, if known. @item :size Specifies the element size of the destination buffer given to @var{:translate} (8, 16, or @var{:default}). @end table Draws a single character of block text represented by the given @emph{element}. The given @emph{x} and @emph{y} specify the left baseline position for the character. The first return value is true if the character is successfully translated and drawn, or @var{nil} if the @var{:translate} function did not translate it. The @var{:translate} function is allowed to return an initial font change. The second return value gives the total pixel width of the character actually drawn, if known. The @var{:translate} function may not return a horizontal position change, since @var{draw-image-glyph} does not generate complex output requests. Specifying a @var{:width} is a hint to improve performance. The @var{:width} is assumed to be the total pixel width of the character actually drawn. Specifying @var{:width} permits appending the output of subsequent calls to the same protocol request, provided @emph{gcontext} has not been modified in the interim. If @var{:width} is not specified, appending of subsequent output might not occur (unless @var{:translate} returns the character width). The @var{:size} specifies the element size of the destination buffer given to @var{:translate} (either 8, 16, or @var{:default}). If @var{:default} is specified, the size is based on the current font, if known; otherwise, 16 is used. @table @var @item output-p Type @var{boolean}. @item width Type @var{int32} or @var{null}. @end table @end defun @defun draw-image-glyphs drawable gcontext x y sequence &key (:start 0) :end :translate :width (:size :default) @anchor{draw-image-glyphs} @table @var @item drawable The destination @var{drawable}. @item x @itemx y The left baseline position for the character drawn. @item gcontext The graphics context for drawing text. @item sequence A sequence of characters or other objects to be translated into font indexes. @item :start @itemx :end Start and end indexes defining the elements to draw. @item :translate A function to translate text to font indexes. Default is @var{#'translate-default}. @item :width The total total pixel width of the character actually drawn, if known. @item :size The element size of the destination buffer given to @var{:translate} (8, 16, or @var{:default}). @end table Draws the block text characters represented by the given @var{sequence}. @var{:start} and @var{:end} define the elements of the @emph{sequence} which are drawn. The given @emph{x} and @emph{y} specify the left baseline position for the first character. The first return value is @var{nil} if all characters are successfully translated and drawn; otherwise, the index of the first untranslated sequence element is returned. The @var{:translate} function is allowed to return an initial font change. The second return value gives the total pixel width of the characters actually drawn, if known. The @var{:translate} function may not return a horizontal position change, since @var{draw-image-glyphs} does not generate complex output requests. Specifying a @var{:width} is a hint to improve performance. The @var{:width} is assumed to be the total pixel width of the character sequence actually drawn. Specifying @var{:width} permits appending the output of subsequent calls to the same protocol request, provided @emph{gcontext} has not been modified in the interim. If @var{:width} is not specified, appending of subsequent output might not occur (unless @var{:translate} returns the character width). The @var{:size} specifies the element size of the destination buffer given to @var{:translate} (either 8, 16, or @var{:default}). If @var{:default} is specified, the size will be based on the current font, if known; otherwise, 16 is used. @table @var @item new-start Type @var{array-index} or @var{null}. @item width Type @var{int32} or @var{null}. @end table @end defun @defun translate-function source source-start source-end font destination destination-start @table @var @item source A sequence of characters or other objects to be translated. @item source-start An array-index specifying the first @emph{source} element to be translated. @item source-end An array-index specifying the end of the @emph{source} subsequence to be translated. @item font The font indexed by translated @emph{source} elements. @item destination A vector where translated @emph{source} elements are stored. @item destination-start An array-index specifying the position to begin storing translated @emph{source} elements. @end table A function used as the @var{:translate} argument for text functions. Converts elements of the @emph{source} (sub)sequence into font indexes for the given @emph{font} and stores them into the @emph{destination} vector. The @emph{destination} vector is created automatically by CLX. @emph{destination} is guaranteed to have room for (- @emph{source-end source-star}t) integer elements, starting at @emph{destination-start}. Elements of @emph{destination} can be either @var{card8} or @var{card16} integers, depending on the context. @emph{font} is the current font, if known, or @var{nil} otherwise. Starting with the element at @emph{source-start}, @var{translate-function} should translate as many elements of @emph{source} as possible (up to the @emph{source-end} element) into indexes in the current @emph{font}, and store them into @emph{destination}. The first return value should be the source index of the first untranslated element. The second return value indicates the changes which should be made to the current text output request before translating the remaining @emph{source} elements. If no further elements need to be translated, the second return value should be @var{nil}. If a horizontal motion is required before further translation, the second return value should be the change in x position. If a font change is required for further translation, the second return value should be the new font. If known, the pixel width of the translated text can be returned as the third value; this can allow for appending of subsequent output to the same protocol request, if no overall width has been specified at the higher level. @table @var @item first-not-done Type @var{array-index}. @item to-continue Type @var{int16}, @var{font}, or @var{null}. @item current-width Type @var{int32} or @var{null}. @end table @end defun @node Images, Font and Characters, Graphic Operations, Top @chapter Images The X protocol provides for the transfer of images (two-dimensional arrays of pixel data) between a client program and a @var{drawable}. The format for image data can vary considerably. In order to present a uniform data representation for the manipulation of a variety of images, CLX defines a special @var{image} data type. Additional @var{image} subtypes -- @var{image-xy} and @var{image-z} -- allow for the representation of an image either as a sequence of bit planes or as an array of pixels. CLX includes functions for accessing @var{image} objects; for transferring image data between @var{image} objects, @var{drawables}, and files; and also for direct transfer of raw image data. @menu * Image Types:: * Image Functions:: * Image Files:: * Direct Image Transfer:: @end menu @node Image Types, Image Functions, Images, Images @section Image Types The @var{image} data type is the base type for all @var{image} objects. @var{image-xy} and @var{image-z} are subtypes of the @var{image} type which furnish accessors specialized for different image representations. @menu * Basic Images:: * XY-Format Images:: * Z-Format Images:: @end menu @node Basic Images, XY-Format Images, Image Types, Image Types @subsection Basic Images The following paragraphs describe the CLX functions that can be used to access all types of @var{image} objects. @defun image-blue-mask image @table @var @item image An @var{image} object. @end table Returns (and with @code{setf}) changes the @emph{mask} that selects the pixel subfield for blue intensity values. The @emph{mask} is non-@var{nil} only for images for @var{:direct-color} or @var{:true-color} visual types. @table @var @item mask Type @var{pixel} or @var{null}. @end table @end defun @defun image-depth image @table @var @item image An @var{image} object. @end table Returns the @emph{depth} (that is, the number of bits per pixel) for the @emph{image}. @table @var @item depth Type @var{card8}. @end table @end defun @defun image-green-mask image @table @var @item image An @var{image} object. @end table Returns (and with @code{setf}) changes the mask that selects the pixel subfield for green intensity values. The mask is non-@var{nil} only for images for @var{:direct-color} or @var{:true-color} visual types. @table @var @item mask Type @var{pixel} or @var{null}. @end table @end defun @defun image-height image @table @var @item image An @var{image} object. @end table Returns the @emph{height} of the @emph{image} in pixels. @table @var @item height Type @var{card16}. @end table @end defun @defun image-name image @table @var @item image An @var{image} object. @end table Returns and (with @code{setf}) changes the @emph{name} string optionally associated with the @emph{image}. @table @var @item name Type @var{stringable} or @var{null}. @end table @end defun @defun image-plist image @table @var @item image An @var{image} object. @end table Returns and (with @code{setf}) changes the @emph{image} property list. The property list is a hook for added application extensions. @table @var @item plist Type @var{list}. @end table @end defun @defun image-red-mask image @table @var @item image An @var{image} object. @end table Returns (and with @code{setf}) changes the @emph{mask} which selects the pixel subfield for red intensity values. The @emph{mask} is non-@var{nil} only for images for @var{:direct-color} or @var{:true-color} visual types. @table @var @item mask Type @var{pixel} or @var{null}. @end table @end defun @defun image-width image @table @var @item image An @var{image} object. @end table Returns the @emph{width} of the @emph{image} in pixels. @table @var @item width Type @var{card16}. @end table @end defun @defun image-x-hot image @table @var @item image An @var{image} object. @end table Returns and (with @code{setf}) changes the x position of the hot spot for an image used as a cursor glyph. The hot spot position is specified relative to the upper-left origin of the @emph{image}. @table @var @item x-position Type @var{card16} or @var{null}. @end table @end defun @defun image-y-hot image @table @var @item image An @var{image} object. @end table Returns and (with @code{setf}) changes the y position of the hot spot for an image used as a cursor glyph. The hot spot position is specified relative to the upper-left origin of the @emph{image}. @table @var @item y-position Type @var{card16} or @var{null}. @end table @end defun @node XY-Format Images, Z-Format Images, Basic Images, Image Types @subsection XY-Format Images The @var{image-xy} subtype represents an image as a sequence of bitmaps, one for each plane of the image, in most-significant to least-significant bit order. The following paragraphs describe the additional CLX functions that can be used to access @var{image-xy} objects. @defun image-xy-bitmap-list image @table @var @item image An @var{image-xy} object. @end table Returns and (with @code{setf}) changes the list of bitmap planes for the @emph{image}. @table @var @item bitmaps Type @var{list} of @var{bitmap}. @end table @end defun @node Z-Format Images, , XY-Format Images, Image Types @subsection Z-Format Images The @var{image-z} subtype represents an image as a two-dimensional array of pixels, in scanline order. The following paragraphs describe the additional CLX functions that can be used to access @var{image-z} objects. @defun image-z-bits-per-pixel image @table @var @item image An @var{image-z} object. @end table Returns and (with @code{setf}) changes the number of bits per data unit used to contain a pixel value for the @emph{image}. Depending on the storage format for image data, this value can be larger than the actual @emph{image} depth. @table @var @item pixel-data-size One of 1, 4, 8, 16, 24, or 32. @end table @end defun @defun image-z-pixarray image @table @var @item image An @var{image-z} object. @end table Returns and (with @code{setf}) changes the two-dimensional array of pixel data for the @emph{image}. @table @var @item pixarray Type @var{pixarray}. @end table @end defun @node Image Functions, Image Files, Image Types, Images @section Image Functions The following paragraphs describe the CLX functions used to: @itemize @bullet @item Create an @var{image} object. @item Copy an image or a subimage. @item Read an image from a @var{drawable}. @item Display an image to a @var{drawable}. @end itemize @defun create-image &key :bit-lsb-first-p :bits-per-pixel :blue-mask :byte-lsb-first-p :bytes-per-line :data :depth :format :green-mask :height :name :plist :red-mask :width :x-hot :y-hot Function @table @var @item :bit-lsb-first-p For a returned image, true if the order of bits in each @var{:data} byte is least-significant bit first. @item :bits-per-pixel One of 1, 4, 8, 16, 24, or 32. @item :blue-mask For @var{:true-color} or @var{:direct-color} images, a pixel mask. @item :byte-lsb-first-p For a returned @emph{image}, true if the @var{:data} byte order is least-significant byte first. @item :bytes-per-line For a returned @emph{image}, the number of @var{:data} bytes per scanline. @item :data Either a @var{list} of @var{bitmaps}, a @var{pixarray}, or an array of @var{card8} bytes. @item :depth The number of bits per displayed pixel. @item :format One of @var{:bitmap}, @var{:xy-format}, or @var{:z-format}. @item :green-mask For @var{:true-color} or @var{:direct-color} images, a pixel mask. @item :height A @var{card16} for the image height in pixels. @item :name An optional @var{stringable} for the image name. @item :plist An optional image property list. @item :red-mask For @var{:true-color} or @var{:direct-color} images, a pixel mask. @item :width A @var{card16} for the image width in pixels. @item :x-hot For a @var{cursor} image, the x position of the hot spot. @item :y-hot For a cursor image, the y position of the hot spot. @end table Creates an @var{image} object from the given @var{:data} and returns either an @var{image}, @var{image-xy}, or an @var{image-z}, depending on the type of image @var{:data}. If the @var{:data} is a list, it is assumed to be a @var{list} of @var{bitmaps} and an @var{image-xy} is created. If the @var{:data} is a @var{pixarray}, an @var{image-z} is created. Otherwise, the @var{:data} must be an array of bytes (@var{card8}), in which case a basic @var{image} object is created. If the @var{:data} is a list, each element must be a bitmap of equal size. @var{:width} and @var{:height} default to the bitmap width -- (@var{array-dimension bitmap} 1) -- and the bitmap height -- (@var{array-dimension bitmap} 0) -- respectively. @var{:depth} defaults to the number of bitmaps. If the @var{:data} is a @var{pixarray}, @var{:width} and @var{:height} default to the @var{pixarray} width -- (@var{array-dimension pixarray} 1), and the pixarray height -- (@var{array-dimension pixarray} 0), respectively. @var{:depth} defaults to (@var{pixarray-depth} @var{:data}). The @var{:bits-per-pixel} is rounded to a valid size, if necessary. By default, the @var{:bits-per-pixel} is equal to the @var{:depth}. If the @var{:data} is an array of @var{card8}, the @var{:width} and @var{:height} are required to interpret the image data correctly. The @var{:bits-per-pixel} defaults to the @var{:depth}, and the @var{:depth} defaults to 1. @var{:bytes-per-line} defaults to: @lisp (@var{floor} (@var{length :data}) (* @var{:bits-per-pixel :height})) @end lisp The @var{:format} defines the storage format of image data bytes and can be one of the following values: @table @var @item :xy-pixmap The @var{:data} is organized as a set of bitmaps representing image bit planes, appearing in most-significant to least-significant bit order. @item :z-pixmap The @var{:data} is organized as a set of pixel values in scanline order. @item :bitmap Similar to @var{:xy-pixmap}, except that the @var{:depth} must be 1, and 1 and 0 bits represent the foreground and background pixels, respectively. @end table By default, the @var{:format} is @var{:bitmap} if @var{:depth} is 1; otherwise, @var{:z-pixmap}. @table @var Type @var{image}. @end table @end defun @defun copy-image image &key (:x 0) (:y 0) :width :height :result-type @table @var @item image An @var{image} object. @item :x @itemx :y @var{card16} values defining the position of the upper-left corner of the subimage copied. @item :width @itemx :height @var{card16} values defining the size of subimage copied. @item :result-type One of @var{'image-x}, @var{'image-xy}, or @var{'image-z}. @end table Returns a new image, of the given @var{:result-type}, containing a copy of the portion of the @emph{image} defined by @var{:x}, @var{:y}, @var{:width}, and @var{:height}. By default, @var{:width} is: @lisp (- (@var{image-width} @emph{image}) @var{:x}) @end lisp and @var{:height} is: @lisp (- (@var{image-height} @emph{image}) @var{:y}) @end lisp If necessary, the new image is converted to the @var{:result-type}, that can be one of the following values: @table @code @item 'image-x A basic @var{image} object is returned. @item 'image-xy An @var{image-xy} is returned. @item 'image-z An @var{image-z} is returned. @end table @table @var @item new-image Type @var{image}. @end table @end defun @defun get-image drawable &key :x :y :width :height :plane-mask (:format :z-format) :result-type Function @table @var @item drawable A @var{drawable}. @item :x @itemx :y @var{card16} values defining the upper-left @var{drawable} pixel returned. These arguments are required. @item :width @itemx :height @var{card16} values defining the size of the @emph{image} returned. These arguments are required. @item :plane-mask A pixel mask. @item :format Either @var{:xy-pixmap} or @var{:z-pixmap}. @item :result-type One of @var{'image-x}, @var{'image-xy}, or @var{'image-z}. @end table Returns an @emph{image} containing pixel values from the region of the @emph{drawable} given by @var{:x}, @var{:y}, @var{:width}, and @var{:height}. The bits for all planes selected by 1 bits in the @var{:plane-mask} are returned as zero; the default @var{:plane-mask} is all 1 bits. The @var{:format} of the returned pixel values may be either @var{:xy-format} or @var{:z-format}. The @var{:result-type} defines the type of image object returned: @table @code @item 'image-x A basic @var{image} object is returned. @item 'image-xy An @var{image-xy} is returned. @item 'image-z An @var{image-z} is returned. @end table By default, @var{:result-type} is @var{'image-z} if @var{:format} is @var{:z-format} and @var{'image-xy} if @var{:format} is @var{:xy-format}. @table @var Type @var{image}. @end table @end defun @defun put-image drawable gcontext image &key (:src-x 0) (:src-y 0) :x :y :width :height :bitmap-p @table @var @item drawable The destination @var{drawable}. @item gcontext The graphics context used to display the @emph{image}. @item image An @var{image} object. @item :src-x @itemx :src-y @var{card16} values defining the upper-left position of the @emph{image} region to display. @item :x @itemx :y The position in the @emph{drawable} where the @emph{image} region is displayed. These arguments are required. @item :width :height @var{card16} values defining the size of the @emph{image} region displayed. @item :bitmap-p If @emph{image} is depth 1, then if true, foreground and background pixels are used to display 1 and 0 bits of the @emph{image}. @end table Displays a region of the @emph{image} defined by @var{:src-x}, @var{:src-y}, @var{:width}, and @var{:height} on the destination d@emph{rawable}, with the upper-left pixel of the @emph{image} region displayed at the @emph{drawable} position given by @var{:x} and @var{:y}. By default, @var{:width} is: @lisp (- (@var{image-width} @emph{image}) @var{:src-x}) @end lisp and @var{:height} is: @lisp (- (@var{image-height} @emph{image}) @var{:src-y}) @end lisp The following attributes of the @emph{gcontext} are used to display the @var{image}: clip-mask, clip-x, clip-y, function, plane-mask, and subwindow-mode. The @var{:bitmap-p} argument applies only to images of depth 1. In this case, if @var{:bitmap-p} is true or if the @emph{image} is a basic @var{image} object created with @var{:format :bitmap}, the @emph{image} is combined with the foreground and background pixels of the @var{gcontext}. 1 bits of the @emph{image} are displayed in the foreground pixel and 0 bits are displayed in the background pixel. @end defun @node Image Files, Direct Image Transfer, Image Functions, Images @section Image Files CLX provides functions that allow images to be written to a file in a standard X format. The following paragraphs describe the CLX functions used to: @itemize @bullet @item Read an image from a file. @item Write an image to a file. @end itemize @defun read-bitmap-file pathname @table @var @item pathname An image file pathname. @end table Reads an image file in standard X format and returns an @var{image} object. The returned @emph{image} can have depth greater than one. @table @var @item image Type @var{image}. @end table @end defun @defun write-bitmap-file pathname image &optional name @table @var @item pathname An image file pathname. @item image An @var{image} object. @item name A @var{stringable} image name. @end table Writes the @emph{image} to an image file in standard X format. The @emph{image} can have depth greater than one. The @emph{name} is an image identifier written to the file; the default @emph{name} is (@var{or} (@var{image-name} @emph{image}) @var{'image}). @end defun @node Direct Image Transfer, , Image Files, Images @section Direct Image Transfer For cases where the @var{image} representation is not needed, CLX provides functions to read and display image data directly. @defun get-raw-image drawable &key :data (:start 0) :x :y :width :height :plane-mask (:format :z-format) (:result-type '(vector card8)) @table @var @item drawable A @var{drawable}. @item :data An optional @var{sequence} of @var{card8}. @item :start The index of the first @var{:data} element modified. @item :x @itemx :y @var{card16} values defining the size of the @var{image} returned. These arguments are required. @item :width @itemx :height @var{card16} values defining the size of the image returned.These arguments are required. @item :plane-mask A pixel mask. @item :format Either @var{:xy-pixmap} or @var{:z-pixmap}. This argument is required. @item :result-type The type of image data sequence to return. @end table Returns a sequence of image data from the region of the @emph{drawable} given by @var{:x}, @var{:y}, @var{:width}, and @var{:height}. If @var{:data} is given, it is modified beginning with the element at the @var{:start} index and returned. The @emph{depth} and @emph{visua}l type ID of the @emph{drawable} are also returned. The bits for all planes selected by 1 bits in the @var{:plane-mask} are returned as zero; the default @var{:plane-mask} is all 1 bits. The @var{:format} of the returned pixel values may be either @var{:xy-format} or @var{:z-format}. The @var{:result-type} defines the type of image data returned. The calling program is responsible for handling the byte-order and bit-order returned by the server for the @emph{drawable}'s display (see @var{display-byte-order} and @var{display-image-lsb-first-p}). @table @var @item data Type @var{sequence} or @var{card8}. @item depth Type @var{card8}. @item visual Type @var{card29}. @end table @end defun @defun put-raw-image drawable gcontext data &key (:start 0) :depth :x :y :width :height (:left-pad 0) :format @table @var @item drawable The destination @var{drawable}. @item gcontext The graphics context used to display the image. @item data A sequence of integers. @item :start The index of the first element of @emph{data} displayed. @item :depth The number of bits per pixel displayed. This argument is required. @item :x @itemx :y The position in the @emph{drawable} where the image region is displayed. These arguments are required. @item :width @itemx :height @var{card16} values defining the size of the image region displayed. These arguments are required. @item :left-pad A @var{card8} specifying the number of leading bits to discard for each image scanline. @item :format One of @var{:bitmap}, @var{:xy-pixmap}, or @var{:z-pixmap}. @end table Displays a region of the image data defined by @var{:start}, @var{:left-pad}, @var{:width}, and @var{:height} on the destination @emph{drawable}, with the upper-left pixel of the image region displayed at the @emph{drawable} position given by @var{:x} and @var{:y}. The @var{:format} can be either @var{:xy-pixmap}, @var{:z-pixmap}, or @var{:bitmap}. If @var{:xy-pixmap} or @var{:z-pixmap} formats are used, @var{:depth} must match the depth of the destination @emph{drawable}. For @var{:xy-pixmap}, the data must be in XY format. For @var{:z-pixmap}, the data must be in Z format for the given @var{:depth}. If the @var{:format} is @var{:bitmap}, the @var{:depth} must be 1. In this case, the image is combined with the foreground and background pixels of the @emph{gcontext}. 1 bits of the image are displayed in the foreground pixel and 0 bits are displayed in the background pixel. The @var{:left-pad} must be zero for @var{:z-pixmap} format. For @var{:bitmap} and @var{:xy-pixmap} formats, the @var{:left-pad} must be less than the bitmap-scanline-pad for the @emph{drawable}'s display (@pxref{display-bitmap-format}). The first @var{:left-pad} bits in every scanline are to be ignored by the server; the actual image begins that many bits into the data. The following attributes of the @emph{gcontext} are used to display the @var{image}: clip-mask, clip-x, clip-y, function, plane-mask, and subwindow-mode. The calling program is responsible for handling the byte-order and bit-order required by the server for the @emph{drawable}'s display (see @var{display-byte-order} and @var{display-image-lsb-first-p}). @end defun @node Font and Characters, Colors, Images, Top @chapter Font and Characters An X server maintains a set of fonts used in the text operations requested by client programs. An X font is an array of character bit maps (or @emph{glyphs}) indexed by integer codes. In fact, font glyphs can also represent cursor shapes or other images and are not limited to character images. X supports both linear and matrix encoding of font indexes. With linear encoding, a font index is interpreted as a single 16-bit integer index into a one-dimensional array of glyphs. With matrix encoding, a font index is interpreted as a pair of 8-bit integer indexes into a two-dimensional array of glyphs. The type of index encoding used is font-dependent. In order to access or use a font, a client program must first open it using the @var{open-font} function, sending a font name string as an identifier. @var{open-font} creates a CLX @var{font} object used to refer to the font in subsequent functions. Afterward, calling @var{open-font} with the same font name returns the same @var{font} object. When a font is no longer in use, a client program can call @var{close-font} to destroy the @var{font} object. A font has several attributes which describe its geometry and its glyphs. CLX provides functions to return the attributes of a font, as well functions for accessing the attributes of individual font glyphs. Glyph attributes are referred to as @emph{character attributes}, since characters are the most common type of font glyphs. A font also has a property list of values recorded by the X server. However, the set of possible font properties and their values are not standardized and are implementation-dependent. Typically, CLX maintains a cache of font and character attributes, in order to minimize server requests. However, the font cache mechanism is implementation-dependent and cannot be controlled by the client. In some cases, CLX may create a @emph{pseudo-font} object solely for the purpose of accessing font attributes. A pseudo-font is represented by a special type of @var{font} object that cannot be used in a @var{gcontext}. If necessary, CLX can automatically convert a pseudo-font into a true font, if the name of the pseudo-font is known. The set of available fonts is server-dependent; that is, font names are not guaranteed to be portable from one server to the next. However, the public X implementation from MIT includes a set of fonts that are typically available with most X servers. The following paragraphs describe CLX functions to: @itemize @bullet @item Open and close fonts. @item List available fonts. @item Access font attributes. @item Access character attributes. @item Return the size of a text string. @end itemize @menu * Opening Fonts:: * Listing Fonts:: * Font Attributes:: * Chracter Attributes:: * Querying Text Size:: @end menu @node Opening Fonts, Listing Fonts, Font and Characters, Font and Characters @section Opening Fonts The following paragraphs discuss the CLX functions for opening and closing fonts. @defun open-font display name @table @var @item display A @var{display} object. @item name A font name string. @end table Opens the font with the given @emph{name} and returns a @var{font} object. The name string should contain only ISO Latin-1 characters; case is not significant. @table @var @item font Type @var{font}. @end table @end defun @defun close-font font @table @var @item font A @var{font} object. @end table Deletes the association between the resource ID and the @emph{font}. The @emph{font} is freed when no other server resource references it. The @emph{font} can be unloaded by the X server if this is the last reference to the @emph{font} by any client. In any case, the @emph{font} should never again be referenced because its resource ID is destroyed. This might not generate a protocol request if the @emph{font} is reference-counted locally or if it is a pseudo-font. @end defun @defun discard-font-info fonts @table @var @item font A @var{font} object. @end table Discards any state that can be re-obtained with @var{open-font}. This is simply a performance hint for memory-limited systems. @end defun @node Listing Fonts, Font Attributes, Opening Fonts, Font and Characters @section Listing Fonts The following paragraphs describe CLX functions that return fonts or font names that match a given pattern string. Such pattern strings should contain only ISO Latin-1 characters; case is not significant. The following pattern characters can be used for @emph{wildcard} matching: @table @code @item #\* Matches any sequence of zero or more characters. @item #\? Matches any single character. @end table For example, the pattern "T?mes Roman" matches the name "Times Roman" but not the name "Thames Roman". However, the pattern "T*mes Roman" matches both names. @defun font-path display &key (:result-type 'list) @table @var @item display A @var{display} object. @item :result-type Specifies the type of resulting sequence. @end table Returns a @var{list} (by default) of names containing the current search path for fonts. With @code{setf}, this function sets the search path for font lookup. There is only one search path per server, not one per client. The interpretation of the names is server-dependent, but they are intended to specify directories to be searched in the order listed. Setting the path to the empty list restores the default path defined for the server. Note that as a side-effect of executing this request, the server is guaranteed to flush all cached information about fonts for which there are currently no explicit resource IDs allocated. @table @var @item paths Type @var{sequence} of either @var{string} or @var{pathname}. @end table @end defun @defun list-font-names display pattern &key (:max-fonts 65535) (:result-type 'list) @table @var @item display A @var{display} object. @item pattern A string used to match font names. Only font names that match the pattern are returned. @item :max-fonts The maximum number of font names returned. Default is 65535. @item :result-type The type of sequence to return. Default is '@var{list}. @end table Returns a sequence of strings containing the font names that match the @emph{pattern}. The fonts available are determined by the font search path; see @var{font-path}). The maximum number of font names returned is determined by @var{:max-fonts}. @table @var @item font-name Type @var{sequence} of @var{string}. @end table @end defun @defun list-fonts display pattern &key (:max-fonts 65535) (:result-type 'list) @table @var @item display A @var{display} object. @item pattern A string used to match font names. Only fonts whose name matches the pattern are returned. @item :max-fonts The maximum number of fonts returned. Default is 65535. @item :result-type The type of sequence to return. Default is @var{'list}. @end table Returns a sequence of pseudo-fonts corresponding to the available fonts whose names match the @emph{pattern}. The fonts available are determined by the font search path; see @var{font-path}). The maximum number of @var{font} objects returned is determined by @var{:max-fonts}. @table @var @item font Type @var{sequence} of @var{font}. @end table @end defun @node Font Attributes, Chracter Attributes, Listing Fonts, Font and Characters @section Font Attributes The following paragraphs describe the CLX functions used to access font attributes. @defun font-all-chars-exist-p font @table @var @item exists-p Type @var{boolean}. @end table Returns true if glyphs exist for all indexes in the range returned by @var{font-min-char} and @var{font-max-char}. Returns @var{nil} if an index in the range corresponds to empty glyph. @table @var @item font A @var{font} object. @end table @end defun @defun font-ascent font @table @var @item ascent Type @var{int16}. @end table Returns the vertical @emph{ascent} of the @emph{font} used for interline spacing. The @emph{ascent} defines the nominal distance in pixels from the baseline to the bottom of the previous line of text. Some font glyphs may actually extend beyond the font @emph{ascent}. @table @var @item font A @var{font} object. @end table @end defun @defun font-default-char font @table @var @item index Type @var{card16}. @end table Returns the @emph{index} of the glyph drawn when an invalid or empty glyph index is specified. If the default index specifies an invalid or empty glyph, an invalid or empty index has no effect. @table @var @item font A @var{font} object. @end table @end defun @defun font-descent font @table @var @item descent Type @var{int16}. @end table Returns the vertical @emph{descent} of the @emph{font} used for interline spacing. The @emph{descent} defines the nominal distance in pixels from the baseline to the top of the next line of text. Some font glyphs may actually extend beyond the font @emph{descent}. @table @var @item font A @var{font} object. @end table @end defun @defun font-direction font @table @var @item direction Type @var{draw-direction}. @end table Returns the nominal drawing @emph{direction} for the @emph{font}. The font drawing direction is only a hint that indicates whether the @emph{char-width} of most font glyphs is positive (@var{:left-to-right} direction) or negative (@var{:right-to-left} direction). Note that X does not provide any direct support for vertical text. @table @var @item font A @var{font} object. @end table @end defun @defun font-display font @table @var @item font A @var{font} object. @end table Returns the @var{display} object associated with the specified @emph{font}. @table @var @item display Type @var{display}. @end table @end defun @defun font-equal font-1 font-2 @table @var @item font-1 @itemx font-2 The @var{font} objects. @end table Returns true if the two arguments refer to the same server resource and @var{nil} if they do not. @end defun @defun font-id font @table @var @item font A @var{font} object. @end table Returns the unique resource ID assigned to the specified @emph{font}. @table @var @item id Type @var{resource-id}. @end table @end defun @defun font-max-byte1 font @table @var @item font A @var{font} object. @end table Returns zero if the @emph{font} uses linear index encoding. Otherwise, if the @emph{font} uses matrix index encoding, a value between 1 and 255 is returned that specifies the maximum value for the most significant byte of font indexes. @table @var @item max-byte1 Type @var{card8}@emph{.} @end table @end defun @defun font-max-byte2 font @table @var @item font A @var{font} object. @end table Returns zero if the @emph{font} uses linear index encoding. Otherwise, if the @emph{font} uses matrix index encoding, a value between 1 and 255 is returned that specifies the maximum value for the least significant byte of font indexes. @table @var @item max-byte2 Type @var{card8}@emph{.} @end table @end defun @defun font-max-char font @table @var @item font A @var{font} object. @end table Returns the maximum valid value used for linear encoded indexes. This function is not meaningful for fonts that use matrix index encoding. @table @var @item index Type @var{card16}. @end table @end defun @defun font-min-byte1 font @table @var @item font A @var{font} object. @end table Returns zero if the @emph{font} uses linear index encoding. Otherwise, if the @emph{font} uses matrix index encoding, a value between 1 and 255 is returned that specifies the minimum value for the most significant byte of font indexes. @table @var @item min-byte1 Type @var{card8}. @end table @end defun @defun font-min-byte2 font @table @var @item font A @var{font} object. @end table Returns zero if the @emph{font} uses linear index encoding. Otherwise, if the @emph{font} uses matrix index encoding, a value between 1 and 255 is returned that specifies the minimum value for the least significant byte of font indexes. @table @var @item min-byte2 Type @var{card8}. @end table @end defun @defun font-min-char font @table @var @item font A @var{font} object. @end table Returns the minimum valid value used for linear encoded indexes. This function is not meaningful for fonts that use matrix index encoding. @table @var @item index Type @var{card16}. @end table @end defun @defun font-name font @table @var @item font A @var{font} object. @end table Returns the name of the @emph{font}, or @var{nil} if @emph{font} is a pseudo-font. @table @var @item name Type @var{string} or @var{null}. @end table @end defun @defun font-p font Returns true if the argument is a @var{font} object and @var{nil} otherwise. @table @var @item font-p Type @var{boolean}. @end table @end defun @defun font-plist font @table @var @item font A @var{font} object. @end table Returns and (with @code{setf}) sets the property list for the specified @emph{font}. This function provides a hook where extensions can add data. @table @var @item plist Type @var{list}. @end table @end defun @defun font-properties font @table @var @item font A @var{font} object. @end table Returns the list of font @emph{properties} recorded by the X server. The returned list is a property list of keyword/value pairs. The set of possible font property keywords is implementation-dependent. @table @var @item properties Type @var{list}. @end table @end defun @defun font-property font name @table @var @item font A @var{font} object. @item name A font property keyword. @end table Returns the value of the font @emph{property} specified by the @emph{name} keyword. The property value, if it exists, is returned as an uninterpreted 32-bit integer. @table @var @item property Type @var{int32} or @var{null}. @end table @end defun @defun max-char-ascent font @table @var @item font A @var{font} object. @end table Returns the maximum @var{char-ascent} value for all characters in @emph{font}. @table @var @item ascent Type @var{int16}. @end table @end defun @defun max-char-attributes font @table @var @item font A @var{font} object. @end table Returns the maximum @var{char-attributes} value for all characters in @emph{font}. @table @var @item attributes Type @var{int16}. @end table @end defun @defun max-char-descent font @table @var @item font A @var{font} object. @end table Returns the maximum @var{char-descent} value for all characters in @emph{font}. @table @var @item descent Type @var{int16}. @end table @end defun @defun max-char-left-bearing font @table @var @item font A @var{font} object. @end table Returns the maximum @var{char-left-bearing} value for all characters in @emph{font}. @table @var @item left-bearing Type @var{int16}. @end table @end defun @defun max-char-right-bearing font @table @var @item font A @var{font} object. @end table Returns the maximum @var{char-right-bearing} value for all characters in @emph{font}. @table @var @item right-bearing Type @var{int16}. @end table @end defun @defun max-char-width font @table @var @item font A @var{font} object. @end table Returns the maximum @var{char-width} value for all characters in @emph{font}. @table @var @item width Type @var{int16}. @end table @end defun @defun min-char-ascent font @table @var @item font A @var{font} object. @end table Returns the minimum @var{char-ascent} for all characters in @emph{font}. @table @var @item ascent Type @var{int16}. @end table @end defun @defun min-char-attributes font @table @var @item font A @var{font} object. @end table Returns the minimum @var{char-attributes} for all characters in @emph{font}. @table @var @item attributes Type @var{int16}. @end table @end defun @defun min-char-descent font @table @var @item font A @var{font} object. @end table Returns the minimum @var{char-descent} for all characters in @emph{font}. @table @var @item descent Type @var{int16}. @end table @end defun @defun min-char-left-bearing font @table @var @item font A @var{font} object. @end table Returns the minimum @var{char-left-bearing} for all characters in @emph{font}. @table @var @item left-bearing Type @var{int16}. @end table @end defun @defun min-char-right-bearing font @table @var @item font A @var{font} object. @end table Returns the minimum @var{char-right-bearing} for all characters in @emph{font}. @table @var @item right-bearing Type @var{int16}. @end table @end defun @defun min-char-width font @table @var @item font A @var{font} object. @end table Returns the minimum @var{char-width} for all characters in @emph{font}. @table @var @item width Type @var{int16}. @end table @end defun @node Chracter Attributes, Querying Text Size, Font Attributes, Font and Characters @section Chracter Attributes The following paragraphs describe the CLX functions used to access the attributes of individual font glyphs. @defun char-ascent font index @table @var @item font A @var{font} object. @item index An @var{int16} font index. @end table Returns the vertical distance in pixels from the baseline to the top of the given font glyph. Returns @var{nil} if the index is invalid or specifies an empty glyph, or if the @emph{font} is a pseudo-font. @table @var @item ascent Type @var{int16} or @var{null}. @end table @end defun @defun char-attributes font index @table @var @item font A @var{font} object. @item index An @var{int16} font index. @end table Returns font-specific @emph{attributes} of the given glyph. The interpretation of such attributes is server-dependent. Returns @var{nil} if the @emph{index} is invalid or specifies an empty glyph, or if the @emph{font} is a pseudo-font. @table @var @item attributes Type @var{int16} or @var{null}. @end table @end defun @defun char-descent font index @table @var @item font A @var{font} object. @item index An @var{int16} font index. @end table Returns the vertical distance in pixels from the baseline to the bottom of the given font glyph. Returns @var{nil} if the @emph{index} is invalid or specifies an empty glyph, or if the @emph{font} is a pseudo-font. @table @var @item descent Type @var{int16} or @var{null}. @end table @end defun @defun char-left-bearing font index @table @var @item font A @var{font} object. @item index An @var{int16} font index. @end table Returns the left side bearing of the given font glyph. If @var{draw-glyph} is called with horizontal position @emph{x}, the leftmost pixel of the glyph is drawn at the position (+ @emph{x left-bearing}). Returns @var{nil} if the @emph{index} is invalid or specifies an empty glyph, or if the @emph{font} is a pseudo-font. @table @var @item left-bearing Type @var{int16} or @var{null}. @end table @end defun @defun char-right-bearing font index @table @var @item font A @emph{font} object. @item index An @var{int16} font index. @end table Returns the right side bearing of the given font glyph. If n@var{draw-glyph} is called with horizontal position @emph{x}, the rightmost pixel of the glyph is drawn at the position (+ @emph{x rightbearing}). Returns @var{nil} if the @emph{index} is invalid or specifies an empty glyph, or if the @emph{font} is a pseudo-font. @table @var @item right-bearing Type @var{int16} or @var{null}. @end table @end defun @defun char-width font index @table @var @item font A @var{font} object. @item index An @var{int16} font index. @end table Returns the @emph{width} of the given font glyph. The @emph{width} is defined to be equal to (- @emph{rightbearing left-bearing}). Returns @var{nil} if the @emph{index} is invalid or specifies an empty glyph, or if the @emph{font} is a pseudo-font. @table @var @item width Type @var{int16} or @var{null}. @end table @end defun @node Querying Text Size, , Chracter Attributes, Font and Characters @section Querying Text Size CLX defines functions to return the size of text drawn in a specified font. @xref{Drawing Text}, for a description of the @var{:translate} function used by the functions in the following paragraphs. @defun text-extents font sequence &key (:start 0) :end :translate @anchor{text-extents} @table @var @item font The font (or @var{gcontext}) used for measuring characters. @item sequence A sequence of characters or other objects to be translated into font indexes. @item :start @itemx :end Start and end indexes defining the elements to draw. @item :translate A function to translate text to font indexes. Default is @var{#'translate-default}. @end table Returns the complete geometry of the given @emph{sequence} when drawn in the given @emph{fon}t. The @emph{font} can be a @var{gcontext}, in which case the font attribute of the given graphics context is used. @var{:start} and @var{:end} define the elements of the @emph{sequence} which are used. The returned @emph{width} is the total pixel width of the translated character sequence. The returned @emph{ascent} and @emph{descent} give the vertical ascent and descent for characters in the translated @emph{sequence}. The returned @emph{left} gives the left bearing of the leftmost character. The returned @emph{right} gives the right bearing of the rightmost character. The returned @emph{font-ascent} and @emph{font-descent} give the maximum vertical ascent and descent for all characters in the @emph{fon}t. If @var{:translate} causes font changes, then @emph{font-ascent} and @emph{font-descent} will be the maximums over all fonts used. The @emph{direction} returns the preferred draw direction for the font. If @var{:translate} causes font changes, then the @emph{direction} will be @var{nil}. The @emph{first-not-done} value returned is @var{nil} if all elements of the @emph{sequence} were successfully translated; otherwise the index of the first untranslated element is returned. @table @var @item width Type @var{int32}. @item ascent Type @var{int16}. @item descent Type @var{int16}. @item left Type @var{int32}. @item right Type @var{int32}. @item font-ascent Type @var{int16}. @item direction Type @var{draw-direction}. @item first-not-done Type @var{array-index} or @var{null}. @end table @end defun @defun text-width font sequence &key (:start 0) :end :translate @table @var @item font The font (or @var{gcontext}) used for measuring characters. @item sequence A sequence of characters or other objects to be translated into font indexes. @item :start @item :end Start and end indexes defining the elements to draw. @item :translate A function to translate text to font indexes. Default is @var{#'translate-default}. @end table Returns the total pixel width of the given @emph{sequence} when drawn in the given @emph{font}. The @emph{font} can be a @var{gcontext}, in which case the font attribute of the given graphics context is used. @var{:start} and @var{:end} define the elements of the @emph{sequence} which are used. The second value returned is @var{nil} if all elements of the @emph{sequence} were successfully translated; otherwise the index of the first untranslated element is returned. @table @var @item width Type @var{int32}. @item first-not-done Type @var{array-index} or @var{null}. @end table @end defun @node Colors, Cursors, Font and Characters, Top @chapter Colors @menu * Colormaps and Colors:: * Color Functions:: * Colormap Functions:: @end menu @node Colormaps and Colors, Color Functions, Colors, Colors @section Colormaps and Colors In X, a @emph{color} is defined by a set of three numeric values, representing intensities of red, green, and blue. Red, green, and blue are referred to as the @emph{primary} hues. A @emph{colormap} is a list of colors, each indexed by an integer @emph{pixel} value. Each entry in a colormap is called a color @emph{cell}. Raster graphics displays store pixel values in a special screen hardware memory. As the screen hardware scans this memory, it reads each pixel value, looks up the color in the corresponding cell of a colormap, and displays the color on its screen. The colormap abstraction applies to all classes of visual types supported by X, including those for screens which are actually monochrome. For example, @var{:gray-scale} screens use colormaps in which colors actually specify the monochrome intensity. A typical black-and-white monochrome display has a @var{:static-gray} screen with a two-cell colormap. The following list describes how pixel values and colormaps are handled for each visual class. @table @var @item :direct-color A pixel value is decomposed into separate red, green, and blue subfields. Each subfield indexes a separate colormap. Entries in all colormaps can be changed. @item :gray-scale A pixel value indexes a single colormap that contains monochrome intensities. Colormap entries can be changed. @item :pseudo-color A pixel value indexes a single colormap that contains color intensities. Colormap entries can be changed. @item :static-color Same as @var{:pseudo-color}, except that the colormap entries are predefined by the hardware and cannot be changed. @item :static-gray Same as @var{:gray-scale}, except that the colormap entries are predefined by the hardware and cannot be changed. @item :true-color Same as @var{:direct-color}, except that the colormap entries are predefined by the hardware and cannot be changed. Typically, each of the red, green, and blue colormaps provides a (near) linear ramp of intensity. @end table CLX provides functions to create colormaps, access and modify colors and color cells, and install colormaps in screen hardware. @node Color Functions, Colormap Functions, Colormaps and Colors, Colors @section Color Functions A color is represented by a CLX color object, in which each of the red, green, and blue values is specified by an @var{rgb-val} -- a floating point number between 0.0 and 1.0. (@pxref{Data Types}). The value 0.0 represents the minimum intensity, while 1.0 represents the maximum intensity. CLX automatically converts @var{rgb-val} values into 16-bit integers when sending colors to an X server. The X server, in turn, scales 16-bit color values to match the actual intensity range supported by the screen. Colors used on @var{:gray-scale} screens must have the same value for each of red, green, and blue. Only one of these values is used by screen hardware to determine intensity; however, CLX does not define which of red, green, or blue is actually used. The following paragraphs describe the CLX functions used to create, access, and modify colors. @defun make-color &key (:blue 1.0) (:green 1.0) (:red 1.0) &allow-other-keys @table @var @item :blue @itemx :green @itemx :red @var{rgb-val} values that specify the saturation for each primary. @end table Creates, initializes, and returns a new @var{color} object with the specified values for red, green, and blue. @table @var @item color Type @var{color}. @end table @end defun @defun color-blue color @table @var @item color A @var{color} object. @end table Returns and (with @code{setf}) sets the value for blue in the @emph{color}. @table @var @item blue-intensity Type @var{rgb-val}. @end table @end defun @defun color-green color @table @var @item color A @var{color} object. @end table Returns and (with @code{setf}) sets the value for green in the @emph{color}. @table @var @item green-intensity Type @var{rgb-val}. @end table @end defun @defun color-p color Returns non-@var{nil} if the argument is a @var{color} object and @var{nil} otherwise. @table @var @item color-p Type @var{boolean}. @end table @end defun @defun color-red color @table @var @item color A @var{color} object. @end table Returns and (with @code{setf}) sets the value for red in the @emph{color}. @table @var @item red-intensity Type @var{rgb-val}. @end table @end defun @defun color-rgb color @table @var @item color A @var{color} object. @end table Returns the values for red, green, and blue in the @emph{color}. @table @var @item red @itemx green @itemx blue Type @var{rgb-val}. @end table @end defun @node Colormap Functions, , Color Functions, Colors @section Colormap Functions A colormap is represented in CLX by a @var{colormap} object. A CLX program can create and manipulate several @var{colormap} objects. However, the colors contained in a @var{colormap} are made visible only when the @var{colormap} is @emph{installed}. Each window is associated with a @var{colormap} that is used to translate window pixels into colors (see @var{window-colormap}). However, a window will appear in its true colors only if its associated @var{colormap} is installed. The total number of colormaps that can be installed depends on the screen hardware. Most hardware devices allow exactly one @var{colormap} to be installed at any time. That is, @var{screen-min-installed-maps} and @var{screen-max-installed-maps} are both equal to 1. Installing a new @var{colormap} can cause a previously installed @var{colormap} to be uninstalled. It is important to remember that the set of installed @var{colormaps} is a hardware resource shared cooperatively among all client programs connected to an X server. A CLX program can control the contents of @var{colormaps} by allocating color cells in one of two ways: read-only or read-write. Allocating a read-only color cell establishes a color value for a specified pixel value that cannot be changed. However, read-only color cells can be shared among all client programs. Read-only allocation is the best strategy for making use of limited @var{colormap} hardware in a multi-client environment. Alternatively, allocating a read-write color cell allows a client the exclusive right to set the color value stored in the cell. A cell allocated read-write by one client cannot be allocated by another client, not even as a read-only cell. Note that read-write allocation is not allowed for screens whose visual type belongs to one of the @var{:static-gray}, @var{:static-color}, or @var{:true-color} classes. For screens of these classes, @var{colormap} cells cannot be modified. Two entries of the default colormap, typically containing the colors black and white, are automatically allocated read-only. The pixel values for these entries can be returned by the functions @var{screen-black-pixel} and @var{screen-white-pixel}. Applications that need only two colors and also need to operate on both monochrome and color screens should always use these pixel values. The names @emph{black} and @emph{white} are intended to reflect relative intensity levels and need not reflect the actual colors displayed for these pixel values. Each screen has a default @var{colormap}, which is initially installed. By conventions, clients should allocate only read-only cells from the default @var{colormap}. @menu * Creating Colormaps:: * Installing Colormaps:: * Allocating Colors:: * Finding Colors:: * Changing Colors:: * Colormap Attributes:: @end menu @node Creating Colormaps, Installing Colormaps, Colormap Functions, Colormap Functions @subsection Creating Colormaps CLX provides functions for creating and freeing new @var{colormap} objects. @defun create-colormap visual window &optional alloc-p @table @var @item visual A @var{visual} type ID. @item window A @var{window}. @item alloc-p Specifies whether @var{colormap} cells are permanently allocated read-write. @end table Creates and returns a @emph{colormap} of the specified @emph{visual} type for the screen containing the @emph{window}. The @emph{visual} type must be one of those supported by the screen. Initial color cell values are undefined for visual types belonging to the @var{:gray-scale}, @var{:pseudo-color}, and @var{:direct-color} classes. Color cell values for visual types belonging to the @var{:static-gray}, @var{:static-color}, and @var{:true-color} classes have initial values defined by the visual type. However, X does not define the set of possible visual types or their initial color cell values. If @emph{alloc-p} is true, all colormap cells are permanently allocated read-write and cannot be freed by @var{free-colors}. It is an error for @emph{alloc-p} to be true when the visual type belongs to the @var{:static-gray}, @var{:static-color}, or @var{:true-color} classes. @table @var @item colormap Type @var{colormap}. @end table @end defun @defun copy-colormap-and-free colormap @table @var @item colormap A @var{colormap}. @end table Creates and returns a new @var{colormap} by copying, then freeing, allocated cells from the specified @emph{colormap}. All color cells allocated read-only or read-write in the original @var{colormap} have the same color values and the same allocation status in the @emph{new-colormap}. The values of unallocated color cells in the @emph{new-colormap} are undefined. After copying, all allocated color cells in the original @var{colormap} are freed, as if @var{free-colors} was called. The unallocated cells of the original @var{colormap} are not affected. If @emph{alloc-p} was true when the original @var{colormap} was created, then all color cells of the @emph{new-colormap} are permanently allocated read-write, and all the color cells of the original @var{colormap} are freed. @table @var @item new-colormap Type @var{colormap}. @end table @end defun @defun free-colormap colormap @table @var @item colormap A @var{colormap}. @end table Destroys the @emph{colormap} and frees its server resource. If the @emph{colormap} is installed, it is uninstalled. For any window associated with the @emph{colormap}, the window is assigned a @var{nil} @var{colormap}, and a @var{:colormap-notify} event is generated. The colors displayed for a window with a @var{nil colormap} are undefined. However, this function has no effect if the @emph{colormap} is a screen default @var{colormap}. @end defun @node Installing Colormaps, Allocating Colors, Creating Colormaps, Colormap Functions @subsection Installing Colormaps The following paragraphs describe the CLX functions to install and uninstall colormaps and to return the set of installed colormaps. Initially, the default @var{colormap} for a screen is installed (but is not in the required list). @defun install-colormap colormap @anchor{install-colormap} @table @var @item colormap A @var{colormap}. @end table Installs the @emph{colormap.} All windows associated with this @emph{colormap} immediately display with true colors. As a side-effect, additional colormaps might be implicitly uninstalled by the server. If the specified @emph{colormap} is not already installed, a @var{:colormap-notify} event is generated on every window associated with this @emph{colormap}. In addition, for every other colormap that is implicitly uninstalled, a @var{:colormap-notify} event is generated on every associated window. @end defun @defun installed-colormaps window &key (:result-type 'list) @table @var @item window A @var{window}. @item :result-type A sub-type of @var{sequence} that indicates the type of sequence to return. @end table Returns a sequence containing the installed @var{colormaps} for the screen of the specified @emph{window}. The order of the colormaps is not significant. @table @var @item colormap Type @var{sequence} of @var{colormap}. @end table @end defun @defun uninstall-colormap colormap @table @var @item colormap A @var{colormap}. @end table Uninstalls the @emph{colormap}. However, the @emph{colormap} is not actually uninstalled if this would reduce the set of installed colormaps below the value of @var{screen-min-installed-maps}. If the @emph{colormap} is actually uninstalled, a @var{:colormap-notify} event is generated on every associated window. @end defun @node Allocating Colors, Finding Colors, Installing Colormaps, Colormap Functions @subsection Allocating Colors The following paragraphs describe the functions for allocating read-only and read-write color cells, allocating color planes, and freeing color cells. @defun alloc-color colormap color @table @var @item colormap A @var{colormap}. @item color A @var{color} object or a @var{stringable} containing a color name. @end table Returns a @emph{pixel} for a read-only color cell in the @emph{colormap}. The color in the allocated cell is the closest approximation to the requested @emph{color} possible for the screen hardware. The other values returned give both the approximate color stored in the cell and the exact color requested. The requested @emph{color} can be either a @var{color} object or a @var{stringable} containing a color name. If a color name is given, a corresponding color value is looked up (see @var{lookup-color}) and used. Color name strings must contain only ISO Latin-1 characters; case is not significant. @table @var @item pixel Type @var{pixel}. @item screen-color @itemx exact-color Type @var{color}. @end table @end defun @defun alloc-color-cells colormap colors &key (:planes 0) :contiguous-p (:result-type 'list) @table @var @item colormap A @var{colormap}. @item colors A positive number defining the length of the pixels sequence returned. @item :planes A non-negative number defining the length of the masks sequence returned. @item :contiguous-p If true, the masks form contiguous sets of bits. @item :result-type A subtype of @var{sequence} that indicates the type of sequences returned. @end table Returns a @var{sequence} of @emph{pixels} for read-write color cells in the @emph{colormap}. The allocated cells contain undefined color values. The visual type class of the @var{colormap} must be either @var{:gray-scale}, @var{:pseudo-color}, or @var{:direct-color}. The @emph{colors} argument and the @var{:planes} argument define the number of pixels and the number of masks returned, respectively. The number of colors must be positive, and the number of planes must be non-negative. A total of (* @emph{colors} (@var{expt} 2 @emph{planes})) color cells are allocated. The pixel values for the allocated cells can be computed by combining the returned pixels and masks. The length of the returned masks sequence is equal to @var{:planes}. Each mask of the returned masks sequence defines a single bitplane. None of the masks have any 1 bits in common. Thus, by selectively combining masks with @var{logior}, (@var{expt} 2 @emph{planes}) distinct combined plane masks can be computed. The length of the returned @emph{pixels} sequence is equal to @emph{colors}. None of the pixels have any 1 bits in common with each other or with any of the returned masks. By combining pixels and plane masks with @var{logior}, (* @emph{colors} (@var{expt} 2 @emph{planes})) distinct pixel values can be produced. If the @emph{colormap} class is @var{:gray-scale} or @var{:pseudo-color}, each @emph{mask} will have exactly one bit set. If the @var{colormap} class is @var{:direct-color}, each @emph{mask} will have exactly three bits set. If @var{:contiguous-p} is true, combining all masks with @var{logior} produces a plane mask with either one set of contiguous bits (for @var{:gray-scale} and @var{:pseudo-color}) or three sets of contiguous bits (for @var{:direct-color}). @table @var @item pixels @itemx mask Type @var{sequence} of @var{pixels}. @end table @end defun @defun alloc-color-planes colormap colors &key (:reds 0) (:greens 0) (:blues 0) :contiguous-p (:result-type 'list) @table @var @item colormap A @var{colormap}. @item colors A positive number defining the length of the pixels sequence returned. @item :planes A non-negative number defining the length of the masks sequence returned. @item :contiguous-p If true, then the masks form contiguous sets of bits. @item :result-type A subtype of @var{sequence} that indicates the type of sequences returned. @end table Returns a @var{sequence} of @emph{pixels} for read-write color cells in the @emph{colormap}. The allocated cells contain undefined color values. The visual type class of the @emph{colormap} must be either @var{:gray-scale}, @var{:pseudo-color}, or @var{:direct-color}. The @emph{colors} argument defines the number of pixels returned. The @var{:reds}, @var{:greens}, and @var{:blues} arguments define the number of bits set in the returned red, green, and blue masks, respectively. The number of colors must be positive, and the number of bits for each mask must be non-negative. A total of (* @emph{colors} (@var{expt} 2 (+ @emph{reds greens} @emph{blues}))) color cells are allocated. The pixel values for the allocated cells can be computed by combining the returned @emph{pixels} and masks. Each mask of the returned masks defines a pixel subfield for the corresponding primary. None of the masks have any 1 bits in common. By selectively combining subsets of the red, green, and blue masks with @var{logior}, (@var{expt} 2 (+ @emph{reds greens blues}) distinct combined plane masks can be computed. The length of the returned @emph{pixels} @var{sequence} is equal to @emph{colors}. None of the pixels have any 1 bits in common with each other or with any of the returned masks. By combining pixels and plane masks with @var{logior}, (* @emph{colors} (@var{expt} 2 (+ @emph{reds greens blues})) distinct pixel values can be produced. If @var{:contiguous-p} is true, each of returned masks consists of a set of contiguous bits. If the @var{colormap} class is @var{:direct-color}, each returned mask lies within the pixel subfield for its primary. @table @var @item pixels Type @var{sequence} of @var{pixel}. @item red-mask @itemx green-mask @itemx blue-mask Type @var{pixel}. @end table @end defun @defun free-colors colormap pixels &optional (plane-mask 0) @table @var @item colormap A @var{colormap}. @item pixels A @var{sequence} of pixel values. @item plane-mask A pixel value with no bits in common with any of the @emph{pixels}. @end table Frees a set of allocated color cells from the @emph{colormap}. The pixel values for the freed cells are computed by combining the given @emph{pixels} sequence and @var{:plane-mask}. The total number of cells freed is: @lisp (* (@var{length} @emph{pixels}) (@var{expt} 2 (@var{logcount} @emph{plane-mask}))) @end lisp The @var{:plane-mask} must not have any bits in common with any of the given @emph{pixels}. The pixel values for the freed cells are produced by using @var{logior} to combine each of the given pixels with all subsets of the @var{:plane-mask}. Note that freeing an individual pixel allocated by @var{alloc-color-planes} may not allow it to be reused until all related pixels computed from the same plane mask are also freed. A single error is generated if any computed pixel is invalid or if its color cell is not allocated by the client. Even if an error is generated, all valid pixel values are freed. @end defun @node Finding Colors, Changing Colors, Allocating Colors, Colormap Functions @subsection Finding Colors A CLX program can ask the X server to return the colors stored in allocated color cells. The server also maintains a dictionary of color names and their associated color values. CLX provides a function to look up the values for common colors by names such as "red", "purple", and so forth. The following paragraphs describe the CLX functions for returning the color values associated with color cells or with color names. @defun lookup-color colormap name @table @var @item colormap A @var{colormap}. @item name A @var{stringable} color name. @end table Returns the color associated by the X server with the given color @emph{name}. The @emph{name} must contain only ISO Latin-1 characters; case is not significant. The first value returned is the closest approximation to the requested color possible on the screen hardware. The second value returned is the true color value for the requested color. @table @var @item screen-color @itemx exact-color Type @var{color}. @end table @end defun @defun query-colors colormap pixels &key (:result-type 'list) @table @var @item colormap A @var{colormap}. @item pixels A @var{sequence} of @var{pixel} values. @item :result-type A subtype of @var{sequence} that indicates the type of sequences returned. @end table Returns a @var{sequence} of the colors contained in the allocated cells of the @emph{colormap} specified by the given @emph{pixels}. The values returned for unallocated cells are undefined. @table @var @item colors Type @var{sequence} of @var{color}. @end table @end defun @node Changing Colors, Colormap Attributes, Finding Colors, Colormap Functions @subsection Changing Colors The following paragraphs describe the CLX functions to change the colors in colormap cells. @defun store-color colormap pixel color &key (:red-p t) (:green-p t) (:blue-p t) @table @var @item colormap A @var{colormap}. @item pixel A @var{pixel}. @item color A color @var{object} or a @var{stringable} containing a color name. @item :red-p @itemx :green-p @itemx :blue-p @var{boolean} values indicating which color components to store. @end table Changes the contents of the @emph{colormap} cell indexed by the @emph{pixel}. Components of the given @emph{color} are stored in the cell. The @var{:red-p}, @var{:green-p}, and @var{:blue-p} arguments indicate which components of the given @emph{color} are stored. The @emph{color} can be either a @var{color} object or a @var{stringable} containing a color name. If a color name is given, a corresponding color value is looked up (see @var{lookup-color}) and used. Color name strings must contain only ISO Latin-1 characters; case is not significant. @end defun @defun store-colors colormap pixel-colors &key (:red-p t) (:green-p t) (:blue-p t) @table @var @item colormap A @var{colormap}. @item pixel-colors A list of the form (@{@emph{pixel color}@}*). @item :red-p @itemx :green-p @itemx :blue-p @var{boolean} values indicating which color components to store. @end table Changes the contents of multiple @emph{colormap} cells. @emph{pixel-colors} is a list of the form (@{ @emph{pixel color}@}*), indicating a set of pixel values and the colors to store in the corresponding cells. The @var{:red-p}, @var{:green-p}, and @var{:blue-p} arguments indicate which components of the given colors are stored. Each color can be either a @var{color} object or a @var{stringable} containing a color name. If a color name is given, a corresponding color value is looked up (see @var{lookup-color}) and used. Color name strings must contain only ISO Latin-1 characters; case is not significant. @end defun @node Colormap Attributes, , Changing Colors, Colormap Functions @subsection Colormap Attributes The complete set of colormap attributes is discussed in the following paragraphs. @defun colormap-display colormap @table @var @item colormap A @var{colormap}. @end table Returns the @var{display} object associated with the specified @emph{colormap}. @table @var @item display Type @var{display}. @end table @end defun @defun colormap-equal colormap-1 colormap-2 @table @var @item colormap-1 @itemx colormap-2 A @var{colormap}. @end table Returns true if the two arguments refer to the same server resource and @var{nil} if they do not. @end defun @defun colormap-id colormap @table @var @item colormap A @var{colormap}. @end table Returns the unique ID assigned to the specified @emph{colormap}. @table @var @item id Type @var{resource-id}. @end table @end defun @defun colormap-p colormap Returns non-@var{nil} if the argument is a @var{colormap} and @var{nil} otherwise. @table @var @item map-p Type @var{boolean}. @end table @end defun @defun colormap-plist colormap @table @var @item colormap A @var{colormap}. @end table Returns and (with @code{setf}) sets the property list for the specified @emph{colormap}. This function provides a hook where extensions can add data. @table @var @item colormap-p Type @var{boolean}. @end table @end defun @node Cursors, Atoms, Colors, Top @chapter Cursors A @emph{cursor} is a visible shape that appears at the current position of the pointer device. The cursor shape moves with the pointer to provide continuous feedback to the user about the current location of the pointer. Each window can have a cursor attribute that defines the appearance of the pointer cursor when the pointer position lies within the window. See @var{window-cursor}. A cursor image is composed of a source bitmap, a mask bitmap, a @emph{hot spot}, a foreground color, and a background color. Either 1-bit pixmaps or font glyphs can be used to specify source and mask bitmaps. The source bitmap identifies the foreground and background pixels of the cursor image; the mask bitmap identifies which source pixels are actually drawn. The mask bitmap thus allows a cursor to assume any shape. The hot spot defines the position within the cursor image that is displayed at the pointer position. In CLX, a cursor is represented by a @var{cursor} object. This section describes the CLX functions to: @itemize @bullet @item Create and free cursor objects @item Change cursor colors @item Inquire the best cursor size @item Access cursor attributes @end itemize @menu * Creating Cursors:: * Cursor Functions:: * Cursor Attributes:: @end menu @node Creating Cursors, Cursor Functions, Cursors, Cursors @section Creating Cursors The following paragraphs describe the CLX functions used to create and free @var{cursor} objects. @defun create-cursor &key :source :mask :x :y :foreground :background @table @var @item :source The source pixmap. This argument is required. @item :mask The mask pixmap. @item :x @itemx :y The hot spot position in the @var{:source}. This argument is required. @item :foreground A @var{color} object specifying the foreground color. This argument is required. @item :background A @var{color} object specifying the background color. This argument is required. @end table Creates and returns a cursor. @var{:x} and @var{:y} define the position of the hot spot relative to the origin of the @var{:source. :foreground} and @var{:background} colors must be specified, even if the server only has a @var{:static-gray} or @var{:gray-scale} screen. The @var{:source}, @var{:x}, and @var{:y} arguments must also be specified. The cursor image is drawn by drawing a pixel from the @var{:source} bitmap at every position where the corresponding bit in the @var{:mask} bitmap is 1. If the corresponding @var{:source} bit is 1, a pixel is drawn in the @var{:foreground} color; otherwise, a pixel is drawn in the @var{:back-ground} color. If the @var{:mask} is omitted, all @var{:source} pixels are drawn. If given, the @var{:mask} must be the same size as the @var{:source}. An X server may not be able to support every cursor size. A server is free to modify any component of the cursor to satisfy hardware or software limitations. The @var{:source} and @var{:mask} can be freed immediately after the cursor is created. Subsequent drawing in the @var{:source} or @var{:mask} pixmap has an undefined effect on the cursor. @table @var @item cursor Type @var{cursor}. @end table @end defun @defun create-glyph-cursor &key :source-font :source-char :mask-font (:mask-char 0) :foreground :background @table @var @item :source-font The source font. This is a required argument. @item :source-char An index specifying a glyph in the source font. This is a required argument. @item :mask-font The mask font. @item :mask-char An index specifying a glyph in the mask font. @item :foreground A @var{color} object specifying the foreground color. This is a required argument. @item :background A @var{color} object specifying the background color. This is a required argument. @end table Creates and returns a cursor defined by font glyphs. The source bitmap is defined by the @var{:source-font} and @var{:source-char}. The mask bitmap is defined by the @var{:mask-font} and @var{:mask-char}. It is an error if the @var{:source-char} and @var{:mask-char} are not valid indexes for the @var{:source-font} and @var{:mask-font}, respectively. The hot spot position is defined by the "character origin" of the source glyph, that is, the position [- @emph{char-left-bearing}, @emph{char-ascent}] relative to the upper left corner of the source glyph bitmap. Source and mask bits are compared after aligning the character origins of the source and mask glyphs. The source and mask glyphs need not have the same size or character origin position. If the @var{:mask-font} is omitted, all source pixels are drawn. An X server may not be able to support every cursor size. A server is free to modify any component of the cursor to satisfy hardware or software limitations. Either of the @var{:source-font} or @var{:mask-font} can be closed after the cursor is created. @table @var @item cursor Type @var{cursor}. @end table @end defun @defun free-cursor cursor @table @var @item cursor A @var{cursor} object. @end table Destroys the @var{cursor} object. Cursor server resources are freed when no other references remain. @end defun @node Cursor Functions, Cursor Attributes, Creating Cursors, Cursors @section Cursor Functions The following paragraphs describe the CLX functions used to operate on @var{cursor} objects. @defun query-best-cursor width height display @table @var @item display A @var{display} object. @item width @itemx height The requested cursor size. @end table Returns the cursor size closest to the requested @emph{width} and @emph{height} that is best suited to the display. The @emph{width} and @emph{height} returned define the largest cursor size supported by the X server. Clients should always be prepared to limit cursor sizes to those supported by the server. @table @var @item width @itemx height Type @var{card16}. @end table @end defun @defun recolor-cursor cursor foreground background @table @var @item cursor A @var{cursor} object. @item foreground A @var{color} object specifying the new foreground color. @item background A @var{color} object specifying the new background color. @end table Changes the color of the specified @emph{cursor}. If the cursor is displayed on a screen, the change is visible immediately. @end defun @node Cursor Attributes, , Cursor Functions, Cursors @section Cursor Attributes The complete set of cursor attributes is discussed in the following paragraphs. @defun cursor-display cursor @table @var @item cursor A @var{cursor} object. @end table Returns the @var{display} object associated with the specified @emph{cursor}. @table @var @item display Type @var{display}. @end table @end defun @defun cursor-equal cursor-1 cursor-2 @table @var @item cursor-1 @itemx cursor-2 @var{cursor} objects. @end table Returns true if the two arguments refer to the same server resource and @var{nil} if they do not. @end defun @defun cursor-id cursor @table @var @item cursor A @var{cursor} object. @end table Returns the unique resource ID that has been assigned to the specified @emph{cursor}. @table @var @item id Type @var{resource-id.} @end table @end defun @defun cursor-p cursor @table @var @item cursor-p Type @var{boolean}. @end table Returns true if the argument is a @var{cursor} object and @var{nil} otherwise. @end defun @defun cursor-plist cursor @table @var @item cursor A @var{cursor} object. @end table Returns and (with @code{setf}) sets the property list for the specified @emph{cursor}. This function provides a hook where extensions can add data. @table @var @item plist A property list. @end table @end defun @node Atoms, Events and Input, Cursors, Top @chapter Atoms, Properties and Selections @menu * Atoms (Atoms):: * Properties:: * Selections:: @end menu @node Atoms (Atoms), Properties, Atoms, Atoms @section Atoms In X, an @emph{atom} is a unique ID used as the name for certain server resources -- properties and selections. In CLX, an atom is represented by a keyword symbol. For convenience, CLX functions also allow atoms to be specified by strings and non-keyword symbols. @var{xatom} is a CLX data type that permits either string or symbol values. A string is equivalent to the @var{xatom} given by (@var{intern} @emph{string} @var{'keyword}). A symbol is equivalent to the @var{xatom} given by ( @var{intern} (@var{symbol-name} @emph{symbol}) @var{'keyword}). The symbol name string of an @var{xatom} must consist only of ISO Latin characters. Note that the case of @var{xatom} strings is important; the @var{xatom} "Atom" is not the same as the @var{xatom} "ATOM". Certain atoms are already predefined by every X server. Predefined atoms are designed to represent common names that are likely to be useful for many client applications. Note that these atoms are predefined only in the sense of having @var{xatom} and @var{card29} values, not in the sense of having required semantics. No interpretation is placed on the meaning or use of an atom by the server. The @var{xatom} objects predefined by CLX are listed below. @multitable @columnfractions 0.3 0.3 0.3 @item @var{:arc} @tab @var{:italic_angle} @tab @var{:string} @item @var{:atom} @tab @var{:max_space} @tab @var{:subscript_x} @item @var{:bitmap} @tab @var{:min_space} @tab @var{:subscript_y} @item @var{:cap_height} @tab @var{:norm_space} @tab @var{:superscript_x} @item @var{:cardinal} @tab @var{:notice} @tab @var{:superscript_y} @item @var{:colormap} @tab @var{:pixmap} @tab @var{:underline_position} @item @var{:copyright} @tab @var{:point} @tab @var{:underline_thickness} @item @var{:cursor} @tab @var{:point_size} @tab @var{:visualid} @item @var{:cut_buffer0} @tab @var{:primary} @tab @var{:weight} @item @var{:cut_buffer1} @tab @var{:quad_width} @tab @var{:window} @item @var{:cut_buffer2} @tab @var{:rectangle} @tab @var{:wm_class} @item @var{:cut_buffer3} @tab @var{:resolution} @tab @var{:wm_client_machine} @item @var{:cut_buffer4} @tab @var{:resource_manager} @tab @var{:wm_command} @item @var{:cut_buffer5} @tab @var{:rgb_best_map} @tab @var{:wm_hints} @item @var{:cut_buffer6} @tab @var{:rgb_blue_map} @tab @var{:wm_icon_name} @item @var{:cut_buffer7} @tab @var{:rgb_color_map}@tab @var{:wm_icon_size} @item @var{:drawable} @tab @var{:rgb_default_map} @tab @var{:wm_name} @item @var{:end_space} @tab @var{:rgb_gray_map} @tab @var{:wm_normal_hints} @item @var{:family_name} @tab @var{:rgb_green_map}@tab @var{:wm_size_hints} @item @var{:font} @tab @var{:rgb_red_map} @tab @var{:wm_transient_for} @item @var{:font_name} @tab @var{:secondary} @tab @var{:wm_zoom_hints} @item @var{:full_name} @tab @var{:strikeout_ascent} @tab @var{:x_height} @item @var{:integer} @tab @var{:strikeout_descent} @tab @end multitable When creating a new atom, the following conventions should be obeyed in order to minimize the conflict between atom names: @itemize @bullet @item Symbol names beginning with an underscore should be used for atoms that are private to a particular vendor or organization. An additional prefix should identify the organization. @item Symbol names beginning with two underscores should be used for atoms that are private to a single application or end user. @end itemize CLX provides functions to convert between an @var{xatom} and its corresponding ID integer. The data type of an atom ID is @var{card29}. The @var{xatom} representation is usually sufficient for most CLX programs. However, it is occasionally useful to be able to convert an atom ID returned in events or properties into its corresponding @var{xatom}. @defun atom-name display atom-id @table @var @item display A @var{display} object. @item atom-id A @var{card29}. @end table Returns the atom keyword for the @emph{atom-id} on the given @emph{display} server. @table @var @item atom-name Type @var{keyword}. @end table @end defun @defun find-atom display atom-name @table @var @item display A @var{display} object. @item atom-name An @var{xatom}. @end table Returns the atom ID for the given @emph{atom-name}, if it exists. If no atom of that name exists for the display server, @var{nil} is returned. @table @var @item atom-id Type @var{card29} or @var{null}. @end table @end defun @defun intern-atom display atom-name @table @var @item display A @var{display} object. @item atom-name An @var{xatom}. @end table Creates an atom with the given name and returns its atom ID. The atom can survive the interning client; it exists until the last server connection has been closed and the server resets itself. @table @var @item atom-id Type @var{card29} or @var{null}. @end table @end defun @node Properties, Selections, Atoms (Atoms), Atoms @section Properties For each window, an X server can record a set of @emph{properties}. Properties are a general mechanism for clients to associate arbitrary data with a window, and for clients to communicate window data to each other via the server. No interpretation is placed on property data by the server itself. A property consists of a name, a type, a data format, and data. The name of a property is given by an atom. The property type is another atom used to denote the intended interpretation of the property data. The property formats specifies whether the property data should be treated as a set of 8-, 16-, or 32-bit elements. The property format must be specified so that the X server can communicate property data with the correct byte order. CLX provides functions to: @itemize @bullet @item Create or change a property @item Return property data @item List window properties @item Delete a property @end itemize @defun change-property window property data type format &key (:mode :replace) (:start 0) :end :transform @table @var @item window A @var{window}. @item property A property name @var{xatom}. @item data A sequence of property data elements. @item type The property type @var{xatom}. @item format One of 8, 16, or 32. @item :mode One of @var{:replace}, @var{:append}, or @var{:prepend}. @item :start @itemx :end Specify the subsequence of previous data replaced when @var{:mode} is @var{:replace}. @item :transform A function that transforms each data element into a data value to store. @end table Creates a new window property or changes an existing property. A @var{:property-notify} event is generated for the @emph{window}. If the @var{:mode} is @var{:replace}, the new @emph{data}, @emph{type}, and @emph{format} replace any previous values. The subsequence of previous data elements that are replaced is defined by the @var{:start} and @var{:end} indexes. If the @var{:mode} is @var{:prepend} or @var{:append}, no previous data is changed, but the new @emph{data} is added at the beginning or the end, respectively. For these modes, if the @emph{property} already exists, the new @emph{type} and @emph{format} must match the previous values. The @var{:transform}, if given, is a function used to compute the actual property data stored. The @var{:transform}, which must accept a single data element and return a single transformed data element, is called for each data element. If the @emph{data} is a string, the default @var{:transform} function transforms each character into its ASCII code; otherwise, the default is to store the @emph{data} unchanged. @end defun @defun delete-property window property @table @var @item window A @var{window}. @item property A property name @var{xatom}. @end table Deletes the @emph{window property}. If the @emph{property} already exists, a @var{:property-notify} event is generated for the @emph{window}. @end defun @defun get-property window property &key :type (:start 0) :end :delete-p (:result-type 'list) :transform @anchor{get-property} @table @var @item window A @var{window}. @item property A property name @var{xatom}. @item :type The requested type @var{xatom} or @var{nil}. @item :start @itemx :end Specify the subsequence of property @emph{data} returned. @item :transform A function that transforms each data element into a data value to return. @item :delete-p If true, the existing @emph{property} can be deleted. @item :result-type The t@emph{ype} of data sequence to return. Default is @var{'list}. @end table Returns a subsequence of the data for the window property. The @var{:start} and @var{:end} indexes specify the property @emph{data} elements returned. The @var{:transform} function is called for elements of the specified subsequence to compute the @emph{data} sequence returned. The property @emph{type} and @emph{format} are also returned. The final return value gives the actual number of data bytes (not elements) following the last data element returned. If the @emph{property} does not exist, the returned @emph{data} and @emph{type} are @var{nil} and the returned @emph{format} and @emph{bytes-after} are zero. If the given @var{:type} is non-@var{nil} but does not match the actual property type, then the @emph{data} returned is @var{nil}, the @emph{type} and @emph{format} returned give the actual property values, and the @emph{bytes-after} returned gives the total number of bytes (not elements) in the property data. If the given @var{:type} is @var{nil} or if it matches the actual property type, then: @itemize @bullet @item The @emph{data} returned is the transformed subsequence of the property data. @item The @emph{type} and @emph{format} returned give the actual property values. @item The @emph{bytes-after} returned gives the actual number of data bytes (not elements) following the last data element returned. @end itemize In this case, the @var{:delete-p} argument is also examined. If @var{:delete-p} is true and @emph{bytes-after} is zero, the property is deleted and a @var{:property-notify} event is generated for the @emph{window}. @table @var @item data Type @var{sequence}. @item type Type @var{xatom}. @item format Type (@var{member 8 16 32}). @item bytes-after Type @var{card32}. @end table @end defun @defun list-properties window &key (:result-type 'list) @table @var @item window A @var{window}. @item :result-type The type of sequence to return. Default is @var{'list}. @end table Returns a sequence containing the names of all @emph{window properties}. @table @var @item properties Type @var{sequence} of @var{keyword}. @end table @end defun @defun rotate-properties window properties &optional (delta 1) @table @var @item window A @var{window}. @item properties A sequence of @var{xatom} values. @item delta The index interval between source and destination elements of @emph{properties}. @end table Rotates the values of the given @emph{window properties}. The value of property @emph{i} in the given sequence is changed to the value of the property at index (@var{mod} (+ @emph{i delta}) (@var{length} @emph{properties})). This function operates much like the @var{rotatef} macro in Common Lisp. If (@var{mod} @emph{delta} (@var{length} @emph{properties})) is non-zero, a @var{:property-notify} event is generated on the window for each property, in the same order as they appear in the @emph{properties} sequence. @end defun @node Selections, , Properties, Atoms @section Selections A selection is an atom used to identify data that can be shared among all client programs connected to an X server. Unlike properties, the data represented by a selection is stored by some client program, not by the server. The data named by a selection is associated with a client window, which is referred to as the @emph{selection owner}. The server always knows which window is the owner of a selection. Selections can be created freely by clients using @var{intern-atom} to create an atom. CLX provides functions to inquire or change the owner of a selection and to @emph{convert} a selection. Conversion is the key to the use of selections for inter-client communication. Suppose Client A wants to paste the contents of the data named by selection @emph{S} into his window @emph{WA}. Client A calls @var{convert-selection} on selection atom @emph{S}, sending a conversion request to the server. The server, in turn, sends a @var{:selection-request} event to the current owner of @emph{S}, which is window @emph{WB} belonging to Client B. The @var{:selection-request} event contains the @emph{requestor} window (@emph{WA}), the selection atom (@emph{S}), an atom identifying a requested data type, and the name of a property of @emph{WA} into which the value of @emph{S} will be stored. Since @emph{WB} is the owner of @emph{S}, it must be associated with the data defined by Client B as the value of @emph{S}. When @emph{WB} gets the @var{:selection-request} event, Client B is expected to convert the value of @emph{S} to the requested data type (if possible) and store the converted value in the given requestor property. Client B is then expected to send a @var{:selection-notify} event to the requestor window @emph{WA}, informing the requestor that the converted value for @emph{S} is ready. Upon receiving the @var{:selection-notify} event, Client A can call @var{get-property} to retrieve the converted value and to paste it into @emph{WA}. @var{NOTE:} Clients using selections must always be prepared to handle @var{:selection-request} events and/or @var{:selection-notify} events. There is no way for a client to ask not to receive these types of events. Type atoms used in selection conversion can represent arbitrary client-defined interpretations of the selection data. For example, if the value of selection @emph{S} is a text string, Client A might request its typeface by requesting conversion to the @var{:font} type. A type @var{atom} can also represent a request to the selection owner to perform some action as a side-effect of conversion (for example, @var{:delete}). Some of the predefined atoms of an X server are intended to be used as selection types (for example, @var{:colormap}, @var{:bitmap}, @var{:string}, and so forth) However, X does not impose any requirements on the interpretation of type atoms. When multiple clients negotiate for ownership of a selection, certain race conditions might be possible. For example, two clients might each receive a user command to assert ownership of the @var{:primary} selection, but the order in which the server processes these client requests is unpredictable. As a result, the ownership request initiated most recently by the user might be incorrectly overridden by the other earlier ownership request. To prevent such anomalies, the server records a @emph{last-changed} timestamp for each change of selection ownership. Although inter-client communication via selections is rather complex, it offers important benefits. Since selection communication is mediated by an X server, clients can share data even though they are running on different hosts and using different networking protocols. Data storage and conversion is distributed among clients so that the server is not required to provide all possible data types or to store multiple forms of selection data. Certain predefined atoms are used as standard selections, as described in the X11 Inter-client Communications Conventions Manual. Some of the standard selections covered by these conventions are: @table @var @item :primary The @emph{primary selection}. The main vehicle for inter-client cut and paste operations. @item :secondary The @emph{secondary selection}. In some environments, clients can use this as an auxiliary to @var{:primary}. @item :clipboard Analogous to akill ring. Represents the most recently deleted data item. @end table @defun convert-selection selection type requestor &optional property time @table @var @item selection The @var{xatom} for the selection name. @item type The @var{xatom} for the requested data type. @item requestor The @var{window} to receive the converted @emph{selection} value. @item property The @var{xatom} for the requestor property to receive the converted value. @item time A @var{timestamp}. @end table Requests that the value of the @emph{selection} be converted to the specified @emph{type} and stored in the given @emph{property} of the @emph{requestor} window. If the @emph{selection} has an owner, the X server sends a @var{:selection-request} event to the owner window. Otherwise, if no owner exists, the server generates on the requestor a @var{:selection-notify} event containing a @var{nil} @emph{property} atom. The given @emph{property} specifies the requestor property that will receive the converted value. If the @emph{property} is omitted, the @emph{selection} owner will define a property to use. The @emph{time} furnishes a timestamp representing the time of the conversion request; by default, the current server time is used. @var{NOTE:} Standard conventions for inter-client communication require that both the requestor property and the time must be specified. If possible, the time should be the time of a user event which initiated the conversion. Alternatively, a timestamp can be obtained by calling @var{change-property} to append zero-length data to some property; the timestamp in the resulting @var{:property-notify} event can then be used. @end defun @defun selection-owner display selection &optional time @table @var @item display A @var{display}. @item selection The @var{xatom} for the selection name. @item time A @var{timestamp}. @end table Returns and (with @code{setf}) changes the owner and the last-changed @emph{time} for the @emph{selection}. If the owner is @var{nil}, no owner for the @emph{selection} exists. When the owner window for a @emph{selection} is destroyed, the @emph{selection} owner is set to @var{nil} without affecting the last-changed @emph{time}. The @emph{time} argument is used only when changing the @emph{selection} owner. If the @emph{time} is @var{nil}, the current server time is used. If the @emph{time} is earlier than the current last-changed time of the @emph{selection} or if the @emph{time} is later than the current server time, the owner is not changed. Therefore, a client should always confirm successful change of ownership by immediately calling @var{selection-owner}. If the change in ownership is successful, the last-changed time of the @emph{selection} is set to the specified @emph{time}. If the change in ownership is successful and the new owner is different from the previous owner, and if the previous owner is not @var{nil}, a @var{:selection-clear} event is generated for the previous owner window. @var{NOTE:} Standard conventions for inter-client communication require that a non-nil time must be specified. If possible, the time should be the time of a user event which initiated the change of ownership. Alternatively, a timestamp can be obtained by calling change-property to append zero-length data to some property; the timestamp in the resulting @var{:property-notify} event can then be used. @table @var @item owner Type @var{window} or @var{null}. @end table @end defun @node Events and Input, Resources, Atoms, Top @chapter Events and Input A client application uses CLX functions to send @emph{requests} to an X server over a display connection returned by the @var{open-display} function. In return, the X server sends back @emph{replies} and @emph{events}. Replies are synchronized with specific requests and return requested server information. Events typically occur asynchronously. Device events are generated by user input from both the keyboard and pointer devices. Other events are side-effects of the requests sent by CLX functions. The types of events returned by an X server are summarized below. Device Events @table @asis @item Keyboard @var{:key-press} @var{:key-release} @item Pointer @var{:button-press} @var{:button-release} @var{:enter-notify} @var{:leave-notify} @var{:motion-notify} @end table Side-Effect Events @table @asis @item Client communication @var{:client-message} @var{:property-notify} @var{:selection-clear} @var{:selection-notify} @var{:selection-request} @item Color map state @var{:colormap-notify} @item Exposure @var{:exposure} @var{:graphics-exposure} @var{:no-exposure} @item Input focus @var{:focus-in} @var{:focus-out} @item Keyboard and pointer state @var{:keymap-notify} @var{:mapping-notify} @item Structure control @var{:circulate-request} @var{:configure-request} @var{:map-request} @item Window state @var{:resize-request} @var{:circulate-notify} @var{:configure-notify} @var{:create-notify} @var{:destroy-notify} @var{:gravity-notify} @var{:map-notify} @var{:reparent-notify} @var{:unmap-notify} @var{:visibility-notify} @end table Client programs can override the server's normal distribution of events by@emph{ grabbing} the pointer or the keyboard. Grabbing causes events from the pointer or keyboard device to be reported to a single specified window, rather than to their ordinary destinations. It can also cause the server to @emph{freeze} the grabbed device, sending queued events only when explicitly requested by the grabbing client. Two kinds of grabs are possible: @itemize @bullet @item Active -- Events are immediately grabbed. @item Passive -- Events are grabbed later, as soon as a specified device event occurs. @end itemize Grabbing an input device is performed rarely and usually only by special clients, such as window managers. This section describes the CLX functions used to: @itemize @bullet @item Select events (@pxref{Selecting Events}) @item Process an event on the event queue (@pxref{Processing Events}) @item Manage the event queue (@pxref{Managing the Event Queue}) @item Send events to other applications (@pxref{Sending Events}) @item Read and change the pointer position (@pxref{Pointer Position}) @item Manage the keyboard input focus (@pxref{Managing Input Focus}) @item Grab pointer and keyboard events (@pxref{Grabbing the Pointer}) @item Release queued events (@pxref{Releasing Queued Events}) @end itemize This section also contains a detailed description of the content of each type of event. @menu * Selecting Events:: * Processing Events:: * Managing the Event Queue:: * Sending Events:: * Pointer Position:: * Managing Input Focus:: * Grabbing the Pointer:: * Grabbing a Button:: * Grabbing the Keyboard:: * Grabbing a Key:: * Event Types:: * Releasing Queued Events:: @end menu @node Selecting Events, Processing Events, Events and Input, Events and Input @section Selecting Events A client @emph{selects} which types of events it receives from a specific window. The window event-mask attribute, set by the client, determines which event types are selected (see @var{window-event-mask} in @ref{Window Attributes}). Most types of events are received by a client only if they are selected for some window. In the X protocol, an event-mask is represented as a bit string. CLX also allows an event mask to be defined by a list of @var{event-mask-class} keywords. The functions @var{make-event-keys} and @var{make-event-mask} can be used to convert between these two forms of an event-mask. In general, including an @var{event-mask-class} keyword in an event-mask causes one or more related event types to be selected. The following table describes the event types selected by each @var{event-mask-class} keyword. @multitable @columnfractions 0.5 0.5 @item Event Mask Keyword @tab Event Types Selected @item @var{:button-1-motion} @tab @var{:motion-notify} when @var{:button-1} is down @item @var{:button-2-motion} @tab @var{:motion-notify} when @var{:button-2} is down @item @var{:button-3-motion} @tab @var{:motion-notify} when @var{:button-3} is down @item @var{:button-4-motion} @tab @var{:motion-notify} when @var{:button-4} is down @item @var{:button-5-motion} @tab @var{:motion-notify} when @var{:button-5} is down @item @var{:button-motion} @tab @var{:motion-notify} when any pointer button is down @item @var{:button-press} @tab @var{:button-press} @item @var{:button-release} @tab @var{:button-release} @item @var{:colormap-change} @tab @var{:colormap-notify} @item @var{:enter-window} @tab @var{:enter-notify} @item @var{:exposure} @tab @var{:exposure} @item @var{:focus-change} @tab @var{:focus-in} @var{:focus-out} @item @var{:key-press} @tab @var{:key-press} @item @var{:key-release} @tab @var{:key-release} @item @var{:keymap-state} @tab @var{:keymap-notify} @item @var{:leave-window} @tab @var{:leave-notify} @item @var{:owner-grab-button} @tab Pointer events while button is grabbed @item @var{:pointer-motion} @tab @var{:motion-notify} @item @var{:pointer-motion-hint} @tab Single @var{:motion-notify} only @item @var{:property-change} @tab @var{:property-notify} @item @var{:resize-redirect} @tab @var{:resize-request} @item @var{:structure-notify} @tab @var{:circulate-notify} @var{:configure-notify} @var{:destroy-notify} @var{:gravity-notify} @var{:map-notify} @var{:reparent-notify} @var{:unmap-notify} @item @var{:substructure-redirect} @tab @var{:circulate-request} @var{:configure-request} @var{:map-request} @item @var{:visibility-change} @tab @var{:visibility-notify} @end multitable Some types of events do not have to be selected to be received and therefore are not represented in an event-mask. For example, the @var{copy-plane} and @var{copy-area} functions cause @var{:graphics-exposure} and @var{:no-exposure} events to be reported, unless exposures are turned @var{:off} in the graphics context (see @var{copy-area} and @var{copy-plane} in @ref{Area and Plane Operations}, and @var{gcontext-exposures} in paragraph 5.4.6, Exposures). Also, @var{:selection-clear}, @var{:selection-request}, @var{:selection-notify} and @var{:client-message} events can be received at any time, but they are generally sent only to clients using selections (@pxref{Client Communications Events}). @var{:mapping-notify} is always sent to clients when the keyboard mapping is changed. Any client can select events for any window. A window maintains a separate event-mask for each interested client. In general, multiple clients can select for the same events on a window. After the X server generates an event, it sends it to all clients which selected it. However, the following restrictions apply to sharing window events among multiple clients. For a given window: @itemize @bullet @item Only one client at a time can include @var{:substructure-redirect} in its event-mask @item Only one client at a time can can include @var{:button-press} in its event-mask @item Only one client at a time can include @var{:resize-redirect} in its event-mask @end itemize @node Processing Events, Managing the Event Queue, Selecting Events, Events and Input @section Processing Events Events received by a CLX client are stored in an @emph{event queue} until they are read and processed. Events are processed by @emph{handler functions}. @defun handler-function &rest event-slots &key :display :event-key :send-event-p &allow-other-keys @table @var @item :display A @var{display} for the connection that returned the event. @item :event-key An @var{event-key} keyword specifying the event type. @item :send-event-p If true, the event was sent from another application using the @var{send-event} function. @end table The arguments to a handler function are keyword-value pairs that describe the contents of an event. The actual @emph{event-slots} passed depend on the event type, except that @var{:display}, @var{:event-key}, and @var{:send-event-p} are given for all event types. The keyword symbols used for each event type are event slot names defined by the @var{declare-event} macro and are described in @ref{Declaring Event Types}. If a handler returns non-@var{nil}, the event is considered @emph{processed} and can be removed from the event queue. Otherwise, if a handler function returns @var{nil}, the event can remain in the event queue for later processing. @table @var @item handled-p Type @var{boolean}. @end table @end defun @defun process-event display &key :handler :timeout :peek-p :discard-p (:force-output-p t) @table @var @item display A @var{display}. @item :handler A handler function or a sequence of handler functions. @item :timeout Specifies the timeout delay in seconds. @item :peek-p If @var{nil}, events are removed from the event queue after processing. @item :discard-p If true, unprocessed events are discarded. @item :force-output-p If true, buffered output requests are sent. @end table Invokes @var{:handler} on each queued event until @var{:handler} returns non-@var{nil}. Then, the non-@var{nil :handler} value is returned by @var{process-event}. If @var{:handler} returns @var{nil} for each event in the event queue, @var{process-event} waits for another event to arrive. If timeout is non-@var{nil} and no event arrives within the specified timeout interval (given in seconds), @var{process-event} returns @var{nil}; if timeout is @var{nil}, @var{process-event} will not return until @var{:handler} returns non-@var{nil}. @var{process-event} may wait only once on network data, and therefore timeout prematurely. If @var{:force-output-p} is true, @var{process-event} first invokes @var{display-force-output} to send any buffered requests. If @var{:peek-p} is true, a processed event is not removed from the queue. If @var{:discard-p} is true, unprocessed events are removed from the queue; otherwise, unprocessed events are left in place. If @var{:handler} is a sequence, it is expected to contain handler functions for each event type. The sequence index of the handler function for a particular event type is given by ( @var{position event-key *event-key-vector*}). @table @var @item handled-p Type @var{boolean}. @end table @end defun @defmac event-case display &key :timeout :peek-p :discard-p (:force-output-p t) &body clauses @anchor{event-case} @table @var @item display A @var{display}. @item :handler A handler function or a sequence of handler functions. @item :timeout Specifies the timeout delay, in seconds. @item :peek-p If @var{nil}, events are removed from the event queue after processing. @item :discard-p If true, unprocessed events are discarded. @item :force-output-p If true, buffered output requests are sent. @item clauses Code to process specified event types. @end table Executes the matching clause for each queued event until a clause returns non-@var{nil}. The non-@var{nil} clause value is then returned. Each of the clauses is a list of the form (@emph{event-match} [@emph{event-slots}] &rest @emph{forms}), where: @itemize @bullet @item @emph{event-match} -- Either an @var{event-key}, a list of @var{event-keys}, otherwise, or @var{t}. It is an error for the same key to appear in more than one clause. @item @emph{event-slots} -- If given, a list of (non-keyword) event slot symbols defined for the specified event type(s). @xref{Declaring Event Types}. @item @emph{forms} -- A list of forms that process the specified event type(s). The value of the last form is the value returned by the clause. @end itemize A clause matches an event if the @var{event-key} is equal to or a member of the @emph{event-match}, or if the @emph{event-match} is @var{t} or @var{otherwise}. If no @var{t} or @var{otherwise} clause appears, it is equivalent to having a final clause that returns @var{nil}. If @emph{event-slots} is given, these symbols are bound to the value of the corresponding event slot in the clause forms. Each element of @emph{event-slots} can also be a list of the form (@emph{event-slot-keyword variable}), in which case the @emph{variable} symbol is bound to the value of the event slot specified by the @emph{event-slot-keyword}. If every clause returns @var{nil} for each event in the event queue, @var{event-case} waits for another event to arrive. If @var{:timeout} is non-@var{nil} and no event arrives within the specified timeout interval (given in seconds), @var{event-case} returns @var{nil}; if @var{:timeout} is @var{nil}, @var{event-case} will not return until a clause returns non-@var{nil}. @var{event-case} may wait only once on network data and therefore timeout prematurely. If @var{:force-output-p} is true, @var{event-case} first invokes @var{display-force-output} to send any buffered requests. If @var{:peek-p} is true, a processed event is not removed from the queue. If @var{:discard-p} is true, unprocessed events are removed from the queue; otherwise, unprocessed events are left in place. @table @var @item handled-p Type @var{boolean}. @end table @end defmac @defmac event-cond display &key :timeout :peek-p :discard-p (:force-output-p t) &body clauses @table @var @item handled-p Type @var{boolean}. @end table Similar to @var{event-case} except that each of the clauses is a list of the form (@emph{event-match} [@emph{event-slots}] @emph{test-form} &rest @emph{forms}). Executes the @emph{test-form} of the clause that matches each queued event until a @emph{test-form} returns non-@var{nil}. The body @emph{forms} of the clause are then executed. The values returned by the last clause body form are then returned by @var{event-cond}. When a @emph{test-form} returns true and @var{:peek-p} is @var{nil}, or when a @emph{test-form} returns @var{nil} and @var{:discard-p} is true, the matching event is removed from the event queue before the body @emph{forms} are executed. @table @var @item display A @var{display}. @item :handler A handler function or a sequence of handler functions. @item :timeout Specifies the timeout delay in seconds. @item :peek-p If @var{nil}, events are removed from the event queue after processing. @item :discard-p If true, unprocessed events are discarded. @item :force-output-p If true, buffered output requests are sent. @item clauses Code to process specified event types. @end table @end defmac @node Managing the Event Queue, Sending Events, Processing Events, Events and Input @section Managing the Event Queue The following paragraphs describe CLX functions and macros used to: @itemize @bullet @item Put a new event on the event queue @item Discard the current event @item Return the current length of the event queue @item Gain exclusive access to the event queue for a client process @end itemize @defun queue-event display event-key &rest event-slots &key :append-p &allow-other-keys @table @var @item display A @var{display}. @item event-key Specifies the type of event placed in the queue. @item event-slots Keyword-value pairs that describe the contents of an event. @item :append-p If true, the event is placed at the tail of the queue; otherwise, the event is placed at the head of the queue. @end table Places an event of the type given by @emph{event-key} into the event queue. When @var{:append-p} is true, the event is placed at the tail of the queue; otherwise, the event is placed at the head of the queue. The actual @emph{event-slots} passed depend on the event type. The keyword symbols used for each event type are event slot names defined by the @var{declare-event} macro and are described in @ref{Declaring Event Types}. @end defun @defun discard-current-event display @table @var @item display A @var{display}. @end table Discards the current event for the @emph{display}. Returns @var{nil} when the event queue is empty; otherwise, returns @var{t}. This function provides extra flexibility for discarding events, but it should be used carefully; use @var{event-cond} instead, if possible. Typically, @var{discard-current-event} is called inside a handler function or a clause of an @var{event-case} form and is followed by another call to @var{process-event}, @var{event-case}, or @var{event-cond}. @table @var @item discarded-p Type @var{boolean}. @end table @end defun @defun event-listen display &optional (timeout 0) @table @var @item display A @var{display}. @item timeout The number of seconds to wait for events. @end table Returns the number of events queued locally. If the event queue is empty, @var{event-listen} waits for an event to arrive. If timeout is non-@var{nil} and no event arrives within the specified timeout interval (given in seconds), @var{event-listen} returns @var{nil}; if timeout is @var{nil}, @var{event-listen} will not return until an event arrives. @table @var @item event-count Type @code{(or null integer)}. @end table @end defun @defmac with-event-queue display &body body @anchor{with-event-queue} @table @var @item display A @var{display}. @item body Forms to execute. @end table Executes the @emph{body} in a critical region in which the executing client process has exclusive access to the event queue. @end defmac @node Sending Events, Pointer Position, Managing the Event Queue, Events and Input @section Sending Events A client can send an event to a window. Clients selecting this window event will receive it just like any other event sent by the X server. @defun send-event window event-key event-mask &rest event-slots &key :propagate-p :display &allow-other-keys @table @var @item window The destination @var{window} for the event. @item event-key An @var{event-key} defining the type of event to send. @item event-mask Specifies the event types that receiving clients must select. @item event-slots Keyword-value pairs that describe the contents of an event. @item :propagate-p If true, the event can be propagated to ancestors of the destination window. @item :display A @var{display}. @end table Sends an event specified by the @emph{event-key} and @emph{event-slots} to the given destination @emph{window}. Any active grabs are ignored. The @emph{event-slots} passed depend on the event type. The keyword symbols used for each event type are event slot names defined by the @var{declare-event} macro and are described in @ref{Declaring Event Types}. If the @emph{window} is @var{:pointer-window}, the destination @emph{window} is replaced with the window containing the pointer. If the @emph{window} is @var{:input-focus}, the destination @emph{window} is replaced with the descendant of the focus window that contains the pointer or (if no such descendant exists) the focus window. The @var{:display} keyword is only required if the @emph{window} is @var{:pointer-window} or @var{:input-focus}. The @emph{event-key} must be one of the core events, or one of the events defined by an extension, so the server can send the event with the correct byte-order. The contents of the event are otherwise unaltered and unchecked by the server, except that the @var{send-event-p} event slot is set to true. If the @emph{event-mask} is @var{nil}, the event is sent to the client that created the destination @emph{window} with an @emph{event-mask} of 0; if that client no longer exists, no event is sent. Otherwise, the event is sent to every client selecting any of the event types specified by @emph{event-mask} on the destination @emph{window}. If @var{:propagate-p} is true and no clients have selected any of the event types in @emph{event-mask} on the destination @emph{window}, the destination is replaced with the closest ancestor of @emph{window} for which some client has selected a type in @emph{event-mask} and no intervening window has that type in its do-not-propagate mask. If no such window exists, or if the @emph{window} is an ancestor of the focus window and @var{:input-focus} was originally specified as the destination, the event is not sent to any clients. Otherwise, the event is reported to every client selecting on the final destination any of the types specified in @emph{event-mask}. @end defun @node Pointer Position, Managing Input Focus, Sending Events, Events and Input @section Pointer Position The CLX functions affecting pointer position are discussed in the following paragraphs. @defun query-pointer window @table @var @item window A @var{window} specifying the coordinate system for the returned position. @end table Returns the current pointer coordinates relative to the given @emph{window}. If @var{query-pointer} returns @var{nil} for @emph{same-screen-p}, the pointer is not on the same screen as the @emph{window}. In this case, @var{query-pointer} returns a value of @var{nil} for @emph{child} and a value of zero for @emph{x} and @emph{y}. If @var{query-pointer} returns true for @emph{same-screen-p}, the returned @emph{x} and @emph{y} are relative to the origin of window. The @emph{child} is the child of the window containing the pointer, if any. The @emph{state-mask} returned gives the current state of the modifier keys and pointer buttons. The returned @emph{root} is the root window currently containing the pointer. The returned @emph{root-x} and @emph{root-y} specify the pointer coordinates relative to @emph{root}. @table @var @item x Type @var{int16}. @item y Type @var{int16}. @item same-screen-p Type @var{boolean}. @item child Type @var{window} or @var{null}. @item state-mask Type @var{card16}. @item root-x Type @var{int16}. @item root-y Type @var{int16}. @item root Type @var{window}. @end table @end defun @defun global-pointer-position display @table @var @item display A @var{display}. @end table Returns the @emph{root} window currently containing the @emph{display} pointer and the current position of the pointer relative to the @emph{root}. @table @var @item root-x Type @var{int16}. @item root-y Type @var{int16}. @item root Type @var{window}. @end table @end defun @defun pointer-position window @table @var @item window A @var{window} specifying the coordinate system for the returned position. @end table Returns the current pointer coordinates relative to the given @emph{window}. If @var{pointer-position} returns @var{nil} for @emph{same-screen-p}, the pointer is not on the same screen as the @emph{window}. In this case, @var{pointer-position} returns a value of @var{nil} for @emph{child} and a value of zero for @emph{x} and @emph{y}. If @var{pointer-position} returns true for @emph{same-screen-p}, the returned @emph{x} and @emph{y} are relative to the origin of @emph{window}. @table @var @item x Type @var{int16}. @item y Type @var{int16}. @item same-screen-p Type @var{boolean}. @item child Type @var{window} or @var{null}. @end table @end defun @defun motion-events window &key :start :stop (:result-type 'list) @table @var @item window The @var{window} containing the returned motion events. @item :start @itemx :stop @var{timestamp} values for the time interval for returned motion events. @item :result-type The form of the returned motion events. @end table Many X server implementations maintain a more precise history of pointer motion between event notifications. The pointer position at each pointer hardware interrupt can be stored into a buffer for later retrieval.This is called the @emph{motion history buffer}. A paint program, for example, may want to have a precise history of where the pointer traveled, even though for most other applications this amount of detail is grossly excessive. The @var{motion-events} function returns all events in the motion history buffer that fall between the specified @var{:start} and @var{:stop} timestamps (inclusive) and have coordinates that lie within the specified @emph{window} (including borders) at its present placement. If the @var{:start} time is later than the @var{:stop} time or if the @var{:start} time is in the future, no events are returned. @table @var @item motion-events Type @code{(repeat-seq (int16 x) (int16 y) (timestamp time))}. @end table @end defun @defun warp-pointer destination destination-x destination-y @table @var @item destination The @var{window} into which the pointer is moved. @item destination-x @itemx destination-y The new position of the pointer relative to the destination. @end table Moves the pointer to the given coordinates relative to the @emph{destination} window. @var{warp-pointer} should be rarely be used since the user should normally be in control of the pointer position. @var{warp-pointer} generates events just as if the user had instantaneously moved the pointer from one position to another. @var{warp-pointer} cannot move the pointer outside the confine-to window of an active pointer grab; an attempt to do so only moves the pointer as far as the closest edge of the confine-to window. @end defun @defun warp-pointer-relative display x-offset y-offset @table @var @item display A @var{display}. @item x-offset @itemx y-offset The offsets used to adjust the pointer position. @end table Moves the pointer by the given offsets. This function should rarely be used since the user should normally be in control of the pointer position. @var{warp-pointer-relative} generates events just as if the user had instantaneously moved the pointer from one position to another. @var{warp-pointer-relative} cannot move the pointer outside the confine-to window of an active pointer grab; an attempt to do so only moves the pointer as far as the closest edge of the confine-to window. @end defun @defun warp-pointer-if-inside destination destination-x destination-y source source-x source-y &optional (source-width 0) (source-height 0) @table @var @item destination The @var{window} into which the pointer is moved. @item destination-x @itemx destination-y The new position of the pointer relative to the @emph{destination}. @item source The @var{window} that must currently contain the pointer. @item source-x @itemx source-y @itemx source-width @itemx source-height The source rectangle that must currently contain the pointer. @end table Moves the pointer to the given position relative to the @emph{destination} window. However, the move can only take place if the pointer is currently contained in a visible portion of the specified rectangle of the @emph{source} window. If @emph{source-height} is zero, it is replaced with the current height of @emph{source} window minus @emph{source-y}. If @emph{source-width} is zero, it is replaced with the current width of @emph{source} window minus @emph{source-x}. @var{warp-pointer-if-inside} generates events just as if the user had instantaneously moved the pointer from one position to another. @var{warp-pointer-if-inside} cannot move the pointer outside the confine-to window of an active pointer grab; an attempt to do so only moves the pointer as far as the closest edge of the confine-to window. @end defun @defun warp-pointer-relative-if-inside x-offset y-offset source source-x source-y &optional (source-width 0) (source-height 0) @table @var @item x-offset @itemx y-offset The offsets used to adjust the pointer position. @item source The @var{window} that must currently contain the pointer. @item source-x @itemx source-y @itemx source-width @itemx source-height The source rectangle that must currently contain the pointer. @end table Moves the pointer by the given offsets. However, the move can only take place if the pointer is currently contained in a visible portion of the specified rectangle of the @emph{source} window. If @emph{source-height} is zero, it is replaced with the current height of @emph{source-window} minus @emph{source-y}. If @emph{source-width} is zero, it is replaced with the current width of @emph{source-window} minus @emph{source-x}. @var{warp-pointer-relative-if-inside} generates events just as if the user had instantaneously moved the pointer from one position to another. @var{warp-pointer-relative-if-inside} cannot move the pointer outside the confine-to window of an active pointer grab; an attempt to do so only moves the pointer as far as the closest edge of the confine-to window. @end defun @node Managing Input Focus, Grabbing the Pointer, Pointer Position, Events and Input @section Managing Input Focus CLX provides the @var{set-focus-input} and @var{focus-input} functions to set and get the keyboard input focus window. @defun set-input-focus display focus revert-to &optional time @table @var @item display A @var{display}. @item focus The new input focus @var{window}. @item revert-to The focus @var{window} when focus is no longer viewable. @item time A @var{timestamp}. @end table Changes the keyboard input focus and the last-focus-change time. The function has no effect if the specified @emph{time} is earlier than the current last-focus-change time or is later than the current server time; otherwise, the last-focus-change time is set to the specified @emph{time}. The @var{set-input-focus} function causes the X server to generate @var{:focus-in} and @var{:focus-out} events. If @var{:none} is specified as the @emph{focus}, all keyboard events are discarded until a new focus window is set. In this case, the @emph{revert-to} argument is ignored. If a window is specified as the @emph{focus} argument, it becomes the keyboard's focus window. If a generated keyboard event would normally be reported to this window or one of its inferiors, the event is reported normally; otherwise, the event is reported with respect to the focus window. If @var{:pointer-root} is specified as the @emph{focus} argument, the input focus window is set to the root window of the screen containing the pointer when each keyboard event occurs. In this case, the @emph{revert-to} argument is ignored. The specified @emph{focus} window must be viewable at the time of the request. If the @emph{focus} window later becomes not viewable, the new focus window depends on the @emph{revert-to} argument. If @emph{revert-to} is specified as @var{:parent}, the @emph{focus} reverts to the parent (or the closest viewable ancestor) and the new @emph{revert-to} value is take to be @var{:none}. If @emph{revert-to} is @var{:pointer-root} or @var{:none}, the @emph{focus} reverts to that value. When the @emph{focus} reverts, @var{:focus-in} and @var{:focus-out} events are generated, but the last-focus-change time is not affected. @end defun @defun input-focus display @table @var @item display A @var{display}. @end table Returns the @emph{focus} window, @var{:pointer-root}, or @var{:none}, depending on the current state of the focus window. @emph{revert-to} returns the current focus revert-to state. @table @var @item focus Type (@var{or window} (@var{member :none :pointer-root})). @item revert-to Type (@var{or window} (@var{member :none :pointer-root :parent})). @end table @end defun @node Grabbing the Pointer, Grabbing a Button, Managing Input Focus, Events and Input @section Grabbing the Pointer CLX provides the @var{grab-pointer} and @var{ungrab-pointer} functions for grabbing and releasing pointer control. @defun grab-pointer window event-mask &key :owner-p :sync-pointer-p :sync-keyboard-p :confine-to :cursor :time @table @var @item window The @var{window} grabbing the pointer. @item event-mask A @var{pointer-event-mask}. @item :owner-p If true, all client windows receive pointer events normally. @item :sync-pointer-p Indicates whether the pointer is in synchronous or asynchronous mode. @item :sync-keyboard-p Indicates whether the keyboard is in synchronous or asynchronous mode. @item :confine-to A @var{window} to which the pointer is confined. @item :cursor A @var{cursor}. @item :time A @var{timestamp}. A @var{nil} value means the current server time is used. @end table Actively grabs control of the pointer. Further pointer events are only reported to the grabbing client. The request overrides any active pointer grab by this client. If @var{:owner-p} is @var{nil}, all generated pointer events are reported with respect to @emph{window}, and are only reported if selected by @emph{event-mask}. If @var{:owner-p} is true, and if a generated pointer event would normally be reported to this client, it is reported normally; otherwise the event is reported with respect to the @emph{window}, and is only reported if selected by @emph{event-mask}. For either value of @var{:owner-p}, unreported events are simply discarded. If @var{:sync-pointer-p} is @var{nil}, pointer event processing continues normally (asynchronously); if the pointer is currently frozen by this client, then processing of pointer events is resumed. If @var{:sync-pointer-p} is true (indicating a synchronous action), the pointer (as seen via the protocol) appears to freeze, and no further pointer events are generated by the server until the grabbing client issues a releasing @var{allow-events} request. Actual pointer changes are not lost while the pointer is frozen; they are simply queued for later processing. If @var{:sync-keyboard-p} is @var{nil}, keyboard event processing is unaffected by activation of the grab. If @var{:sync-keyboard-p} is true, the keyboard (as seen via the protocol) appears to freeze, and no further keyboard events are generated by the server until the grabbing client issues a releasing @var{allow-events} request. Actual keyboard changes are not lost while the keyboard is frozen; they are simply queued for later processing. If @var{:cursor} is specified, it is displayed regardless of what window the pointer is in. Otherwise, the normal cursor for the @emph{window} is displayed. If a @var{:confine-to} window is specified, the pointer is restricted to stay within that window. The @var{:confine-to} window does not need to have any relationship to the @emph{window}. If the pointer is not initially in the @var{:confine-to} window, it is warped automatically to the closest edge (with @var{:enter}/@var{:leave-events} generated normally) just before the grab activates. If the @var{:confine-to} window is subsequently reconfigured, the pointer is warped automatically as necessary to keep it contained in the window. @var{grab-pointer} generates @var{:enter-notify} and @var{:leave-notify} events. @var{grab-pointer} can fail with a status of: @itemize @bullet @item @var{:already-grabbed} if the pointer is actively grabbed by some other client @item @var{:frozen} if the pointer is frozen by an active grab of another client @item @var{:not-viewable} if the @emph{window} or the @var{:confine-to} window is not viewable, or if the @var{:confine-to} window lies completely outside the boundaries of the root window. @item @var{:invalid-time} if the specified time is earlier than the last-pointer-grab time or later than the current server time. Otherwise, the last-pointer-grab time is set to the specified time, with current-time replaced by the current server time, and a value of @var{:success} is returned by @var{grab-pointer}. @end itemize @table @var @item grab-status One of @var{:already-grabbed}, @var{:frozen}, @var{:invalid-time}, @var{:not-viewable}, or @var{:success}. @end table @end defun @defun ungrab-pointer display &key :time @table @var @item display A @var{display}. @item :time A @var{timestamp}. @end table Releases the pointer if this client has it actively grabbed (from either @var{grab-pointer}, @var{grab-button}, or from a normal button press), and releases any queued events. The request has no effect if the specified @var{:time} is earlier than the last-pointer-grab time or is later than the current server time. An @var{ungrabpointer} is performed automatically if the event window or @var{:confine-to} window for an active pointer grab becomes not viewable. This request generates @var{:enter-notify} and @var{:leave-notify} events. @end defun @defun change-active-pointer-grab display event-mask &optional cursor time @table @var @item display A @var{display}. @item event-mask A @var{pointer-event-mask}. @item cursor A @var{cursor} or @var{nil}. @item time A @var{timestamp}. @end table Changes the specified dynamic parameters if the pointer is actively grabbed by the client and the specified @emph{time} is no earlier than the last-pointer-grab time and no later than the current server time. The interpretation of @emph{event-mask} and @emph{cursor} are as in @var{grab-pointer}. @var{change-active-pointer-grab} has no effect on the passive parameters of a @var{grab-button}. @end defun @node Grabbing a Button, Grabbing the Keyboard, Grabbing the Pointer, Events and Input @section Grabbing a Button CLX provides the @var{grab-button} and @var{ungrab-button} functions for passively grabbing and releasing pointer control. @defun grab-button window button event-mask &key (:modifiers 0) :owner-p :sync-pointer-p :sync-keyboard-p :confine-to :cursor @table @var @item window A @var{window}. @item button The button (type @var{card8}) pressed or @var{:any}. @item event-mask A @var{pointer-event-mask}. @item :modifiers A @var{modifier-mask}. @item :owner-p If true, all client windows receive pointer events normally. @item :sync-pointer-p Indicates whether the pointer is handled in a synchronous or asynchronous fashion. @item :sync-keyboard-p Indicates whether the keyboard is in synchronous or asynchronous mode. @item :confine-to A @var{window} to which the pointer is confined. @item :cursor A @var{cursor}. @end table This request establishes a passive grab. If the specified @emph{button} is pressed when the specified modifier keys are down (and no other buttons or modifier keys are down), and: @itemize @bullet @item @emph{window} contains the pointer @item The @var{:confine-to} window (if any) is viewable @item These constraints are not satisfied for any ancestor of @emph{window} @end itemize then: @itemize @bullet @item The pointer is actively grabbed as described with @var{grab-pointer} @item The last-pointer-grab time is set to the time that the button was pressed (as transmitted in the @var{:button-press} event) @item The @var{:button-press} event is reported @end itemize The interpretation of the remaining arguments is the same as with @var{grab-pointer}. The active grab is terminated automatically when all buttons are released (independent of the state of modifier keys). A zero @emph{modifier} mask is equivalent to issuing the request for all possible modifier-key combinations (including the combination of no modifiers). It is not required that all specified modifiers have currently assigned keycodes. A @emph{button} of @var{:any} is equivalent to issuing the request for all possible buttons. Otherwise, it is not required that the specified @emph{button} currently be assigned to a physical button. @end defun @defun ungrab-button window button &key (:modifiers 0) @table @var @item window A @var{window}. @item button The button (type @var{card8}) that is released or @var{:any}. @item :modifiers A @var{modifier-mask}. @end table Releases the passive button/key combination on the specified @emph{window} if it was grabbed by this client. A zero @emph{modifier} mask is equivalent to issuing the request for all possible modifier combinations including the combination of no modifiers. A @emph{button} of @var{:any} is equivalent to issuing the request for all possible buttons. This has no effect on an active grab. @end defun @node Grabbing the Keyboard, Grabbing a Key, Grabbing a Button, Events and Input @section Grabbing the Keyboard CLX provides the @var{grab-keyboard} and @var{ungrab-keyboard} functions for actively grabbing and releasing control of the keyboard. @defun grab-keyboard window &key :owner-p :sync-pointer-p :sync-keyboard-p :time @table @var @item window A @var{window}. @item :owner-p If true, all client windows receive keyboard input normally. @item :sync-pointer-p Indicates whether the pointer is in synchronous or asynchronous mode. @item :sync-keyboard-p Indicates whether the keyboard is in synchronous or asynchronous mode. @item :time A @var{timestamp}. @end table Actively grabs control of the keyboard. Further key events are reported only to the grabbing client. The request overrides any active keyboard grab by this client. @var{grab-keyboard} generates @var{:focus-in} and @var{:focus-out} events. If @var{:owner-p} is @var{nil}, all generated key events are reported with respect to @emph{window}. If @var{:owner-p} is true, then a generated key event that would normally be reported to this client is reported normally; otherwise the event is reported with respect to the @emph{window}. Both @var{:key-press} and @var{:key-release} events are always reported, independent of any event selection made by the client. If @var{:sync-keyboard-p} is @var{nil}, keyboard event processing continues normally (asynchronously); if the keyboard is currently frozen by this client, then processing of keyboard events is resumed. If @var{:sync-keyboard-p} is true, the keyboard (as seen via the protocol) appears to freeze, and no further keyboard events are generated by the server until the grabbing client issues a releasing @var{allow-events} request. Actual keyboard changes are not lost while the keyboard is frozen; they are simply queued for later processing. If @var{:sync-pointer-p} is @var{nil}, pointer event processing is unaffected by activation of the grab. If @var{:sync-pointer-p} is true, the pointer (as seen via the protocol) appears to freeze, and no further pointer events are generated by the server until the grabbing client issues a releasing @var{allow-events} request. Actual pointer changes are not lost while the pointer is frozen; they are simply queued for later processing. The grab can fail with a status of: @itemize @bullet @item @var{:already-grabbed} if the keyboard is actively grabbed by some other client @item @var{:frozen} if the keyboard is frozen by an active grab from another client @item @var{:not-viewable} if @emph{window} is not viewable @item @var{:invalid-time} if the specified time is earlier than the last-keyboard-grab time or later than the current server time. Otherwise, @var{grab-keyboard} returns a status of @var{:success} and last-keyboard-grab time is set to the specified time, with current-time replaced by current server time. @end itemize @table @var @item grab-status One of @var{:already-grabbed}, @var{:frozen}, @var{:invalid-time}, @var{:not-viewable}, or @var{:success}. @end table @end defun @defun ungrab-keyboard display &key :time @table @var @item display A @var{display}. @item :time A @var{timestamp}. @end table Releases the keyboard if this client has it actively grabbed (from either @var{grab-keyboard} or @var{grab-key}), and releases any queued events. The request has no effect if the specified time is earlier than the last-keyboard-grab time or is later than the current server time. An @var{ungrab-keyboard} is performed automatically if the event window for an active keyboard grab becomes not viewable. @end defun @node Grabbing a Key, Event Types, Grabbing the Keyboard, Events and Input @section Grabbing a Key The following paragraphs describe the functions used for passively grabbing and releasing the keyboard. @defun grab-key window key &key (:modifiers 0) :owner-p :sync-pointer-p :sync-keyboard-p :time @table @var @item window A @var{window}. @item key The key (type @var{card8}) to be grabbed or @var{:any}. @item :modifiers A @var{modifier-mask}. @item :owner-p If true, all client windows receive keyboard input normally. @item :sync-pointer-p Indicates whether the pointer is in synchronous or asynchronous mode. @item :sync-keyboard-p Indicates whether the keyboard is in synchronous or asynchronous mode. @item :time A @var{timestamp}. @end table This request establishes a passive grab on the keyboard. If the specified @emph{key} (which can also be a modifier key) is pressed (whether or not any specified modifier keys are down), and either of the following is true: @itemize @bullet @item @emph{window} is an ancestor of (or is) the focus window @item @emph{window} is a descendant of the focus window and contains the pointer @item These constraints are not satisfied for any ancestor of @emph{window}, then the following occurs: @itemize @bullet @item The keyboard is actively grabbed as described in @var{grab-keyboard} @item The last-keyboard-grab time is set to the time that the @emph{key} was pressed (as transmitted in the @var{:key-press} event) @item The @var{:key-press} event is reported @end itemize @end itemize The interpretation of the remaining arguments is as for @var{grab-keyboard}. The active grab is terminated automatically when the specified @emph{key} has been released, independent of the state of the modifier keys. A zero modifier mask is equivalent to issuing the request for all possible modifier combinations (including the combination of no modifiers). It is not required that all specified modifiers have currently assigned keycodes. A @emph{key} of @var{:any} is equivalent to issuing the request for all possible keycodes. Otherwise, the @emph{key} must be in the range specified by @var{display-min-keycode} and @var{display-max-keycode} in the connection setup. @end defun @defun ungrab-key window key &key (:modifiers 0) @table @var @item window A @var{window}. @item key The key (type @var{card8}) to be released or @var{:any}. @item :modifiers A @var{modifier-mask}. @end table Releases the @emph{key} combination on the specified @emph{window} if it was grabbed by this client. A zero modifier mask of @var{:any} is equivalent to issuing the request for all possible modifier combinations (including the combination of no modifiers). A @emph{key} of @var{:any} is equivalent to issuing the request for all possible keycodes. @var{ungrab-key} has no effect on an active grab. @end defun @node Event Types, Releasing Queued Events, Grabbing a Key, Events and Input @section Event Types The following paragraphs contain detailed descriptions of the contents of each event type. In CLX, events are not actually represented by structures, but rather by lists of keyword values passed to handler functions or by values bound to symbols within the clauses of @var{event-case} and @var{event-cond} forms. Nevertheless, it is convenient to describe event contents in terms of slots and to identify the components of events with slot name symbols. In fact, CLX uses the @var{declare-event} macro to define event slot symbols and to map these symbols to specific event data items returned by the X server (@pxref{Declaring Event Types}). The following paragraphs describe each event type, listing its @var{event-key} keyword symbol and its slot name symbols. An event keyword symbol identifies a specific event type. An event keyword symbol can be given as an argument to @var{send-event} or to an event handler function; it can also appear in the @emph{event-match} form of an @var{event-case} clause. An event slot name symbol identifies a specific event data item. Event slot names appear as keywords with associated values among the arguments passed to @var{send-event} or to an event handler function; as non-keyword symbols, they can also be in the @emph{event-slots} form of an @var{event-case} clause. In certain cases, more than one name symbol is defined for the same event slot. For example, in @var{:key-press} events, the symbols @emph{window} and @emph{event-window} both refer to the same event data item. @menu * Keyboard and Pointer Events:: * Input Focus Events:: * Keyboard and Pointer State Events:: * Exposure Events:: * Window State Events:: * Structure Control Events:: * Client Communications Events:: * Declaring Event Types:: @end menu @node Keyboard and Pointer Events, Input Focus Events, Event Types, Event Types @subsection Keyboard and Pointer Events The keyboard and pointer events are: @var{:key-press} @var{:key-release}, @var{:button-press}, @var{:button-release}, @var{:motion-notify}, @var{:enter-notify}, and @var{:leave-notify}. @deftp {Event Type} :key-press @deftpx {Event Type} :key-release @deftpx {Event Type} :button-press @deftpx {Event Type} :button-release Selected by @var{:key-press}, @var{:key-release}, @var{:button-press}, or @var{:button-release}. @var{:key-press}, and @var{:key-release} events are generated when a key or pointer button changes state. Note that @var{:key-press} and @var{:key-release} are generated for all keys, even those mapped to modifiers. All of these event types have the same slots. The window containing the pointer at the time of the event is referred to as the @emph{source} window. The @emph{event} @emph{window} is the window to which the event is actually reported. The event window is found by starting with the source window and looking up the hierarchy for the first window on which any client has selected interest in the event (provided no intervening window prohibits event generation by including the event type in its do-not-propagate-mask). The actual window used for reporting can be modified by active grabs and, in the case of keyboard events, can be modified by the focus window. A @var{:button-press} event has the effect of a temporary @var{grab-button}. When a pointer button is pressed and no active pointer grab is in progress, the ancestors of the source window are searched from the @emph{root} down, looking for a passive grab to activate. If no matching passive grab on the button exists, then an active grab is started automatically for the client receiving the @var{:button-press} event, and the last-pointer-grab time is set to the current server time. The effect is essentially equivalent to calling @var{grab-button} with the following arguments: @table @var @item @emph{window} The event window. @item @emph{button} The button that was pressed. @item @emph{event-mask} The client's selected pointer events on the event window. @item @var{:modifiers} 0 @item @var{:owner-p} @var{t} if the client has @var{:owner-grab-button} selected on the event window; otherwise @var{nil}. @item @var{:sync-pointer-p} @var{nil} @item @var{:sync-keyboard-p} @var{nil} @item @var{:confine-to} @var{nil} @item @var{:cursor} @var{nil} @end table The @var{:button-press} grab is terminated automatically when all buttons are released. The functions @var{ungrab-pointer} and @var{change-active-pointer-grab} can both be used to modify the @var{:button-press} grab. @table @var @item window @item event-window Type @var{window}. The window receiving the event. @item code Type @var{card8}. The @emph{code} argument varies with the event type. For @var{:key-press} and @var{:key-release}, @emph{code} is the keycode (@pxref{Keyboard Encodings}). For @var{:button-press} and @var{:button-release}, @emph{code} is the pointer button number. @item x Type @var{int16}. If @emph{event-window} is on the same screen as root, then @emph{x} and @emph{y} are the pointer coordinates relative to the @emph{event-window}; otherwise @emph{x} and @emph{y} are zero. @item y Type @var{int16}. If @emph{event-window} is on the same screen as root, then @emph{x} and @emph{y} are the pointer coordinates relative to the @emph{event-window}; otherwise @emph{x} and @emph{y} are zero. @item state Type @var{card16}. A mask that gives the state of the buttons and modifier keys just before the event. @item time Type @var{card32}. A timestamp for the moment when the event occurred. @item root Type @var{window}. The root window of the source window. @item root-x Type @var{int16}. The x coordinate of the pointer position relative to root at the time of the event. @item root-y Type @var{int16}. The y coordinate of the pointer position relative to root at the time of the event@emph{.} @item child Type (@var{or null window}). If the source window is an inferior of the @emph{event-window}, @emph{child} is set to the child of @emph{event-window} that is an ancestor of (or is) the source window; otherwise, it is set to @var{nil}@emph{.} @item same-screen-p Type @var{boolean}. True if @emph{event-window} and root are on the same screen. @end table @end deftp @deftp {Event Type} :motion-notify Selected by: @var{:button-1-motion}, @var{:button-2-motion}, @var{:button-3-motion}, @var{:button-4-motion}, @var{:button-5-motion}, @var{:button-motion}, or @var{:pointer-motion}. The @var{:motion-notify} event is generated when the pointer moves. A @var{:motion-notify} event has the same slots as @var{:button-press} @var{:button-release}, @var{:key-press}, and @var{:key-release} events, with the exception that the @emph{code} slot is replaced by the @emph{hint-p} slot. As with these other events, the event window for @var{:motion-notify} is found by starting with the source window and looking up the hierarchy for the first window on which any client has selected interest in the event (provided no intervening window prohibits event generation by including @var{:motion-notify} in its do-not-propagate-mask).The actual window used for reporting can be modified by active grabs. @var{:motion-notify} events are generated only when the motion begins and ends in the window. The granularity of motion events is not guaranteed, but a client selecting for motion events is guaranteed to get at least one event when the pointer moves and comes to rest. Selecting @var{:pointer-motion} generates @var{:motion-notify} events regardless of the state of the pointer buttons. By selecting some subset of @var{:button[1-5]-motion} instead, @var{:motion-notify} events are only received when one or more of the specified buttons are pressed. By selecting @var{:button-motion}, @var{:motion-notify} events are only received when at least one button is pressed. If @var{:pointer-motion-hint} is also selected, the server is free to send only one @var{:motion-notify}, until either the key or button state changes, the pointer leaves the event window, or the client calls @var{query-pointer} or @var{motion-events}. @table @var @item hint-p Type @var{boolean}. True if the event is a hint generated by selecting @var{:pointer-motion-hint}. @end table @end deftp @deftp {Event Type} :enter-notify @deftpx {Event Type} :leave-notify @anchor{:enter-notify} Selected by: @var{:enter-window} or @var{:leave-window}. If pointer motion or a window hierarchy change causes the pointer to be in a different window than before, @var{:enter-notify} and @var{:leave-notify} events are generated instead of a @var{:motion-notify} event. All @var{:enter-notify} and @var{:leave-notify} events caused by a hierarchy change are generated after any hierarchy event (@var{:unmap-notify}, @var{:map-notify}, @var{:configure-notify}, @var{:gravity-notify}, or @var{:circulate-notify}) caused by that change, but the ordering of @var{:enter-notify} and @var{:leave-notify} events with respect to @var{:focus-out}, @var{:visibility-notify}, and @var{:exposure} events is not constrained by the X protocol. An @var{:enter-notify} or @var{:leave-notify} event can also be generated when a client application calls @var{change-active-pointer-grab}, @var{grab-pointer}, or @var{ungrab-pointer}. @table @var @item window @itemx event-window Type @var{window}. The window receiving the event. @item x Type @var{int16}. The final pointer position. If @emph{event-window} is on the same screen as root, then @emph{x} and @emph{y} are the pointer coordinates relative to the @emph{event-window}; otherwise @emph{x} and @emph{y} are zero. @item y Type @var{int16}. The final pointer position. If @emph{event-window} is on the same screen as root, then @emph{x} and @emph{y} are the pointer coordinates relative to the @emph{event-window}; otherwise @emph{x} and @emph{y} are zero. @item mode Type (@var{member :normal :grab :ungrab}). Events caused when the pointer is actively grabbed have mode @var{:grab}. Events caused when an active pointer grab deactivates have mode @var{:ungrab}. In all other cases, mode is @var{:normal}. @item kind Type (@var{member :ancestor :virtual :inferior :nonlinear} @var{:nonlinear-virtual}). When the pointer moves from window A to window B, and A is an inferior of B: @itemize @bullet @item @var{:leave-notify} with @emph{kind} @var{:ancestor} is generated on A @item @var{:leave-notify} with @emph{kind} @var{:virtual} is generated on each window between A and B exclusive (in that order) @item @var{:enter-notify} with @emph{kind} @var{:inferior} is generated on B @end itemize When the pointer moves from window A to window B, and B is an inferior of A: @itemize @bullet @item @var{:leave-notify} with @emph{kind} @var{:inferior} is generated on A @item @var{:enter-notify} with @emph{kind} @var{:virtual} is generated on each window between A and B exclusive (in that order) @item @var{:enter-notify} with @emph{kind} @var{:ancestor} is generated on B @end itemize When the pointer moves from window A to window B, with window C being their least common ancestor: @itemize @bullet @item @var{:leave-notify} with @emph{kind} @var{:nonlinear} is generated on A @item @var{:leave-notify} with @emph{kind} @var{:nonlinear-virtual} is generated on each window between A and C exclusive (in that order) @item @var{:enter-notify} with @emph{kind} @var{:nonlinear-virtual} is generated on each window between C and B exclusive (in that order) @item @var{:enter-notify} with @emph{kind} @var{:nonlinear} is generated on B @end itemize When the pointer moves from window A to window B, on different screens: @itemize @bullet @item @var{:leave-notify} with @emph{kind} @var{:nonlinear} is generated on A @item If A is not a root window, @var{:leave-notify} with @emph{kind} @var{:nonlinear-virtual} is generated on each window above A up to and including its root (in order) @item If B is not a root window, @var{:enter-notify} with @emph{kind} @var{:nonlinear-virtual} is generated on each window from B's root down to but not including B (in order) @item @var{:enter-notify} with @emph{kind} @var{:nonlinear} is generated on B @end itemize When a pointer grab activates (but after any initial warp into a confine-to window, and before generating any actual @var{:button-press} event that activates the grab), with @emph{G} the @var{grab-window} for the grab and @emph{P} the window the pointer is in, then @var{:enter-notify} and @var{:leave-notify} events with mode @var{:grab} are generated (as for @var{:normal} above) as if the pointer were to suddenly warp from its current position in @emph{P} to some position in @emph{G}. However, the pointer does not warp, and the pointer position is used as both the @emph{initial} and @emph{final} positions for the events. When a pointer grab deactivates (but after generating any actual @var{:button-release} event that deactivates the grab), with @emph{G} the @var{grab-window} for the grab and @emph{P} the window the pointer is in, then @var{:enter-notify} and @var{:leave-notify} events with mode @var{:ungrab} are generated (as for @var{:normal} above) as if the pointer were to suddenly warp from from some position in @emph{G} to its current position in @emph{P}. However, the pointer does not warp, and the current pointer position is used as both the @emph{initial} and @emph{final} positions for the events. @item focus-p Type @var{boolean}. If @emph{event-window} is the focus window or an inferior of the focus window, then @emph{focus-p} is @var{t}; otherwise, @emph{focus-p} is @var{nil}. @item state Type @var{card16}. A mask that gives the state of the buttons and modifier keys just before the event. @item time Type @var{card32}. A timestamp for the moment when the event occurred. @item root Type @var{window}. The root window containing the final pointer position. @item root-x Type @var{int16}. The x coordinate of the pointer position relative to root at the time of the event. @item root-y Type @var{int16}. The y coordinate of the pointer position relative to root at the time of the event. @item child Type (@var{or null window}). In a @var{:leave-notify} event, if a child of the @emph{event-window} contains the initial position of the pointer, the @emph{child} slot is set to that child; otherwise, the @emph{child} slot is @var{nil}. For an @var{:enter-notify} event, if a child of the @emph{event-window} contains the final pointer position, the @emph{child} slot is set to that child; otherwise, the @emph{child} slot is @var{nil}. @item same-screen-p Type @var{boolean}. True if @emph{event-window} and root are on the same screen. @end table @end deftp @node Input Focus Events, Keyboard and Pointer State Events, Keyboard and Pointer Events, Event Types @subsection Input Focus Events The input focus events are @var{:focus-in} and @var{:focus-out}. @deftp {Event Type} :focus-in @deftpx {Event Type} :focus-out Selected by: @var{:focus-change}. @var{:focus-in} and @var{:focus-out} events are generated when the input focus changes. All @var{:focus-out} events caused by a window @var{:unmap} are generated after any @var{:unmap-notify} event, but the ordering of @var{:focus-out} with respect to generated @var{:enter-notify}, @var{:leave-notify}, @var{:visibility-notify}, and @var{:expose} events is not constrained. @table @var @item window @itemx event-window Type @var{window}. For @var{:focus-in}, the new input focus window. For @var{:focus-out}, the previous input focus window. @item mode Type @code{(member :normal :while-grabbed :grab :ungrab)}. Events generated by @var{set-input-focus} when the keyboard is not grabbed have mode @var{:normal}. Events generated by @var{set-input-focus} when the keyboard is grabbed have mode @var{:while-grabbed}. Events generated when a keyboard grab activates have mode @var{:grab}, and events generated when a keyboard grab deactivates have mode @var{:ungrab}. @item kind Type (@var{member :ancestor :virtual :inferior :nonlinear :nonlinear-virtual :pointer :pointer-root :none}). When the focus moves from window A to window B, and A is an inferior of B, with the pointer in window P: @itemize @bullet @item @var{:focus-out} with @emph{kind} @var{:ancestor} is generated on A @item @var{:focus-out} with @emph{kind} @var{:virtual} is generated on each window between A and B exclusive (in that order) @item @var{:focus-in} with @emph{kind} @var{:inferior} is generated on B @item If P is an inferior of B, but P is not A or an inferior of A or an ancestor of A, @var{:focus-in} with @emph{kind} @var{:pointer} is generated on each window below B down to and including P (in order) @end itemize When the focus moves from window A to window B, and B is an inferior of A, with the pointer in window P: @itemize @bullet @item If P is an inferior of A, but P is not A or an inferior of B or an ancestor of B, @var{:focus-out} with @emph{kind} @var{:pointer} is generated on each window from P up to but not including A (in order) @item @var{:focus-out} with @emph{kind} @var{:inferior} is generated on A @item @var{:focus-in} with @emph{kind} @var{:virtual} is generated on each window between A and B exclusive (in that order) @item @var{:focus-in} with @emph{kind} @var{:ancestor} is generated on B @end itemize When the focus moves from window A to window B, with window C being their least common ancestor, and with the pointer in window P: @itemize @bullet @item If P is an inferior of A, @var{:focus-out} with @emph{kind} @var{:pointer} is generated on each window from P up to but not including A (in order) @item @var{:focus-out} with @emph{kind} @var{:nonlinear} is generated on A @item @var{:focus-out} with @emph{kind} @var{:nonlinear-virtual} is generated on each window between A and C exclusive (in that order) @item @var{:focus-in} with @emph{kind} @var{:nonlinear-virtual} is generated on each window between C and B exclusive (in that order) @item :focus-in with @emph{kind} @var{:nonlinear} is generated on B @item If P is an inferior of B, @var{:focus-in} with @emph{kind} @var{:pointer} is generated on each window below B down to and including P (in order) @end itemize When the focus moves from window A to window B, on different screens, with the pointer in window P: @itemize @bullet @item If P is an inferior of A, @var{:focus-out} with @emph{kind} @var{:pointer} is generated on each window from P up to but not including A (in order) @item @var{:focus-out} with @emph{kind} @var{:nonlinear} is generated on A @item If A is not a root window, @var{:focus-out} with @emph{kind} @var{:nonlinear-virtual} is generated on each window above A up to and including its root (in order) @item If B is not a root window, @var{:focus-in} with @emph{kind} @var{:nonlinear-virtual} is generated on each window from B's root down to but not including B (in order) @item @var{:focus-in} with @emph{kind} @var{:nonlinear} is generated on B @item If P is an inferior of B, @var{:focus-in} with @emph{kind} @var{:pointer} is generated on each window below B down to and including P (in order) @end itemize When the focus moves from window A to @var{:pointer-root} (or @var{:none}), with the pointer in window P: @itemize @bullet @item If P is an inferior of A, @var{:focus-out} with @emph{kind} @var{:pointer} is generated on each window from P up to but not including A (in order) @item @var{:focus-out} with @emph{kind} @var{:nonlinear} is generated on A @item If A is not a root window, @var{:focus-out} with @emph{kind} @var{:nonlinear-virtual} is generated on each window above A up to and including its root (in order) @item @var{:focus-in} with @emph{kind} @var{:pointer-root} (or @var{:none}) is generated on all root windows @item If the new focus is @var{:pointer-root}, @var{:focus-in} with @emph{kind} @var{:pointer} is generated on each window from P's root down to and including P (in order) @end itemize When the focus moves from @var{:pointer-root} (or @var{:none}) to window A, with the pointer in window P: @itemize @bullet @item If the old focus is @var{:pointer-root}, @var{:focus-out} with @emph{kind} @var{:pointer} is generated on each window from P up to and including P's root (in order) @item @var{:focus-out} with @emph{kind} @var{:pointer-root} (or @var{:none}) is generated on all root windows @item If A is not a root window, @var{:focus-in} with @emph{kind} @var{:nonlinear-virtual} is generated on each window from A's root down to but not including A (in order) @item @var{:focus-in} with @emph{kind} @var{:nonlinear} is generated on A @item If P is an inferior of A, @var{:focus-in} with @emph{kind} @var{:pointer} is generated on each window below A down to and including P (in order) @end itemize When the focus moves from @var{:pointer-root} to @var{:none} (or vice versa), with the pointer in window P: @itemize @bullet @item If the old focus is @var{:pointer-root}, @var{:focus-out} with @emph{kind} @var{:pointer} is generated on each window from P up to and including P's root (in order) @item @var{:focus-out} with @emph{kind} @var{:pointer-root} (or @var{:none}) is generated on all root windows @item @var{:focus-in} with @emph{kind} @var{:none} (or @var{:pointer-root}) is generated on all root windows @item If the new focus is @var{:pointer-root}, @var{:focus-in} with @emph{kind} @var{:pointer} is generated on each window from P's root down to and including P (in order) @end itemize @end table When a keyboard grab activates (but before generating any actual @var{:key-press} event that activates the grab), with @emph{G} the @var{grab-window} for the grab and @emph{F} the current focus, then @var{:focus-in} and @var{:focus-out} events with mode @var{:grab} are generated (as for @var{:normal} above) as if the focus were to change from @emph{F} to @emph{G}. When a keyboard grab deactivates (but after generating any actual @var{:key-release} event that deactivates the grab), with @emph{G} the @var{grab-window} for the grab and @emph{F} the current focus, then @var{:focus-in} and @var{:focus-out} events with mode @var{:ungrab} are generated (as for @var{:normal} above) as if the focus were to change from @emph{G} to @emph{F}. @end deftp @node Keyboard and Pointer State Events, Exposure Events, Input Focus Events, Event Types @subsection Keyboard and Pointer State Events The keyboard and pointer state events are @var{:keymap-notify} and @var{:mapping-notify}. @deftp {Event Type} :keymap-notify Selected by: @var{:keymap-state}. The @var{:keymap-notify} event returns the current state of the keyboard. @var{:keymap-notify} is generated immediately after every @var{:enter-notify} and @var{:focus-in}. @table @var @item window @itemx event-window Type @var{window}. The window receiving an @var{:enter-notify} or @var{:focus-in} event. @item keymap Type (@var{bit-vector 256}). A bit-vector containing the logical state of the keyboard. Each bit set to 1 indicates that the corresponding key is currently pressed. The vector is represented as 32 bytes. For @emph{n} from 0 to 7, byte @emph{n} (from 0) contains the bits for keys 8@emph{n} to 8@emph{n}+7, with the least significant bit in the byte representing key 8@emph{n}. @end table @end deftp @deftp {Event Type} :mapping-notify The X server reports @var{:mapping-notify} events to all clients. There is no mechanism to express disinterest in this event. The X server generates this event type whenever a client application calls one of the following: @itemize @bullet @item @var{set-modifier-mapping} to indicate which keycodes to use as modifiers (the status reply must be @var{:mapping-success}) @item @var{change-keyboard-mapping} to change the keyboard mapping @item @var{set-pointer-mapping} to set the pointer mapping (the status reply must be @var{:mapping-success}) @end itemize @table @var @item request Type (@code{member :modifier :keyboard :pointer}). Indicates the kind of change that occurred--@var{:modifier} for a successful @var{set-modifier-mapping}, @var{:keyboard} for a successful @var{change-keyboard-mapping}, and @var{:pointer} for a successful @var{set-pointer-mapping}. @item start Type @var{card8}. If request is @var{:keyboard}, then @emph{start} and @emph{count} indicate the range of altered keycodes. @item count Type @var{card8}. If request is @var{:keyboard}, then @emph{start} and @emph{count} indicate the range of altered keycodes. @end table @end deftp @node Exposure Events, Window State Events, Keyboard and Pointer State Events, Event Types @subsection Exposure Events The X server cannot guarantee that a window's content is preserved when the window is obscured or reconfigured. X requires client applications to be capable of restoring the contents of a previously-invisible window region whenever it is exposed. Therefore, the X server sends events describing the exposed window and its exposed region. For a simple window, a client can choose to redraw the entire content whenever any region is exposed. For a complex window, a client can redraw only the exposed region. @deftp {Event Type} :exposure @anchor{:exposure} Selected by: @var{:exposure}. An @var{:exposure} event is sent when redisplay is needed for a window region whose content has been lost. Redisplay is needed when one of the following occurs: @itemize @bullet @item A region is exposed for a window and the X server has no backing store for the region @item A region of a viewable window is obscured and the X server begins to honor the window's backing-store attribute of @var{:always} or @var{:when-mapped} @item The X server begins to honor an unviewable window's backing-store attribute of @var{:always} or @var{:when-mapped}. @end itemize The regions needing redisplay are decomposed into an arbitrary set of rectangles, and an @var{:exposure} event is generated for each rectangle. For a given action causing @var{:exposure} events, the set of events for a given window are guaranteed to be reported contiguously. @var{:exposure} events are never generated for @var{:input-only} windows. All @var{:exposure} events caused by a hierarchy change are generated after any hierarchy event (@var{:unmap-notify}, @var{:map-notify}, @var{:configure-notify},@var{:gravity-notify}, or @var{:circulate-notify}) caused by that change. All @var{:exposure} events on a given window are generated after any @var{:visibility-notify} event on that window, but it is not required that all @var{:exposure} events on all windows be generated after all visibility events on all windows. The ordering of @var{:exposure} events with respect to @var{:focus-out}, @var{:enter-notify}, and @var{:leave-notify} events is not constrained. @table @var @item window @itemx event-window Type @var{window}. The window needing redisplay. @item x Type @var{card16}. The position of the left edge of the region to redisplay, relative to the @emph{event-window}. @item y Type @var{card16}. The position of the top edge of the region to redisplay, relative to the @emph{event-window}. @item width Type @var{card16}. The width of the region to redisplay. @item height Type @var{card16}. The height of the region to redisplay. @item count Type @var{card16}. If count is zero, then no more @var{:exposure} events for this window follow. If count is nonzero, then at least that many more @var{:exposure} events for this window follow (and possibly more). @end table @end deftp @deftp {Event Type} :graphics-exposure A @var{:graphics-exposure} event is generated by a call to @var{copy-area} or @var{copy-plane} when the exposures attribute of the graphics context is @var{:on}. A @var{:graphics-exposure} event reports a destination region whose content cannot be computed because the content of the corresponding source region has been lost. For example, the missing source region may be obscured or may lie outside the current source drawable size. For a given action causing @var{:graphics-exposure} events, the set of events for a given destination are guaranteed to be reported contiguously. @table @var @item drawable @itemx event-window Type @var{drawable}. The destination drawable for the @var{copy-area} or @var{copy-plane} function. @item x Type @var{card16}. The position of the left edge of the destination region, relative to the @emph{drawable}. @item y Type @var{card16}. The position of the top edge of the destination region, relative to the @emph{drawable}. @item width Type @var{card16}. The width of the destination region. @item height Type @var{card16}. The height of the destination region. @item count Type @var{card16}. If count is zero then no more @var{:graphics-exposure} events for the @emph{drawable} follow. If count is nonzero then at least that many more @var{:graphics-exposure} events for the @emph{drawable} follow (and possibly more). @item major Type @var{card8}. The major opcode for the graphics request generating the event (62 for @var{copy-area}, 63 for @var{copy-plane}). @item minor Type @var{card16}. The minor opcode for the graphics request generating the event (0 for both @var{copy-area} and @var{copy-plane}). @end table @end deftp @deftp {Event Type} :no-exposure A @var{:no-exposure} event is generated by a call to @var{copy-area} or @var{copy-plane} when the exposures attribute of the graphics context is @var{:on}. If no @var{:graphics-exposure} events are generated, then a single @var{:no-exposure} event is sent. @table @var @item drawable @itemx event-window Type @var{drawable}. The destination drawable for the @var{copy-area} or @var{copy-plane} function. @item major Type @var{card8}. The major opcode for the graphics request generating the event (62 for @var{copy-area}, 63 for @var{copy-plane}). @item minor Type @var{card16}. The minor opcode for the graphics request generating the event (0 for both @var{copy-area} and @var{copy-plane}). @end table @end deftp @node Window State Events, Structure Control Events, Exposure Events, Event Types @subsection Window State Events The following paragraphs describe the events that can be received when a window becomes: @itemize @bullet @item Created @item Destroyed @item Invisible @item Mapped @item Moved @item Reparented @item Resized @item Restacked @item Unmapped @item Visible @end itemize @deftp {Event Type} :circulate-notify Selected by: @var{:structure-notify} on a window or @var{:substructure-notify} on its parent. A @var{:circulate-notify} event is generated whenever a window is actually restacked as a result of a client application calling @var{circulate-window-up} or @var{circulate-window-down}. @table @var @item event-window Type @var{window}. The window receiving the event. @item window Type @var{window}. The window that was restacked. @item place Type (@var{member :top :bottom}). If place is @var{:top}, the @emph{window} is now on top of all siblings. Otherwise, it is below all siblings. @end table @end deftp @deftp {Event Type} :configure-notify Selected by: @var{:structure-notify} on a window or @var{:substructure-notify} on its parent. The @var{:configure-notify} event is generated when the position or size of a window actually changes as a result of a client application setting its @emph{x}, @emph{y}, @emph{width}, @emph{height}, or @emph{border-width} attributes. @table @var @item event-window Type @var{window}. The window receiving the event. @item window Type @var{window}. The window that was moved or resized. @item x Type @var{int16}. @emph{x} and @emph{y} specify the new upper-left corner position of the @emph{window} relative to its parent. @item y Type @var{int16}. @emph{x} and @emph{y} specify the new upper-left corner position of the @emph{window} relative to its parent. @item width Type @var{card16}. @emph{width} and @emph{height} specify the new size of the @emph{window} interior. @item height Type @var{card16}. @emph{width} and @emph{height} specify the new size of the @emph{window} interior. @item border-width Type @var{card16}. The new @emph{window} border width. @item above-sibling Type (@var{or null window}). The sibling immediately below the @emph{window}. If above-sibling is @var{nil}, then the @emph{window} is below all of its siblings. @item override-redirect-p Type @var{boolean}. @emph{override-redirect-p} is true if the override-redirect attribute of the @emph{window} is @var{:on}; otherwise, it is @var{nil}. See @var{window-override-redirect} in @ref{Window Attributes}. @end table The X server can report @var{:create-notify} events to clients wanting information about creation of windows. The X server generates this event whenever a client application creates a window by calling @var{create-window}. To receive this event type in a client application, you @code{setf} the @var{:substructure-notify} as the event-mask in the parent window's event-mask slot. @end deftp @deftp {Event Type} :create-notify Selected by: @var{:substructure-notify}. The @var{:create-notify} event is generated when a @emph{window} is created and is sent to the @emph{parent} window. @table @var @item parent @itemx event-window Type @var{window}. The parent window receiving the event. @item window Type @var{window}. The new window created. @item x Type @var{int16}. @emph{x} and @emph{y} specify the initial upper-left corner position of the @emph{window} relative to the parent. @item y Type @var{int16}. @emph{x} and @emph{y} specify the initial upper-left corner position of the @emph{window} relative to the parent. @item width Type @var{card16}. @emph{width} and @emph{height} specify the initial size of the @emph{window} interior. @item height Type @var{card16}. @emph{width} and @emph{height} specify the initial size of the @emph{window} interior. @item border-width Type @var{card16}. The initial @emph{window} border width. @item override-redirect-p Type @var{boolean}. @emph{override-redirect-p} is true if the override-redirect attribute of the @emph{window} is @var{:on}; otherwise, it is @var{nil}. See @var{window-override-redirect} in @ref{Window Attributes}. @end table @end deftp @deftp {Event Type} :destroy-notify Selected by: @var{:structure-notify} on a window or @var{:substructure-notify} on its parent. The @var{:destroy-notify} event is generated when a @emph{window} is destroyed. The ordering of the @var{:destroy-notify} events is such that for any given window, @var{:destroy-notify} is generated on all inferiors of a window before @var{:destroy-notify} is generated on the @emph{window}. The ordering among siblings and across subhierarchies is not otherwise constrained. @table @var @item event-window Type @var{window}. The window receiving the event. @item window Type @var{window}. The window that was destroyed. @end table @end deftp @deftp {Event Type} :gravity-notify Selected by: @var{:structure-notify} on a window or @var{:substructure-notify} on its parent. The X server can report @var{:gravity-notify} events to clients wanting information about when a @emph{window} is moved because of a change in the size of its parent. The X server generates this event whenever a client application actually moves a child window as a result of resizing its parent by calling @var{with-state} with the appropriate arguments set. @table @var @item event-window Type @var{window}. The window receiving the event. @item window Type @var{window}. The window that was moved. @item x Type @var{int16}. x and y specify the new upper-left corner position of the @emph{window} relative to its parent. @item y Type @var{int16}. x and y specify the new upper-left corner position of the @emph{window} relative to its parent. @end table @end deftp @deftp {Event Type} :map-notify Selected by: @var{:structure-notify} on a window or @var{:substructure-notify} on its parent. The X server can report @var{:map-notify} events to clients wanting information about which windows are mapped. The X server generates this event type whenever a client application changes the @emph{window}'s state from unmapped to mapped by calling @var{map-window} or @var{map-subwindow}. To receive this event type, you @var{setf :structure-notify} as the event-mask on the @emph{window}'s @var{event-mask} slot. You can also receive this event type by @code{setf}ing the @var{:substructure-notify} event-mask on the parent window. @table @var @item event-window Type @var{window}. The window receiving the event. @item window Type @var{window}. The window that was mapped. @item override-redirect-p Type @var{boolean}. @emph{override-redirect-p} is true if the override-redirect attribute of the @emph{window} is @var{:on}; otherwise, it is @var{nil}. See @var{window-override-redirect} in @ref{Window Attributes}. @end table @end deftp @deftp {Event Type} :reparent-notify Selected by: @var{:structure-notify} on a window or @var{:substructure-notify} on its old or new parent. The @var{:reparent-notify} event is generated when a @emph{window} is reparented. @table @var @item event-window Type @var{window}. The window receiving the event. @item window Type @var{window}. The window that was reparented. @item parent Type @var{window}. The new parent of the @emph{window}. @item x Type @var{int16}. x and y specify the upper-left corner position of the @emph{window} relative to its new @emph{parent}. @item y Type @var{int16}. x and y specify the upper-left corner position of the @emph{window} relative to its new @emph{parent}. @item override-redirect-p Type @var{boolean}. @emph{override-redirect-p} is true if the override-redirect attribute of the @emph{window} is @var{:on}; otherwise, it is @var{nil}. See @var{window-override-redirect} in @ref{Window Attributes}. @end table @end deftp @deftp {Event Type} :unmap-notify Selected by: @var{:structure-notify} on a window or @var{:substructure-notify} on its parent. The @var{:unmap-notify} event is generated when a mapped @emph{window} is unmapped. @table @var @item event-window Type @var{window}. The window receiving the event. @item window Type @var{window}. The window that was unmapped. @item configure-p Type @var{boolean}. @emph{configure-p} is true if the @emph{window} has a win-gravity attribute of @var{:unmap}, and the event was generated because @emph{window}'s parent was resized. @end table @end deftp @deftp {Event Type} :visibility-notify Selected by: @var{:visibility-change}. The @var{:visibility-notify} event is sent when the visibility of a @emph{window} changes. @var{:visibility-notify} events are never generated on @var{:input-only} windows. For the purposes of this event, the visibility of the @emph{window} is not affected by its subwindows. All @var{:visibility-notify} events caused by a hierarchy change are generated after any hierarchy event caused by that change (for example, @var{:unmap-notify}, @var{:map-notify}, @var{:configure-notify}, @var{:gravity-notify}, or @var{:circulate-notify}). Any @var{:visibility-notify} event on a given window is generated before any @var{:exposure} events on that window, but it is not required that all @var{:visibility-notify} events on all windows be generated before all @var{:exposure} events on all windows. The ordering of @var{:visibility-notify} events with respect to @var{:focus-out}, @var{:enter-notify}, and @var{:leave-notify} events is not constrained. @table @var @item window @itemx event-window Type @var{window}. The window that changed in visibility. @item state Type (@var{member :unobscured :partially-obscured} @var{:fully-obscured}). When the @emph{window} was either unviewable or it was viewable and at least partially obscured, and the @emph{window} changed to viewable and completely unobscured, then @emph{state} is @var{:unobscured}. When the @emph{window} was either unviewable or it was viewable and completely obscured, and the @emph{window} changed to viewable and partially obscured, then @emph{state} is @var{:partially-obscured}. When the @emph{window} was either unviewable or it was at least partially visible, and the @emph{window} changed to viewable and completely obscured, then @emph{state} is @var{:fully-obscured}. @end table @end deftp @node Structure Control Events, Client Communications Events, Window State Events, Event Types @subsection Structure Control Events The following paragraphs describe events used to @emph{redirect} client requests that reconfigure, restack, or map a window. Structure control events are typically used only by window managers and not by ordinary client applications. Structure control events report redirected requests, allowing a window manager to modify the requests before they are actually performed. However, if the override-redirect attribute of a window is @var{:on}, then no requests are redirected and no structure control events are generated. @deftp {Event Type} :circulate-request The @var{:circulate-request} event is generated when a client application calls @var{circulate-window-up} or @var{circulate-window-down} with a window that has the override-redirect attribute @var{:off}. The @emph{window} argument specifies the window to be restacked, and @emph{place} specifies what the new position in the stacking order should be (either @var{:top} or @var{:bottom}). Selected by: @var{:substructure-redirect} on @emph{parent}. @table @var @item parent @itemx event-window Type @var{window}. The window receiving the event. The receiving client must have selected @var{:substructure-redirect} on this window. @item window Type @var{window}. The window to be restacked. @item place Type @code{(member :top :bottom)}. The new stacking priority requested for @emph{window}. @end table @end deftp @deftp {Event Type} :colormap-notify Selected by: @var{:colormap-change}. The @var{:colormap-notify} event is generated with @emph{new-p} @var{t} when the @emph{colormap} associated with a @emph{window} is changed, installed, or uninstalled. @table @var @item window @itemx event-window Type @var{window}. The window receiving the event. @item colormap Type @code{(or null colormap)}. The colormap attribute of the window. @item new-p Type @var{boolean}. If @emph{new-p} is true, then the @emph{window}'s colormap attribute has changed to the given @emph{colormap}. Otherwise, the @emph{window}'s colormap attribute has not, but the @emph{colormap} has been installed or uninstalled. @item installed-p Type @var{boolean}. If @emph{installed-p} is true, then the @emph{colormap} is currently installed. @end table @end deftp @deftp {Event Type} :configure-request Selected by:@var{:substructure-redirect} on parent. The @var{:configure-request} event is generated when a client program sets the @emph{x}, @emph{y}, @emph{width}, @emph{heigh}t, @emph{border-width} or stacking priority attributes of a window that has the override-redirect attribute @var{:off}. @table @var @item parent @itemx event-window Type @var{window}. The window receiving the event. The receiving client must have selected @var{:substructure-redirect} on this window. @item window Type @var{window}. The window to be reconfigured. @item x Type @var{int16}. @emph{x} and @emph{y} specify the requested upper-left corner position of the @emph{window} relative to the parent. If either @emph{x} or @emph{y} is not specified in the value-mask, then it is set to the current window position. @item y Type @var{int16}. @emph{x} and @emph{y} specify the requested upper-left corner position of the @emph{window} relative to the @emph{parent}. If either @emph{x} or @emph{y} is not specified in the @emph{value-mask}, then it is set to the current window position. @item width @itemx height Type @var{card16}. @emph{width} and @emph{height} specify the requested size of the @emph{window} interior. If either @emph{width} or @emph{height} is not specified in the @emph{value-mask}, then it is set to the current window size. @item border-width Type @var{card16} The requested @emph{window} border width. If @emph{border-width} is not specified in the @emph{value-mask}, then it is set to the current window @emph{border-width}. @item stack-mode Type @code{(member :above :below :top-if :bottom-if :opposite)}. @emph{stack-mode} and @emph{above-sibling} specify the requested stacking priority of the @emph{window}. If @emph{stack-mode} is not specified in the @emph{value-mask}, then it is set to @var{:above}. @item above-sibling Type (@var{or null window}). @emph{stack-mode} and @emph{above-sibling} specify the requested stacking priority of the @emph{window}. If @emph{above-sibling} is not specified in the @emph{value-mask}, then it is set to @var{nil}. @item value-mask Type @var{mask16}. Specifies the changed @emph{window} attributes contained in the redirected client request. Each 1 bit specifies that the corresponding attribute was changed. @end table @end deftp @deftp {Event Type} :map-request Selected by: @var{:substructure-redirect} on parent. The @var{:map-request} event is generated when a client application maps a @emph{window} that has the override-redirect attribute @var{:off}. @table @var @item parent @itemx event-window Type @var{window}. The window receiving the event. The receiving client must have selected @var{:substructure-redirect} on this window. @item window Type @var{window}. The window to be mapped. @end table @end deftp @deftp {Event Type} :resize-request Selected by: @var{:resize-redirect}. The @var{:resize-request} event is generated when a client program sets the @emph{width} or @emph{height} attributes of a @emph{window} that has the override-redirect attribute @var{:off}. @table @var @item window @itemx event-window Type @var{window}. The window to be resized. @item width @itemx height Type @var{card16}. @emph{width} and @emph{height} specify the requested size of the wi@emph{ndow} interior. If either @emph{width} or @emph{height} was unchanged in the client request, then it is set to the current window size. @end table @end deftp @node Client Communications Events, Declaring Event Types, Structure Control Events, Event Types @subsection Client Communications Events The client communications events discussed in the following paragraphs are: @var{:client-message}, @var{:property-notify}, @var{:selection-clear}, @var{:selection-request}, and @var{:selection-notify}. @deftp {Event Type} :client-message The @var{:client-message} event is generated exclusively by client calls to @var{send-event}. The X server places no interpretation on the @emph{type} or content of @emph{data} sent in a @var{:client-message}. A client can neither select @var{:client-message} events nor avoid receiving them. @table @var @item window @itemx event-window Type @var{window}. The window receiving the event. @item type Type @var{keyword}. An xatom keyword that specifies the type of client message. Interpretation of the type is determined solely by agreement between the sending and receiving clients. @item format Type (@var{member 8 16 32}). An integer that specifies whether @emph{data} should be viewed as a sequence of 8-bit, 16-bit, or 32-bit quantities. @item data Type @code{(sequence integer)}. The data content of the client message. @emph{data} always consists of 160 bytes -- depending on format, either 20 8-bit values, 10 16-bit values or 5 32-bit values. The amount of this data actually used by a particular client message depends on the type. @end table @end deftp @deftp {Event Type} :property-notify Selected by: @var{:property-change}. The @var{:property-notify} event is generated when a window property is changed or deleted. @table @var @item window @itemx event-window Type @var{window}. The window receiving the event. @item atom Type @var{keyword}. The property that was changed or deleted. @item state Type @code{(member :new-value :deleted)}. @emph{state} is @var{:new-value} if the property was changed using @var{change-property} or @var{rotate-properties}, even if zero-length data was added or if all or part of the property was replaced with identical data. @emph{state} is @var{:deleted} if the property was deleted using @var{delete-property} or @var{get-property}. @item time Type @var{timestamp}. The server time when the property was changed or deleted. @end table @end deftp @deftp {Event Type} :selection-clear The @var{:selection-clear} event is reported to the previous owner of a @emph{selection} when the owner of the @emph{selection} is changed. The selection owner is changed by a client using @code{setf}. A client can neither select @var{:selection-clear} events nor avoid receiving them. @table @var @item window @itemx event-window Type @var{window}. The window losing ownership of the @emph{selection}. @item selection Type @var{keyword}. The name of the selection. @item time Type @var{timestamp}. The last-change time recorded for the @emph{selection}. @end table @end deftp @deftp {Event Type} :selection-notify The @var{:selection-notify} event is sent to a client calling @var{convert-selection}. @var{:selection-notify} reports the result of the client request to return the current value of a @emph{selection} into a particular form. @var{:selection-notify} is sent using @var{send-event} by the owner of the selection or (if no owner exists) by the X server. A client can neither select @var{:selection-notify} events nor avoid receiving them. @var{NOTE:} Standard conventions for inter-client communication require the following additional steps in processing a @var{:selection-notify} event: @enumerate @item The client receiving this event should call @var{get-property} to return the converted selection value. @item After receiving the selection value, the property should then be deleted (either by using the @var{:delete-p} argument to @var{get-property} or by calling @var{delete-property}). @end enumerate @table @var @item window @itemx event-window Type @var{window}. The requestor window given in the call to @var{convert-selection}. @item selection Type @var{keyword}. The selection to be converted. @item target Type @var{keyword}. An @var{xatom} specifying the type of the converted selection value. This is the same target type given in the call to @var{convert-selection}. @item property Type @code{(or null keyword)}. The window property containing the converted selection. If the property is @var{nil}, then either the @emph{selection} has no owner or the owner could not perform the conversion to the @emph{target} type. @item time Type @var{timestamp}. The timestamp from the client call to @var{convert-selection}. @end table @end deftp @deftp {Event Type} :selection-request The @var{:selection-request} event is reported to the owner of a selection when a client calls @var{convert-selection}. This event requests the selection owner to convert the current value of a @emph{selection} into a specified form and to return it to the requestor. A client can neither select @var{:selection-request} events nor avoid receiving them. The selection owner should respond to a @var{:selection-request} event by performing the following steps: @enumerate @item Convert the current @emph{selection} value to the @emph{target} type. @item Store the converted selection value in the @emph{property}. If @emph{property} is @var{nil}, then the owner should choose the @emph{property}. @item Call @var{send-event} to send a @var{:selection-notify} event to the @emph{requestor} containing the @emph{property} with the converted value. If the @emph{selection} could not be converted to the @emph{target} type, then a @var{nil} @emph{property} should be sent. The @var{:selection}, @var{:target}, and @var{:time} arguments to @var{send-event} should be the same as those received in the @var{:selection-request} event. The event-mask argument to @var{send-event} should be @var{nil}; that is, the @var{:selection-notify} event should be sent to client that created the @emph{requestor}. @end enumerate @var{NOTE:} Standard conventions for inter-client communication require the following additional steps in processing a @var{:selection-request} event: @enumerate @item The property used to store the selection value must belong to the requestor. @item If the property is @var{nil}, the target type @var{atom} should be used as the property name. @item If the window did not actually own the selection at the given time, the request should be refused, just as if it could not be converted to the target type. @end enumerate @table @var @item window @itemx event-window Type @var{window}. The selection owner receiving the event. @item requestor Type @var{window}. The window requesting the converted @emph{selection}. @item selection Type @var{keyword}. The selection to be converted. @item target Type @var{keyword}. An @var{xatom} specifying the type of the converted @emph{selection} value. @item property Type @code{(or null keyword)}. A requestor window property. @item time Type @var{timestamp}. The timestamp sent in the client @var{convert-selection} request. @end table @end deftp @node Declaring Event Types, , Client Communications Events, Event Types @subsection Declaring Event Types CLX uses the @var{declare-event} macro to define the event slot symbols that access the contents of X events. Most client applications do not need to use @var{declare-event} because the declarations for all core X events are already defined by CLX. Programmers using extensions to the X protocol can use @var{declare-event} to allow CLX to handle new event types returned by an extended X server. @defmac declare-event event-codes &rest slot-declarations Defines a mapping between event slot symbols and the data items in event messages received from an X server. The @emph{event-codes} argument gives the event type keyword for the event described. If several event types share the same slots, then @emph{event-codes} can be a list of event type keywords. @emph{slot-declarations} is a list containing an element for each event data item. The order of @emph{slot-declarations} corresponds to the order of event data items defined by the X protocol. Each element of @emph{slot-declarations} is a list of the form (@emph{type slot-name}*), where @emph{type} is a Common Lisp type specifier and @emph{slot-name} is a slot name symbol. The effect of such a list is to declare that the next data items in the event have the given data @emph{type} and are associated with the given @emph{slot-name} symbols. @emph{slot-name} can also be a list of slot name symbols; in this case, each symbol in the list is an alias that refers to the same event data item. @table @var @item event-codes An event type keyword or a list of event type keywords. @item slot-declarations A list of clauses defining event slot symbols. @end table @end defmac @node Releasing Queued Events, , Event Types, Events and Input @section Releasing Queued Events A client grabbing the keyboard or pointer can freeze the reporting of events on that device. When an input device is thus frozen, the server queues events until explicitly requested to release them by the grabbing client. CLX programs can use the @var{allow-events} function to release queued events from a frozen input device. @defun allow-events display mode &optional time @table @var @item display A @var{display}. @item mode One of: @var{:async-pointer}, @var{:sync-pointer}, @var{:reply-pointer}, @var{:async-keyboard}, @var{:sync-keyboard}, @var{:replay-keyboard}, @var{:async-both}, @var{:sync-both}. @item time A @var{timestamp}. @end table Releases some queued events if the client has caused a device to freeze. The request has no effect if the @emph{time} is earlier than the last-grab time of the most recent active grab for the client, or if the @emph{time} is later than the current server time. If @emph{time} is @var{nil}, the current server time is used. The effect of this function depends on the specified @emph{mode}. @itemize @bullet @item @var{:async-pointer} -- If the pointer is frozen by the client, pointer event processing continues normally. If the pointer is frozen twice by the client on behalf of two separate grabs, @var{:async-pointer} releases events for both grab@emph{s}. @var{:async-pointer} has no effect if the pointer is not frozen by the client, but the pointer need not be grabbed by the client. @item @var{:sync-pointer} -- If the pointer is frozen and actively grabbed by the client, pointer event processing continues normally until the next @var{:button-press} or @var{:button-release} event is reported to the client, at which time the pointer again appears to freeze. However, if the reported event causes the pointer grab to be released, the pointer does not freeze. @var{:sync-pointer} has no effect if the pointer is not frozen by the client, or if the pointer is not grabbed by the client. @item @var{:replay-pointer} -- If the pointer is actively grabbed by the client and is frozen as the result of an event having been sent to the client (either from the activation of a @var{grab-button}, or from a previous @var{allow-events} with mode @var{:sync-pointer}, but not from a @var{grab-pointer}), the pointer grab is released and that event is completely reprocessed, but this time ignoring any passive grabs at or above (towards the root) the @var{grab-window} of the grab just released. The request has no effect if the pointer is not grabbed by the client, or if the pointer is not frozen as the result of an event. @item @var{:async-keyboard} -- If the keyboard is frozen by the client, keyboard event processing continues normally. If the keyboard is frozen twice by the client on behalf of two separate grabs, @var{:async-keyboard} releases events for both grabs. @var{:async-keyboard} has no effect if the keyboard is not frozen by the client, but the keyboard need not be grabbed by the client. @item @var{:sync-keyboard} -- If the keyboard is frozen and actively grabbed by the client, keyboard event processing continues normally until the next @var{:key-press} or @var{:key-release} event is reported to the client, at which time the keyboard again appears to freeze. However if the reported event causes the keyboard grab to be released, the keyboard does not freeze. @var{:sync-keyboard} has no effect if the keyboard is not frozen by the client, or if the keyboard is not grabbed by the client. @item @var{:replay-keyboard} -- If the keyboard is actively grabbed by the client and is frozen as the result of an event having been sent to the client (either from the activation of a grab-key, or from a previous @var{allow-events} with mode @var{:sync-keyboard}, but not from a @var{grab-keyboard}), the keyboard grab is released and that event is completely reprocessed, but this time ignoring any passive grabs at or above (towards the root) the @var{grab-window} of the grab just released. The request has no effect if the keyboard is not grabbed by the client, or if the keyboard is not frozen as the result of an event. @item @var{:sync-both} -- If both pointer and keyboard are frozen by the client, event processing (for both devices) continues normally until the next @var{:button-press}, @var{:button-release}, @var{:key-press}, or @var{:key-release} event is reported to the client for a grabbed device (button event for the pointer, key event for the keyboard). At this time, the devices again appear to freeze. If the reported event causes the grab to be released, the devices do not freeze. However, if the other device is still grabbed, then a subsequent event for it will still cause both devices to freeze. @var{:sync-both} has no effect unless both pointer and keyboard are frozen by the client. If the pointer of keyboard is frozen twice by the client on behalf of two separate grabs, @var{:sync-both} @emph{thaws} for both, but a subsequent freeze for @var{:sync-both} will only freeze each device once. @item @var{:async-both} -- If the pointer and the keyboard are frozen by the client, event processing for both devices continues normally. If a device is frozen twice by the client on behalf of two separate grabs, @var{:async-both} @emph{thaws} for both. @var{:async-both} has no effect unless both pointer and keyboard are frozen by the client. @end itemize @var{:async-pointer}, @var{:sync-pointer}, and @var{:replay-pointer} have no effect on processing of keyboard events. @var{:async-keyboard}, @var{:sync-keyboard}, and @var{:replay-keyboard} have no effect on processing of pointer events. It is possible for both a pointer grab and a keyboard grab to be active simultaneously by the same or different clients. When a device is frozen on behalf of either grab, no event processing is performed for the device. It is possible for a single device to be frozen due to both grabs. In this case, the freeze must be released on behalf of both grabs before events can again be processed. @end defun @node Resources, Control Functions, Events and Input, Top @chapter Resources Users need a way to specify preferences for various user interface values (for example, colors, fonts, title strings, and so forth). Applications need a consistent method for determining the default interface values that are specific to them. It is also useful if application interface values can be modified by users without changes to the program code. For example, this capability can make it easy to change the color scheme of a user interface. In CLX, such interface values are referred to as @emph{resources}. CLX defines functions for storing and retrieving interface resources from a resource database. A user can store various user interface values as resources in a resource database; a CLX application can then read these resource values and modify its user interface accordingly. @var{NOTE:} The general term @emph{resource} refers to any application user interface value stored in a resource database. The term @emph{server resource} is used more specifically to refer to the types of objects allocated by an X server and referenced by clients (for example, windows, fonts, graphics contexts, and so forth). @menu * Resource Binings:: * Basic Resource Database Functions:: * Accessing Resource Values:: * Resource Database Files:: @end menu @node Resource Binings, Basic Resource Database Functions, Resources, Resources @section Resource Binings Conceptually, a resource database is a set of resource name-value pairs (or @emph{resource bindings}). The name in a resource binding is a list that is the concatenation of a @emph{path list} and an @emph{attribute name}. A path list is a list of symbols (or strings) that corresponds to a path through a tree-structured hierarchy. For example, the path: @lisp '(top middle bottom) @end lisp corresponds to a three-level hierarchy in which @code{middle} is the child of @code{top}, and @code{bottom} is the child of @code{middle}. Typically, the path of a resource name corresponds to a path in a hierarchy of windows, and each symbol/string names a window in the hierarchy. However, the first element of the path can also represent the overall name of the entire program, and subsequent path elements can refer to an application-specific hierarchy of resource names not strictly related to windows. In addition, a resource name can contain a partially-specified path list. The asterisk symbol (*) is a wildcard that can correspond to any sequence of levels in the hierarchy (including the null sequence). For example, the path: @lisp '(top * bottom) @end lisp corresponds to a hierarchy of two or more levels in which @code{top} is at the top level and @code{bot-} @code{tom} is at the bottom level. An element of a path list can be the name of an individual window or the name of a class of windows. The final element of a resource name list is an attribute name. This symbol (or string) identifies a specific attribute of the object(s) named by the preceding path list. The attribute name can also be the symbol * or the string "*", in which case the resource name refers to all attributes of the path object(s). However, this form of resource name is rarely useful. Some examples of resource bindings are shown below. In these examples, assume that @code{mail} is the resource name of a mail reading application. @code{mail} uses a window of the class @code{button} whose name is @code{reply}. @multitable {Resource Name} {Resource Value} @item @code{(mail screen-1 reply background)} @tab @code{'green} @item @code{(mail * background)} @tab @code{'red} @item @code{(* button background)} @tab @code{'blue} @end multitable These resource bindings specify the following: @itemize @bullet @item The @code{background} attribute resource of @code{mail} application@emph{'}s @code{reply} button has the value of @code{green} on @code{screen-1}. @item The @code{background} attribute for the rest of the @code{mail} application is always @code{red} on all screens. @item In general, the @code{background} attribute for all @code{button} windows is @code{blue}. @end itemize @node Basic Resource Database Functions, Accessing Resource Values, Resource Binings, Resources @section Basic Resource Database Functions A @var{resource-database} structure is a CLX object that represents a set of resource bindings. The following paragraphs describe the CLX functions used to: @itemize @bullet @item Create a resource database @item Add a resource binding @item Remove a resource binding @item Merge two resource databases @item Map a function over the contents of a resource database @end itemize @defun make-resource-database @table @var @item resource-database Type @var{resource-database}. @end table Returns an empty resource database. @end defun @defun add-resource database name-list value @table @var @item database The @var{resource-database} for the new resource binding. @item name-list A list containing strings or symbols specifying the name for the resource binding. @item value The value associated with the @emph{name-list} in the resource binding. This can be an object of any type. @end table Adds the resource binding specified by @emph{name-list} and @emph{value} to the given @emph{database}. Only one value can be associated with the @emph{name-list} in the @emph{database}. This function replaces any value previously associated with the @emph{name-list}. @end defun @defun delete-resource database name-list @table @var @item database The @var{resource-database} containing the resource binding. @item name-list A list containing strings or symbols specifying the name for the deleted resource binding. @end table Removes the resource binding specified by @emph{name-list} from the given @emph{database}. @end defun @defun map-resource database function &rest args @table @var @item database A @var{resource-database}. @item function A @var{function} object or function symbol. @item args A list of arguments to the @emph{function}. @end table Calls the function for each resource binding in the @emph{database}. For each resource binding consisting of a @emph{name-list} and a @emph{value}, the form (@var{apply} @emph{function name-list value args}) is executed. @end defun @defun merge-resources from-database to-database @table @var @item from-database The @var{resource-database} from which resource bindings are read. @item to-database The @var{resource-database} to which resource bindings are added. @end table Merges the contents of the @emph{from-database} with the @emph{to-database}. @var{map-resource} invokes @var{add-resource} in order to add each resource binding in the @emph{from-database} to the @emph{to-database}. The updated @emph{to-database} is returned. @table @var @item to-database Type @var{resource-database}. @end table @end defun @node Accessing Resource Values, Resource Database Files, Basic Resource Database Functions, Resources @section Accessing Resource Values The power and flexibility of resource management is the result of the way resource values in a resource database are accessed. A resource binding binding stored in the database generally contains only a partial resource name consisting of a mixture of name and class identifiers and wildcard elements (that is, *). To look up a resource value, an application program starts with two resource name lists of the same length containing no wildcard elements -- a @emph{complete resource name} and a @emph{complete} @emph{resource class}. The lookup algorithm returns the value for the resource binding whose resource name is the closest match to the complete name and class given. The definition of @emph{closest match} takes into account the top-down, parent-child hierarchy of resource names and also the distinction between individual names and class names. @menu * Complete Names and Classes:: * Matching Resource Names:: * Resource Access Functions:: @end menu @node Complete Names and Classes, Matching Resource Names, Accessing Resource Values, Accessing Resource Values @subsection Complete Names and Classes A resource binding contains a resource name list that can contain names, class names, or a mixture of both. A class name is a symbol or string that represents a group of related objects. The set of names used as class names are not specified by CLX. Instead, class names are defined by agreement between those who use class names when creating resource bindings (that is, users) and those who use class names when accessing resource values (that is, application programmers). In order to access a value in a resource database, an application uses a key consisting of two items: a @emph{complete resource name} and a @emph{complete resource class}. A complete resource name is a resource name list containing no wildcard elements. A complete resource class is a list of exactly the same form. The distinction between a complete resource name and a complete resource class lies in how they are used to access resource bindings. The elements of a complete resource name are interpreted as names of individual objects; the elements of a complete resource class are interpreted as names of object classes. The complete resource name and class lists used in a resource database access must have the same length. Like any resource name list, a complete resource name consists of a path list and an attribute name. The first path list element is typically a symbol (or string) identifying the application as a whole. The second element can be a screen root identifier. Subsequent elements can be identifiers for each ancestor window of an application window. Thus, a path list typically identifies a specific window by tracing a path to it through the application window hierarchy. The final element of a complete resource name (its attribute name) is typically the name of a specific attribute of the window given by the path list (for example, @code{'background}). An attribute name can refer to a feature associated with the window by the application but not by the X server (for example, a font identifier). Similarly, a complete resource class typically represents a path to a window in the application window hierarchy and a specific window attribute. However, a complete resource class contains the class name for each window and for the window attribute. For instance, in the previous example, the @code{mail} application can attempt to look up the value of the @code{background} resource for the @code{reply button} window by using the following complete resource name: @lisp (mail screen-1 reply background) @end lisp and the following complete resource class: @lisp (application root button fill) @end lisp This complete resource name contains a path list identifying the reply button window -- @code{(mail screen-1 reply)} -- and an attribute name for the window background. The corresponding resource class contains the class names for the same path list and window attribute. @node Matching Resource Names, Resource Access Functions, Complete Names and Classes, Accessing Resource Values @subsection Matching Resource Names The resource lookup algorithm searches a specified resource data base and returns the value for the resource binding whose resource name is the closest match to a given complete resource name and class. The intent of the lookup algorithm is to formalize an intuitive notion of the closest match. Precedence is given to a match which begins @emph{higher} in the parent-child contact hierarchy. This allows a resource binding with a partial name to define a resource value shared by all members of a window subtree. For example, suppose the resource database contained the following resource bindings: @multitable {Resource Name} {Resource Value} @item @code{(mail * background)} @tab @code{'red} @item @code{(* reply background)} @tab @code{'blue} @end multitable Suppose an application program searched by using the following complete resource name: @lisp (mail screen-1 reply background) @end lisp then the closest matching value returned would be @code{'red}. Precedence is given to the more specific match. A name match is more specific than a class match. Either a name or class match is more specific than a wildcard match. For example, suppose the resource database contained the following resource bindings: @multitable {Resource Name} {Resource Value} @item @code{(mail * background)} @tab @code{'red} @item @code{(mail * fill)} @tab @code{'blue} @end multitable Suppose an application program searched by using the following complete resource name and complete resource class: @lisp (mail screen-1 reply background) (application root button fill) @end lisp then the closest matching value returned would be @code{'red}. However, suppose the resource database contained the following resource bindings: @multitable {Resource Name} {Resource Value} @item @code{(mail * background)} @tab @code{'red} @item @code{(mail * button background)} @tab @code{'blue} @end multitable then the closest matching value returned would be @code{'blue}. @node Resource Access Functions, , Matching Resource Names, Accessing Resource Values @subsection Resource Access Functions The following paragraphs describe the CLX functions used to return a value from a resource database. @defun get-resource database attribute-name attribute-class path-name path-class @table @var @item database A @var{resource-database}. @item attribute-name A string or symbol giving an attribute name from a complete resource name. @item attribute-class A string or symbol giving an attribute class name from a complete resource class. @item path-name The path list from a complete resource name. @emph{path-name} and @emph{path-class} must have the same length. @item path-class The path list from a complete resource class. @emph{path-name} and @emph{path-class} must have the same length. @end table Returns the value of the resource binding in the @emph{database} whose resource name most closely matches the complete resource name/class given by the @emph{path-name}, @emph{path-class}, @emph{attribute-name}, and @emph{attribute-class}. The lookup algorithm implements the precedence rules described previously to determine the closest match. When comparing name elements, case is significant only if both elements are strings; otherwise, element matching is case-insensitive. @table @var @item value Type @var{t}. @end table @end defun @defun get-search-table database path-name path-class @table @var @item database A @var{resource-database}. @item path-name The path list from a complete resource name. @emph{path-name} and @emph{path-class}must have the same length. @item path-class The path list from a complete resource class. @emph{path-name} and @emph{path-class} must have the same length. @end table Returns a table containing the subset of the @emph{database} that matches the @emph{path-name} and @emph{path-class}. Resources using the same @emph{path-name} and @emph{path-class} can be accessed much more efficiently by using this table as an argument to @var{get-search-resource}. @table @var @item search-table Type @var{list}. @end table @end defun @defun get-search-resource table attribute-name attribute-class @table @var @item table A search table returned by @var{get-search-table}. @item attribute-name A string or symbol giving an attribute name from a complete resource name. @item attribute-class A string or symbol giving an attribute class name from a complete resource class. @end table Returns the value of the resource binding in the search @emph{table} that most closely matches the @emph{attribute-name} and @emph{attribute-class}. The @emph{table} is computed by @var{get-search-table} and represents a set of resource bindings. The closest match is determined by the same algorithm used in @var{get-resource}. The following two forms are functionally equivalent: @lisp (get-resource database attribute-name attribute-class path-name path-class) (get-search-resource (get-search-table database path-name path-class) attribute-name attribute-class) @end lisp However, the hard part of the search is done by @var{get-search-table}. Looking up values for several resource attributes that share the same path list can be done much more efficiently with calls to @var{get-search-resource}. @table @var @item value Type @var{t}. @end table @end defun @node Resource Database Files, , Accessing Resource Values, Resources @section Resource Database Files X users and application programs can save resource bindings in a file, using a standard file format shared by all X clients. The following paragraphs describe the CLX functions used to convert between the standard external format of resource files and the internal resource-database format used by application programs. @defun read-resources database pathname &key :key :test :test-not @table @var @item database The @var{resource-database} to merge. @item pathname A pathname for the resource file to read. @item :key A function used to convert a value from the resource file into a resource binding value. @item :test @itemx :test-not Functions used to select which resource bindings from the resource file are merged with the @emph{database}. @end table Reads resource bindings from a resource file in standard X11 format and merges them with the given resource @emph{database}. The @var{:key} function is called to convert a file resource value into the value stored in the @emph{database}. By default, @var{:key} is @var{#'identity}. The @var{:test} and @var{:test-not} functions are predicates that select resource bindings to merge, based on the result of the @var{:key} function. For each file resource binding consisting of a @emph{resource-name} and a @emph{resource-value}, the @var{:test} (or @var{:test-not}) function is called with the arguments @emph{resource-name} and (@var{funcall} @emph{key resource-value}). @table @var @item database Type @var{resource-database}. @end table @end defun @defun write-resources database pathname &key :write :test :test-not @table @var @item database The @var{resource-database} to write. @item pathname A pathname of the file to write. @item :write A function for writing resource values. @item :test @itemx :test-not Functions used to select which resource bindings from the resource file are merged with the @emph{database}. @end table Writes resource bindings found in the @emph{database} to the file given by the @emph{pathname}. The output file is written in the standard X11 format. The @var{:write} function is used for writing resource values; the default is @var{#'princ}. The @var{:write} function is passed two arguments: a @emph{resource-value} and a @emph{stream}. The @var{:test} and @var{:test-not} functions are predicates which select resource bindings to write. For each resource binding consisting of a @emph{resource-name} and a @emph{resource-value}, the @var{:test} (or @var{:test-not}) function is called with the arguments @emph{resource-name} and @emph{resource-value}. @end defun @node Control Functions, Extensions, Resources, Top @chapter Control Functions @menu * Grabbing the Server:: * Pointer Control:: * Keyboard Control:: * Keyboard Encodings:: * Client Termination:: * Managing Host Access:: * Screen Saver:: @end menu @node Grabbing the Server, Pointer Control, Control Functions, Control Functions @section Grabbing the Server Certain cases may require that a client demand exclusive access to the server, causing the processing for all other clients to be suspended. Such exclusive access is referred to as @emph{grabbing the server}. CLX provides functions to grab and release exclusive access to the server. These function should be used rarely and always with extreme caution, since they have the potential to disrupt the entire window system for all clients. @defun grab-server display @table @var @item display A @var{display}. @end table Disables processing of requests and close-downs on all connections other than the one on which this request arrived. @end defun @defun ungrab-server display @table @var @item display A @var{display}. @end table Restarts processing of requests and close-downs on other connections. @end defun @defmac with-server-grabbed display &body body Grabs the @emph{display} server only within the dynamic extent of the @emph{body}. @var{ungrab-server} is automatically called upon exit from the @emph{body}. This macro provides the most reliable way for CLX clients to grab the server. @table @var @item display A @var{display}. @item body The forms to execute while the server is grabbed. @end table @end defmac @node Pointer Control, Keyboard Control, Grabbing the Server, Control Functions @section Pointer Control The following paragraphs describe the CLX functions used to: @itemize @bullet @item Return or change the pointer acceleration and acceleration threshold @item Return or change the mapping of pointer button numbers @end itemize @defun change-pointer-control display &key :acceleration :threshold @table @var @item display A @var{display}. @item :acceleration A number for the acceleration ratio. @item :threshold The number of pixels required for acceleration to take effect. @end table Changes the acceleration and/or the acceleration threshold of the pointer for the @emph{display}. The @var{:acceleration} number is used as a multiplier, typically specified as a rational number of the form @emph{C/P}, where @emph{C} is the number of pixel positions of cursor motion displayed for @emph{P} units of pointer device motion. The acceleration only occurs if the pointer moves more that @var{:threshold} pixels at once, and only applies to the motion beyond the @var{:threshold}. Either @var{:acceleration} or @var{:threshold} can be set to @var{:default}, that restores the default settings of the server. @end defun @defun pointer-control display @table @var @item display A @var{display}. @end table Returns the acceleration and threshold for the @emph{display} pointer. @table @var @item acceleration @itemx threshold Type @var{number}. @end table @end defun @defun pointer-mapping display &key (:result-type 'list) @table @var @item display A @var{display}. @item :result-type The type of sequence to return. @end table Returns or (with @code{setf}) changes the mapping of button numbers for the @emph{display} pointer. The @var{:result-type} is not used when changing the mapping. If element @emph{i} of the mapping sequence is @emph{j}, then the events from pointer button @emph{j} are reported by the server as events for button @emph{i}+1. (Note that pointer buttons are numbered beginning with one, while the mapping sequence itself is indexed normally from zero.) If element @emph{i} of the mapping sequence is zero, then button @emph{i}+1 is disabled and can no longer generate input events. No two elements of the mapping can have the same non-zero value. The length of the mapping sequence indicates the actual number of buttons on the device. When changing the mapping, the new mapping must have this same length. @table @var @item mapping Type @var{sequence} or @var{card8}@emph{.} @end table @end defun @node Keyboard Control, Keyboard Encodings, Pointer Control, Control Functions @section Keyboard Control The following paragraphs describe the CLX functions used to: @itemize @bullet @item Return or change keyboard controls @item Ring the keyboard bell @item Return or change the mapping of modifiers @item Return the current up/down state of all keys @end itemize @defun bell display &optional (percent-from-normal 0) @table @var @item display A @var{display}. @item percent-from-normal An integer (-100 through 100). @end table Rings the bell on the keyboard at a volume relative to the base volume for the keyboard, if possible. Percent can range from -100 to 100 inclusive, or else a Value error occurs. The following is the bell volume when percent is non-negative: @lisp (- (+ @emph{base percent}) (@var{quotient} (* @emph{base percent}) 100)) @end lisp and when percent is negative: @lisp (+ @emph{base} (@var{quotient} (* @emph{base percent}) 100)) @end lisp @end defun @defun change-keyboard-control display &key :key-click-percent :bell-percent :bell-pitch :bell-duration :led :led-mode :key :auto-repeat-mode @table @var @item display A @var{display}. @item :key-click-percent An integer (0 100). @item :bell-percent An integer (0 100). @item :bell-pitch A @var{card16}. @item :bell-duration A @var{card16}. @item :led A @var{card8}. @item :led-mode Either @var{:on} or @var{:off}. @item :key A @var{card8} keycode. @item :auto-repeat-mode Either @var{:on}, @var{:off}, or @var{:default}. @end table Changes the various aspects of the keyboard. The keyword arguments specify which controls to change. The @var{:key-click-percent} keyword sets the volume for key clicks, if possible. A value of 0 implies off, while a value of 100 implies loud. Setting @var{:key-click-percent} to @var{:default} restores the default value. The @var{:bell-percent} sets the base volume for the bell between 0 (off) and 100 (loud) if possible. Setting @var{:bell-percent} to @var{:default} restores the default value. The @var{:bell-pitch} sets the pitch (specified in Hz) of the bell, if possible. Setting the @var{:bell-pitch} to @var{:default} restores the default value. The @var{:bell-duration} sets the duration ( specified in milliseconds) of the bell, if possible. Setting @var{:bell-pitch} to @var{:default} restores the default. Note that a bell generator connected with the console but not directly on the keyboard is treated as if it were part of the keyboard. If both @var{:led-mode} and @var{:led} are specified, then the state of that LED is changed, if possible. If only @var{:led-mode} is specified, the state of all LEDs are changed, if possible. At most 32 LEDs are supported, numbered from one. No standard interpretation of the LEDs are defined. If both @var{:auto-repeat-mode} and @var{:key} are specified, the auto-repeat mode of that key is changed, if possible. If only @var{:auto-repeat-mode} is specified, the global auto-repeat mode for the entire keyboard is changed, if possible, without affecting the per-key settings. An error occurs if @var{:key} is specified without @var{:auto-repeat-mode}. @end defun @defun keyboard-control display @table @var @item display A @var{display}. @end table Returns the current control values for the keyboard. For the LEDs, the least significant bit of @emph{led-mask} corresponds to LED one, and each one bit in @emph{led-mask} indicates an LED that is lit. @emph{auto-repeats} is a bit vector; each one bit indicates that auto-repeat is enabled for the corresponding key. The vector is represented as 32 bytes. Byte @emph{n} (from 0) contains the bits for keys 8@emph{n} to 8@emph{n}+7, with the least significant bit in the byte representing key 8@emph{n}. @table @var @item key-click-percent @itemx bell-percent Type @var{card8}. @item bell-pitch @itemx bell-duration Type @var{card16}. @item led-mask Type @var{card32}. @item global-auto-repeat Either @var{:on} or @var{:off}. @item auto-repeats Type @var{bit-vector}. @end table @end defun @defun modifier-mapping display @table @var @item display A @var{display}. @end table Returns the set of keycodes used for each modifier on the @emph{display} keyboard. Each return value is a list of the @var{card8} keycodes used for each modifier key. The order of keycodes within each list is server-dependent. @table @var @item shift-keycodes @itemx lock-keycodes @itemx control-keycodes @itemx mod1-keycodes @itemx mod2-keycodes @itemx mod3-keycodes @itemx mod4-keycodes @itemx mod5-keycodes Type @var{list} of @var{card8}. @end table Some servers may include the same keycode in more than one list. For example, if the CAPS LOCK key has been turned into an additional CONTROL key, some servers include it in the third return value, but also in the second return value. Client code can therefore not rely on the returned lists to have pairwise empty intersections. @end defun @defun query-keymap display @table @var @item display A @var{display}. @end table Returns a bit vector that describes the state of the keyboard. Each one bit indicates that the corresponding key is currently pressed. The vector is represented as 32 bytes. Byte @emph{n} (from 0) contains the bits for keys 8@emph{n} to 8@emph{n}+7, with the least significant bit in the byte representing key 8@emph{n}. @table @var @item keymap Type @var{bit-vector} 256. @end table @end defun @defun set-modifier-mapping display &key :shift :lock :control :mod1 :mod2 :mod3 :mod4 :mod5 @table @var @item display A @var{display}. @item :shift @itemx :lock @itemx :control @itemx :mod1 @itemx :mod2 @itemx :mod3 @itemx :mod4 @itemx :mod5 A sequence of @var{card8} keycodes for the given modifier. @end table Changes the set of keycodes mapped to the specified modifier keys on the @emph{display} keyboard. Each keyword argument contains a sequence of new @var{card8} keycodes for a specific modifier. The return value indicates whether the change was completed successfully. A status of @var{:failed} is returned if hardware limitations prevent the requested change. For example, multiple keycodes per modifier may not be supported, up transitions on a given keycode may not be supported, or autorepeat may be mandatory for a given keycode. If @var{:failed} is returned, the mappings for all modifiers remain unchanged. A status of @var{:device-busy} is returned if a new keycode given for a modifier was not previously mapped to that modifier and is currently in the down state. In this case, the mappings for all modifiers remain unchanged. @table @var @item status One of @var{:success}, @var{:failed}, or @var{:device-busy}. @end table Notice that the default value for each of the key arguments is the empty list. Failing to include a key argument in a call to this function will therefore remove all the keycodes as modifiers that were previously considered modifiers in the category corresponding to the keyword argument. @end defun @node Keyboard Encodings, Client Termination, Keyboard Control, Control Functions @section Keyboard Encodings Handling the great diversity of keyboard devices and international language character encodings is a difficult problem for interactive programs that need to receive text input but must also be portable. The X Window System solves this problem by using different sets of encodings for device keys (@emph{keycodes}) and for character symbols (@emph{keysyms}). Each X server maintains a @emph{keyboard mapping} that associates keycodes and keysyms, and which can be returned or changed by client programs. To handle text input, a CLX client program must follow these steps: @enumerate @item Receive a @var{:key-press} (or @var{:key-release}) event containing a keycode. @item Convert the keycode into its corresponding keysym, based on the current keyboard mapping. See @var{keycode->keysym}. @item Convert the keysym into the corresponding Common Lisp character. See @var{keysym->character}. @end enumerate @menu * Keycodes and Keysyms:: * Keyboard Mapping:: * Using Keycodes and Keysyms:: @end menu @node Keycodes and Keysyms, Keyboard Mapping, Keyboard Encodings, Keyboard Encodings @subsection Keycodes and Keysyms A @emph{keycode} represents a physical (or logical) key. In CLX, keycodes are values of type (@var{integer} 8 255). A keycode value carries no intrinsic information, although server implementors may attempt to encode geometry (for example, matrix) information in some fashion so it can be interpreted in a server- dependent fashion. The mapping between keys and keycodes cannot be changed. A @emph{keysym} is an encoding of a symbol on the cap of a key. In CLX, keysyms are values of type @var{card32}. The set of defined keysyms include the ISO Latin character sets (1-4), Katakana, Arabic, Cyrillic, Greek, Technical, Special, Publishing, APL, Hebrew, and miscellaneous keys found on keyboards (RETURN, HELP, TAB, and so on). The encoding of keysyms is defined by the X Protocol. A list of keysyms is associated with each keycode. The length of the list can vary with each keycode. The list is intended to convey the set of symbols on the corresponding key. By convention, if the list contains a single keysym and if that keysym is alphabetic and case distinction is relevant, then it should be treated as equivalent to a two-element list of the lowercase and uppercase keysyms. For example, if the list contains the single keysym for uppercase A, the client should treat it as if it were a pair with lowercase as the first keysym and uppercase A as the second keysym. For any keycode, the first keysym in the list should be chosen as the interpretation of a key press when no modifier keys are down. The second keysym in the list normally should be chosen when the @var{:shift} modifier is on, or when the @var{:lock} modifier is on and @var{:lock} is interpreted as @var{:shift-lock}. When the @var{:lock} modifier is on and is interpreted as @var{:caps-lock}, it is suggested that the @var{:shift} modifier first be applied to choose a keysym, but if that keysym is lowercase alphabetic, the corresponding uppercase keysym should be used instead. Other interpretations of @var{:caps-lock} are possible; for example, it may be viewed as equivalent to @var{:shift-lock}, but only applying when the first keysym is lowercase alphabetic and the second keysym is the corresponding uppercase alphabetic. No interpretation of keysyms beyond the first two in a list is suggested here. No spatial geometry of the symbols on the key is defined by their order in the keysym list, although a geometry might be defined on a vendor-specific basis. The X server does not use the mapping between keycodes and keysyms. Rather, the X server stores the mapping merely for reading and writing by clients. @node Keyboard Mapping, Using Keycodes and Keysyms, Keycodes and Keysyms, Keyboard Encodings @subsection Keyboard Mapping The X server maintains a keyboard mapping that associates each keycode with one or more keysyms. The following paragraphs describe the CLX functions used to return or change the mapping of keycodes. @defun change-keyboard-mapping display keysyms &key (:start 0) :end @table @var @item display A @var{display}. @item keysyms A two-dimensional array of keysym (@var{card32}) values. @item :start @itemx :end Indexes for the subsequence of @emph{keysyms} used. @item :first-keycode A @var{card8} defining the first keycode mapping changed. @end table (@var{:first-keycode :start}) Changes the mapping of keycodes to @emph{keysyms}. A @var{:mapping-notify} event is generated for all clients. The new @emph{keysyms} are specified as a two-dimensional array in which: (@var{aref} @emph{keysyms} (+ @var{:start} @emph{i}) @emph{j}) is @emph{keysym j} associated with keycode (+ @var{:first-keycode} @emph{i}). The maximum number of @emph{keysyms} associated with any one keycode is given by: (@var{array-dimension} @emph{keysyms} 1) @emph{keysyms} should contain @var{nil} elements to represent those keysyms that are undefined for a given keycode. @var{:start} and @var{:end} define the subsequence of the @emph{keysyms} array that defines the new mapping, and the number of keycode mappings changed. By default, @var{:end} is given by: (@var{array-dimension} @emph{keysyms} 0) The keycodes whose mappings are changed are given by @var{:first-keycode} through the following: (+ @var{:first-keycode} (- @var{:end :start}) -1) keycodes outside this range of are not affected. @var{:first-keycode} must not be less than (@var{display-min-keycode} @emph{display}), and the last keycode modified must not be greater than (@var{display-max-keycode} @emph{display}). @end defun @defun keyboard-mapping display &key :first-keycode :start :end :data @table @var @item display A @var{display}. @item :first-keycode A @var{card8} defining the first keycode mapping returned. @item :start @itemx :end Indexes for the subsequence of the returned array which is modified. @item :data If given, a two-dimensional array to receive the returned keysyms. @end table Returns the keysyms mapped to the given range of keycodes for the @emph{display} keyboard. The mappings are returned in the form of a two-dimensional array of @var{card32} keysym values. The @var{:data} argument, if given, must be a two-dimensional array in which the returned mappings will be stored. In this case: (@var{array-dimension :data} 1) defines the maximum number of keysyms returned for any keycode. Otherwise, a new array is created and returned. Upon return: (@var{aref} @emph{mappings} (+ @emph{:start i}) @emph{j}) will contain keysym @emph{j} associated with keycode (+ @var{:first-keycode i}) (or @var{nil}, if keysym @emph{j} is undefined for that keycode). @var{:first-keycode} specifies the first keycode whose mapping is returned; by default, @var{:first-keycode} is (@var{display-min-keycode} @emph{display}). @var{:start} and @var{:end} define the subsequence of the returned array in which the returned mappings are stored. By default, @var{:start} is given by @var{:first-keycode} and @var{:end} is given by: (1+ (@var{display-max-keycode} @emph{display})) @var{:first-keycode} must not be less than (@var{display-min-keycode} @emph{display}), and the last keycode returned must not be greater than (@var{display-max-keycode} @emph{display}). @table @var @item mappings Type (@var{array card32} (* *)). @end table @end defun @node Using Keycodes and Keysyms, , Keyboard Mapping, Keyboard Encodings @subsection Using Keycodes and Keysyms The following paragraphs describe the CLX functions used to: @itemize @bullet @item Convert a keycode into a keysym @item Convert a keysym into a character @end itemize @defun keycode->keysym display keycode keysym-index @table @var @item display A @var{display}. @item keycode A @var{card8}. @item keysym-index A @var{card8}. @end table Returns the @emph{keysym} at the given @emph{keysym-index} from the keysym list for the @emph{keycode} in the current keyboard mapping for the @emph{display} server. @emph{This function was called keycode-keysym in X11R4 and older versions of CLX.} @table @var @item keysym Type @var{keysym}. @end table @end defun @defun keysym->character display keysym &optional (state 0) @table @var @item display A @var{display}. @item keysym A @var{keysym}. @item state A @var{mask16}. @end table Returns the @emph{character} associated with the @emph{keysym} and the @emph{state}. The @emph{state} is a @var{mask16} bit mask representing the state of the @emph{display} modifier keys and pointer buttons. See @var{state-mask-key} in @ref{Data Types}. If the @emph{keysym} does not represent a Common Lisp character, then @var{nil} is returned. @emph{This function was called keysym-character in X11R4 and older versions of CLX.} The @emph{state} determines the bits attribute of the returned @emph{character}, as follows: @table @var @item :control @var{char-control-bit} @item :mod-1 @var{char-meta-bit} @item :mod-2 @var{char-super-bit} @item :mod-3 @var{char-hyper-bit} @end table @c Of course *we* know that this mapping is bull shit! @table @var @item character Type @var{character} or @var{null}. @end table @end defun @node Client Termination, Managing Host Access, Keyboard Encodings, Control Functions @section Client Termination The CLX functions affecting client termination are discussed in the following paragraphs. When a display connection to an X server is closed, whether by an explicit call to @var{close-display} or by some external condition, the server automatically performs a sequence of operations to clean up server state information associated with the closed connection. The effect of these operations depends the @emph{close-down mode} and the @emph{save-set} that the client has specified for the closed display connection. The close-down mode of a display determines whether server resources allocated by the connection are freed or not. The save-set identifies windows that will remain after the connection is closed. The display save-set is used primarily by window managers that reparent the top-level windows of other clients. For example, such a window manager can automatically create a frame window that encloses a top-level client window, along with a set of controls used for window management. Ordinarily, termination of the window manager client would then destroy all client windows! However, the window manager can prevent this by adding to its save-set those windows created by other clients that should be preserved. When a display connection closes, an X server performs the following operations: @enumerate @item For each selection owned by a window created on the connection, the selection owner is set to @var{nil}. @item An active or passive grab established for a window created on the connection is released. @item If the connection has grabbed the server, the server is ungrabbed. @item Server resources and colormap cells allocated by the connection are freed and destroyed, depending on the close-down mode, as follows: @itemize @bullet @item @var{:retain-permanent} -- All resources are marked @emph{permanent}, and no resources are destroyed. These resources can later be destroyed by a call to @var{kill-client}. @item @var{:retain-temporary} -- All resources are marked @emph{temporary}, and no resources are destroyed. These resources can later be destroyed by a call to @var{kill-client} or @var{kill-temporary-clients}. @item @var{:destroy} -- All resources are destroyed. @end itemize @end enumerate When server resources allocated by a display connection are destroyed -- whether by closing the connection with close-down mode @var{:destroy} or by later calling @var{kill-client} or @var{kill-temporary-clients} -- then an X server performs the following operations on each member of the save-set before actually destroying resources. @enumerate @item If the save-set window is a descendant of a window created on the connection, the save-set window is reparented. The new parent is the closest ancestor such that the save-set window is no longer a descendant of any window created on the connection. The position of the reparented window with respect to its parent remains unchanged. @item If the save-set window is unmapped, then it is mapped. @end enumerate If the last connection open to an X server is closed with close-down mode @var{:destroy}, the server resets its state to restore all initial defaults. The server state after reset is the same as its initial state when first started. When an X server resets, it performs the following operations: @itemize @bullet @item All permanent and temporary server resources from previously-closed connections are destroyed. @item All but the predefined atoms are deleted. @item All root window properties are deleted. @item All device control attributes and mappings are restored to their original default values. @item The default background and cursor for all root windows are restored. @item The default font path is restored. @item The input focus is set to @var{:pointer-root}. @item The access control list is reset. @end itemize The following paragraphs describe the CLX functions used to: @itemize @bullet @item Add or remove a window from a display save-set. @item Return or change the display close-down mode. @item Force a connection to be closed or all its server resources to be destroyed. @item Force a connection to be closed and all temporary resources to be destroyed. @end itemize @defun add-to-save-set window @table @var @item window A @var{window}. @end table Adds the specified @emph{window} to the save-set of the @emph{window} display. The @emph{window} must have been created by some other display. Windows are removed automatically from the save-set when they are destroyed. @end defun @defun close-down-mode display @table @var @item display A @var{display}. @end table Returns and (with @code{setf}) sets the close-down mode of the client's resources at connection close. @table @var @item mode One of @var{:destroy}, @var{:retain-permanent}, or @var{:retain-temporary}. @end table @end defun @defun kill-client display resource-id @table @var @item display A @var{display}. @item resource-id A valid @var{card29} resource ID. @end table Closes the display connection which created the given @emph{resource-id}. The @emph{resource-id} must be valid, but need not belong to the given @emph{display}. If the closed connection was previously open, the connection is closed according to its close-down mode. Otherwise, if the connection had been previously terminated with close-down mode @var{:retain-permanent} or @var{:retain-temporary}, then all its retained server resources -- both permanent and temporary -- are destroyed. @end defun @defun kill-temporary-clients display @table @var @item display A @var{display}. @end table Closes the @emph{display} connection and destroys all retained temporary server resources for this and all previously-terminated connections. If the @emph{display} connection was previously open, the connection is closed according to its close-down mode. Otherwise, if the @emph{display} connection had been previously terminated with close-down mode @var{:retain-permanent} or @var{:retain-temporary}, then all its retained server resources -- both permanent and temporary -- are destroyed. @end defun @defun remove-from-save-set window @table @var @item window A @var{window}. @end table Removes the specified @emph{window} from the save-set of the @emph{window} display. The @emph{window} must have been created by some other display. Windows are removed automatically from the save-set when they are destroyed. @end defun @node Managing Host Access, Screen Saver, Client Termination, Control Functions @section Managing Host Access An X server maintains a list of hosts from which client programs can be run. Only clients executing on hosts that belong to this @emph{access control list} are allowed to open a connection to the server. Typically, the access control list can be changed by clients running on the same host as the server. Some server implementations can also implement other authorization mechanisms in addition to, or in place of, this mechanism. The action of this mechanism can be conditional based on the authorization protocol name and data received by the server at connection setup. The following paragraphs describe the CLX functions used to: @itemize @bullet @item Add or remove hosts on the access control list. @item Return the hosts on the access control list. @item Return or change the state of the access control list mechanism @end itemize @defun access-control display @table @var @item display A @var{display}. @end table Returns and (with @code{setf}) changes the state of the access control list mechanism for the @emph{display} server. Returns true if access control is enabled; otherwise, @var{nil} is returned. If enabled, the access control list is used to validate each client during connection setup. Only a client running on the same host as the server is allowed to enable or disable the access control list mechanism. @table @var @item enabled-p Type @var{boolean}. @end table @end defun @defun access-hosts display &key (:result-type 'list) @table @var @item display A @var{display}. @item :result-type The type of hosts sequence to return. @end table Returns a sequence containing the @emph{hosts} that belong to the access control list of the @emph{display} server. Elements of the returned @emph{hosts} sequence are either strings or some other type of object recognized as a host name by @var{add-access-host} and @var{remove-access-host}. The second returned value specifies whether the access control list mechanism is currently enabled or disabled (see @var{access-control}). @table @var @item hosts @var{sequence} of @var{string}. @item enabled-p Type @var{boolean}. @end table @end defun @defun add-access-host display host @table @var @item display A @var{display}. @item host A host name. Either a string or some other implementation-dependent type. @end table Adds the specified @emph{host} to the access control list. Only a client running on the same host as the server can change the access control list. @end defun @defun remove-access-host display host @table @var @item display A @var{display}. @item host A host name. Either a string or some other implementation-dependent type. @end table Removes the specified @emph{host} from the access control list. Only a client running on the same host as the server can change the access control list. @end defun @node Screen Saver, , Managing Host Access, Control Functions @section Screen Saver To prevent monitor damage, an X server implements a screen saver function which blanks screens during periods of unuse. The screen saver can be in one of three states: @itemize @bullet @item Disabled -- No screen blanking is done and screen content remains unchanged. @item Deactivated -- The server is being used. When the server input devices are unused for a specific amount of time, the screen saver becomes activated. @item Activated -- The server input devices are unused. The screen saver blanks all server screens or displays a server-dependent image. As soon as an input event from either the pointer or the keyboard occurs, the screen saver is deactivated and its timer is reset. @end itemize The following paragraphs describe the CLX functions used to: @itemize @bullet @item Return or change screen saver control values. @item Activate or reset the screen saver @end itemize @defun activate-screen-saver display @table @var @item display A @var{display}. @end table Activates the screen saver for the @emph{display} server. @end defun @defun reset-screen-saver display @table @var @item display A @var{display}. @end table Deactivates the screen saver for the @emph{display} server (if necessary) and resets its timer, just as if a pointer or keyboard event had occurred. @end defun @defun screen-saver display @table @var @item display A @var{display}. @end table Returns the current control values for the @emph{display} server screen saver. See @var{set-screen-saver}. @table @var @item timeout @itemx period Type @var{int16}. @item blanking @itemx exposures One of @var{:yes} or @var{:no}. @end table @end defun @defun set-screen-saver display timeout period blanking exposures @table @var @item display A @var{display}. @item timeout Specifies the delay until timeout takes over. @item period Specifies the periodic change interval, if used. @item blanking Specifies whether the blanking option is available. @item exposures Specifies whether exposures are allowed during blanking. @end table Changes the current control values for the @emph{display} server screen saver. The screen saver is reset. The screen saver is also disabled if: @itemize @bullet @item @emph{timeout} is zero, or @item Both @emph{blanking} and @emph{exposures} are disabled and the server cannot regenerate the screen contents without sending @var{:exposure} events. @end itemize The @emph{timeout} specifies the (non-negative) number of seconds of input device inactivity that must elapse before the screen saver is activated. The @emph{timeout} can be set to @var{:default} to restore the server default timeout interval. If @emph{blanking} is @var{:yes} and the screen hardware supports blanking, blanking is enabled; that is, the screen saver will simply blank all screens when it is activated. @emph{blanking} can be set to @var{:default} to restore the server default state for blanking. If @emph{exposures} is @var{:yes}, exposures are enabled. If exposures are enabled, or if the server is capable of regenerating screen contents without sending @var{:exposure} events, the screen saver will display some server-dependent image when activated. Frequently, this image will consist of a repeating animation sequence, in which case @emph{period} specifies the ( non-negative) number of seconds for each repetition. A @emph{period} of zero is a hint that no repetition should occur. @end defun @node Extensions, Errors, Control Functions, Top @chapter Extensions @menu * Extensions (Extensions):: * SHAPE - The X11 Nonrectangular Window Shape Extension:: * RENDER - A new rendering system for X11:: * DPMS - The X11 Display Power Management Signaling Extension:: * BIG-REQUESTS - Big Requests Extension:: @end menu @node Extensions (Extensions), SHAPE - The X11 Nonrectangular Window Shape Extension, Extensions, Extensions @section Extensions The X Window System is based on a core protocol which can be extended to provide new functionality. An extension is generally represented by an additional set of requests or event types that are implemented by an X server supporting the extension. By definition, a client program using an extension may not be portable to other servers. However, extensions allow different server implementations and different sites to add their own special features to X, without disrupting clients that rely only on the core protocol. Extensions are identified by assigning them unique name strings and major protocol numbers. A client program can request an X server to use a protocol extension by furnishing the extension protocol number as an argument to @var{open-display}. The X Consortium maintains a registry of standard extension names and protocol numbers. The following paragraphs describe the CLX functions used to: @itemize @bullet @item List all supported extensions. @item Find out if a given extension is supported. @end itemize @defun list-extensions display &key (:result-type 'list) @table @var @item display A @var{display}. @item :result-type The type of name sequence to return. @end table Returns a sequence containing the @emph{names} of all extensions supported by the @emph{display} server. @table @var @item names Type @var{sequence} of @var{string}. @end table @end defun @defun query-extension display name @table @var @item display A @var{display}. @item name An extension name string. @end table Returns the @emph{major-opcode} for the given extension @emph{name} support by the @emph{display} server. If the extension is not supported, only @var{nil} values are returned. The extension @emph{name} must contain only ISO Latin-1 characters; case is significant. If the extension involves additional event types, the @emph{first-event} returned is the base event type code for new events; otherwise, the @emph{first-event} is @var{nil}. If the extension involves additional error codes, the @emph{first-error} returned is the base code for new errors; otherwise, the @emph{first-error} is @var{nil}. The formats of error and event messages sent by the server are completely defined by the extension. @table @var @item major-opcode @itemx first-event @itemx first-error Type @var{card8} or @var{null}. @end table @end defun @node SHAPE - The X11 Nonrectangular Window Shape Extension, RENDER - A new rendering system for X11, Extensions (Extensions), Extensions @section SHAPE - The X11 Nonrectangular Window Shape Extension This documentation is yet to be written. @node RENDER - A new rendering system for X11, DPMS - The X11 Display Power Management Signaling Extension, SHAPE - The X11 Nonrectangular Window Shape Extension, Extensions @section RENDER - A new rendering system for X11 XRENDER is an experimental step in building a newer and modern graphics rendering system that can keep up with the demands of visual appearance on current user interfaces. The X Rendering Extension (Render) introduces digital image composition as the foundation of a new rendering model within the X Window System. Rendering geometric figures is accomplished by client-side tesselation into either triangles or trapezoids. Text is drawn by loading glyphs into the server and rendering sets of them. @menu * Picture formats:: * The picture object:: * Glyphs and Glyphsets:: * Using glyphs:: * Using cursors:: * Errors (Extensions):: @end menu @node Picture formats, The picture object, RENDER - A new rendering system for X11, RENDER - A new rendering system for X11 @subsection Picture formats The following is what the X protocol rendering spec has to say about picture formats. @url{http://www.xfree86.org/~keithp/render/protocol.html} The @var{picture-format} object holds information needed to translate pixel values into red, green, blue and alpha channels. The server has a list of picture formats corresponding to the various visuals on the screen. There are two classes of formats, Indexed and Direct. Indexed picture-formats hold a list of pixel values and RGBA values while Direct picture-formats hold bit masks for each of R, G, B and A. The server must support a direct @var{picture-format} with 8 bits each of red, green, blue and alpha as well as a direct @var{picture-format} with 8 bits of red, green and blue and 0 bits of alpha. The server must also support direct @var{picture-format}s with 1, 4 and 8 bits of alpha and 0 bits of r, g and b. Pixel component values lie in the closed range [0,1]. These values are encoded in a varying number of bits. Values are encoded in a straight forward manner. For a component encoded in m bits, a binary encoding b is equal to a component value of b/(2^m-1). A direct @var{picture-format} with zero bits of alpha component is declared to have alpha == 1 everywhere. A direct @var{picture-format} with zero bits of red, green and blue is declared to have red, green, blue == 0 everywhere. If any of red, green or blue components are of zero size, all are of zero size. Direct @var{picture-format}s never have colormaps and are therefore screen independent. Indexed @var{picture-format}s never have alpha channels and the direct component is all zeros. Indexed @var{picture-format}s always have a colormap in which the specified colors are allocated read- only and are therefore screen dependent. These are valid accessors for picture-format objects. @table @var @item picture-format-display A display @item picture-format-id The X protocol @var{resource-id} @item picture-format-type @code{(member :indexed :direct)} @item picture-format-depth Bitdepth as @var{card8} @item picture-format-red-byte A bitmask @item picture-format-green-byte @itemx picture-format-blue-byte @itemx picture-format-alpha-byte @itemx picture-format-colormap A @var{colormap} or nil @end table @node The picture object, Glyphs and Glyphsets, Picture formats, RENDER - A new rendering system for X11 @subsection The picture object The @var{picture} object contains a @var{drawable}, a @var{picture-format} and some rendering state. More than one @var{picture} can refer to the same @var{drawable}. A @var{picture} is almost like a @var{gcontext}, except that it is tied in use to a single @var{drawable}. Another similarity it has with @var{gcontext} is that it is a cached object. Updates are not processed until the @var{picture} is used. This also makes it possible to query state, as there is no such request in XRENDER to do so. The @var{picture} object is also a lot like a @var{drawable}, in that it is used as a target for graphics operations. Or at least that it occurs where you would expect a drawable in XRENDER requests. @defun render-create-picture drawable &key format picture ... @table @var @item drawable A @var{Drawable} @item format A @var{picture-format} @item picture An existing @var{picture} object to use, one is created if not specified. @item repeat @code{(member :off :on)} @item alpha-map A @var{picture} or @var{:none} @item alpha-x-origin @var{int16} @item alpha-y-origin @var{int16} @item clip-x-origin @var{int16} @item clip-y-origin @var{int16} @item clip-mask A @var{Pixmap} or @var{:none} @item graphics-exposures @code{(member :off :on)} @item subwindow-mode @code{(member :clip-by-children :include-inferiors)} @item poly-edge @code{(member :sharp :smooth)} @item poly-mode @code{(member :precise :imprecise)} @item dither @var{xatom} or @var{:none} @item component-alpha @code{(member :off :on)} @end table This request creates a Picture object. If the @emph{drawable} is a Window then the Red, Green and Blue masks must match those in the visual for the window else a Match error is generated. @table @var @item picture A @var{picture} @end table @end defun @defun render-free-picture picture This request deletes all server resources associated with the picture object. @table @var @item picture The @var{picture} object to free @end table @end defun @node Glyphs and Glyphsets, Using glyphs, The picture object, RENDER - A new rendering system for X11 @subsection Glyphs and Glyphsets A glyph in XRENDER is an alpha mask and an associated orgin, advancement and numeric id. The application refers to them by the numeric id. Glyphs are stored in a glyph-set. The client is responsible for making sure the glyphs it uses are stored in the glyph-set, or there will be a Glyph-error. @defun render-create-glyph-set format &key glyph-set @table @var @item format A @var{picture-format} for the alpha masks that this font will use. @item glyph-set An optional @var{glyph-set} object to initialize with a server side glyphset resource. @end table Creates an initially empty glyph-set for the client to use. @emph{Format} must be a Direct format. When it contains RGB values, the glyphs are composited using component-alpha True, otherwise they are composited using component-alpha False. @end defun @defun render-reference-glyph-set existing-glyph-set &key glyph-set @table @var @item existing-glyph-set An existing @var{glyph-set} @item glyph-set An optional @var{glyph-set}, just like in @var{render-create-glyph-set} @end table Creates a new id refering to the existing-glyph-set. The glyph-set itself will not be freed until all ids has been removed. @end defun @defun render-free-glyph-set glyph-set @table @var @item glyph-set A glyphset resource to free @end table Removes an id to a glyph-set. When all ids have been removed the glyph-set itself is removed. @end defun @defun render-add-glyph glyph-set id &key x-origin y-origin x-advance y-advance data @table @var @item glyph-set A @var{glyph-set} @item id @var{card32} @item x-orgin @var{int16} @item y-orgin @var{int16} @item x-advance @var{int16} @item y-advance @var{int16} @item data An @var{array} of @var{card8} bytes. @end table Associates id with the given description of a glyph. An existing glyph with the same id is replaced. At the time of writing, only 8bit alpha masks are supported. Experimentation with glyph-sets in other pict-formats needed. @end defun @defun render-add-glyph-from-picture glyph-set picture &key x-origin y-origin x-advance y-advance width height @table @var @item glyph-set glyph-set @item picture picture @item x-origin int16 @item y-origin int16 @item x-advance int16 @item y-advance int16 @item x int16 @item y int16 @item width card16 @item height card16 @end table This request add a glyph to @emph{glyph-set} by copying it from the @emph{x,y} location in the @emph{picture}. Existing glyphs with the same names are replaced. The source @emph{picture} may be in a different @var{picture-format} than @emph{glyph-set}, in which case the images are converted to the glyph-set's format. @end defun @defun render-free-glyphs glyph-set glyphs @table @var @item glyph-set A @var{glyph-set} @item glyphs sequence of @var{card32} @end table This request removes @emph{glyphs} from @emph{glyph-set}. Each glyph must exist in @emph{glyph-set} (else a @var{Match} error results). @end defun @node Using glyphs, Using cursors, Glyphs and Glyphsets, RENDER - A new rendering system for X11 @subsection Using glyphs @defun render-composite-glyph dest glyph-set source dest-x dest-y sequence &key op src-x src-y mask-format start end @table @var @item dest picture @item glyph-set glyph-set @item source picture @item dest-x int16 @item dest-y int16 @item sequence @item op (member clear :src :dst :over :over-reverse :in :in-reverse :out :out-reverse :atop :atop-reverse :xor :add :saturate :maximum) @item src-x int16 @item src-y iny16 @item mask-format picture-format @item start blah @item end blah @end table Requests the sequence of glyphs to be drawn with the glyph-set. @end defun @node Using cursors, Errors (Extensions), Using glyphs, RENDER - A new rendering system for X11 @subsection Using cursors @defun render-create-cursor picture &optional (x 0) (y 0)) Creates cursor object from xrender @var{picture}. The @var{x} and @var{y} coordinates define the hotspot relative to the source's origin and must be a point within the source. The resulting picture will nominally be drawn to the screen with :over operator. The components of the cursor may be transformed arbitrarily to meet display limitations. In particular, if the display supports only two colors cursors without translucency, the cursor will be transformed so that areas less than .5 alpha will be transparent, else opaque, and areas darker than 50% gray will be black else white. The source picture can be freed immediately if no further explicit references to it are to be made. Subsequent drawing in the source has an undefined effect on the cursor. The server might or might not make a copy of the picture. @end defun @defun render-create-anim-cursor cursors delays Creates cursor object. @var{cursors} must be list of cursors, @var{delays} must be list of delays (in milliseconds). Lengths of lists must be the same. When active, the cursor image on the screen will cycle through @var{cursors}, showing each cursor in the element for the number of milliseconds indicated by the @var{delays} member of that element. @end defun @node Errors (Extensions), , Using cursors, RENDER - A new rendering system for X11 @subsection Errors What new errors Xrender defines... @node DPMS - The X11 Display Power Management Signaling Extension, BIG-REQUESTS - Big Requests Extension, RENDER - A new rendering system for X11, Extensions @section DPMS - The X11 Display Power Management Signaling Extension @defun dpms-get-version display &optional (major-version 1) (minor-version 1) @table @var @item display @var{display} @item major-version @var{card16} @item minor-version @var{card16} @end table Return two values: the major and minor version of the DPMS implementation the server supports. If supplied, the @var{major-version} and @var{minor-version} indicate what version of the protocol the client wants the server to implement. @end defun @defun dpms-capable display @table @var @item display @var{display} @end table True if the currently running server's devices are capable of DPMS operations. The truth value of this request is implementation defined, but is generally based on the capabilities of the graphic card and monitor combination. Also, the return value in the case of heterogeneous multi-head servers is implementation defined. @end defun @defun dpms-get-timeouts display @table @var @item display @var{display} @end table Return three values: the current values of the DPMS timeout values. The timeout values are (in order returned): standby, suspend and off. All values are in units of seconds. A value of zero for any timeout value indicates that the mode is disabled. @end defun @defun dpms-set-timeouts display standby suspend off @table @var @item display @var{display} @item standby @var{card16} @item suspend @var{card16} @item off @var{card16} @end table Set the values of the DPMS timeouts. All values are in units of seconds. A value of zero for any timeout value disables that mode. @end defun @defun dpms-enable display @table @var @item display @var{display} @end table Enable the DPMS characteristics of the server using the server's currently stored timeouts. If DPMS is already enabled, no change is affected. @end defun @defun dpms-disable display @table @var @item display @var{display} @end table Disable the DPMS characteristics of the server. It does not affect the core or extension screen savers. If DPMS is already disabled, no change is effected. This request is provided so that DPMS may be disabled without damaging the server's stored timeout values. @end defun @defun dpms-force-level display power-level @table @var @item display @var{display} @item power-level (member :dpms-mode-on :dpms-mode-standby :dpms-mode-suspend :dpms-mode-off) @end table Forces a specific DPMS level on the server. @end defun @defun dpms-info display @table @var @item display @var{display} @end table Returns two values: the DPMS power-level and state value for the display. State is one of the keywords DPMS-ENABLED or DPMS-DISABLED. If state is DPMS-ENABLED, then power-level is returned as one of the keywords DPMS-MODE-ON, DPMS-MODE-STANDBY, DPMS-MODE-SUSPEND or DPMS-MODE-OFF. If state is DPMS-DISABLED, then power-level is undefined and returned as NIL. @end defun @node BIG-REQUESTS - Big Requests Extension, , DPMS - The X11 Display Power Management Signaling Extension, Extensions @section BIG-REQUESTS - Big Requests Extension @defun display-extended-max-request-length display @end defun @defun enable-big-requests display @end defun @chapter Errors @node Errors, Undocumented, Extensions, Top @menu * Introduction (Errors):: @end menu @node Introduction (Errors), , Errors, Errors @section Introduction CLX error conditions are hierarchial. The base error condition is @var{x-error}, and all other conditions are built on top of @var{x-error}. @var{x-error} can be built on a lower-level condition that is implementation dependent (this is probably the @var{error} condition). @defmac define-condition name (parent-types*) [({slot-specifier*}) {option*}] Any new condition type must be defined with the @var{define-condition} macro. A condition type has a name, parent types, report message, and any number of slot items. See the @emph{Lisp} @emph{Reference} manual for further information regarding @var{define-condition}. The following are the predefined error conditions that can occur in CLX. @end defmac @deftp {Condition} access-error An @var{access-error} can occur for several reasons: @itemize @bullet @item A client attempted to grab a key/button combination already grabbed by another client @item A client attempted to free a colormap entry that it did not already allocate @item A client attempted to store into a read-only colormap entry @item A client attempted to modify the access control list from other than the local (or otherwise authorized) host @item A client attempted to select an event type that another client has already selected, and, that at most, one client can select at a time @end itemize An @var{access-error} is a special case of the more general @var{request-error} (@pxref{request-error}). @end deftp @deftp {Condition} alloc-error The server failed to allocate the requested resource or server memory. An @var{alloc-error} is a special case of the more general @var{request-error} (@pxref{request-error}). @end deftp @deftp {Condition} atom-error A value for an @emph{atom} argument does not name a defined atom. An @var{atom-error} is a special case of the more general @var{request-error} (@pxref{request-error}). @end deftp @deftp {Condition} closed-display The @var{closed-display} condition is signaled when trying to read or write a closed display (that is, @var{close-display} has been called on the @var{display} object, or a server-disconnect occurred). The @var{closed-display} object is reported with the error. A @var{closed-display} condition is a special case of the more general @var{x-error} (@pxref{x-error}). @end deftp @deftp {Condition} colormap-error A value for a @emph{colormap} argument does not name a defined colormap. A @var{colormap-error} is a special case of the more general @var{resource-error} (@pxref{resource-error}). @end deftp @deftp {Condition} connection-failure Signaled when an X11 server refuses a connection. The following items are reported along with the error: @itemize @bullet @item @emph{major-version} -- The major version of the X server code. @item @emph{minor-version} -- The minor version of the X server code. @item @emph{host} -- The host name for the X server. @item @emph{display} -- The display on which the error occurred. @item @emph{reason} -- A string indicating why the connection failed. @end itemize A @var{connection-failure} is a special case of the more general @var{x-error} (@pxref{x-error}). @end deftp @deftp {Condition} cursor-error A value for a @emph{cursor} argument does not name a defined cursor. A @var{cursor-error} is a special case of the more general @var{resource-error} (@pxref{resource-error}). @end deftp @deftp {Condition} device-busy Signaled by (@code{setf} (@var{pointer-mapping} @emph{display}) @var{mapping}) when the @var{set-pointer-mapping} request returns a busy status. A similar condition occurs in @var{set-modifier-mapping}, but in this case, it returns a boolean indicating success, rather than signaling an error. The @var{device-busy} condition returns the display object as part of the error. A @var{device-busy} condition is a special case of the more general @var{x-error} (@pxref{x-error}). @end deftp @deftp {Condition} drawable-error A value for a @emph{drawable} argument does not name a defined window or pixmap. A @var{drawable-error} is a special case of the more general @var{resource-error} (@pxref{resource-error}). @end deftp @deftp {Condition} font-error A value for a @emph{font} or @emph{gcontext} argument does not name a defined font. A @var{font-error} is a special case of the more general @var{resource-error} (@pxref{resource-error}). @end deftp @deftp {Condition} gcontext-error A value for a @emph{gcontext} argument does not name a defined GContext. A @var{gcontext-error} is a special case of the more general @var{resource-error} (@pxref{resource-error}). @end deftp @deftp {Condition} id-choice-error The value chosen for a resource identifier is either not included in the range assigned to the client or is already in use. Under normal circumstances, this cannot occur and should be considered a server or CLX library error. An @var{id-choice-error} is a special case of the more general @var{resource-error} (@pxref{resource-error}). @end deftp @deftp {Condition} implementation-error The server does not implement some aspect of the request. A server that generates this error for a core request is deficient. As such, this error is not listed for any of the requests. However, clients should be prepared to receive such errors and either handle or discard them. An @var{implementation-error} is a special case of the more general @var{resource-error} (@pxref{resource-error}). @end deftp @deftp {Condition} length-error The length of a request is shorter or longer than that minimally required to contain the arguments. This usually means an internal CLX error. A @var{length-error} is a special case of the more general @var{resource-error} (@pxref{resource-error}). @end deftp @deftp {Condition} lookup-error CLX has the option of caching different resource types (see @var{*clx-cached-types*}) in a hash table by resource ID. When looking up an object in the hash table, if the type of the object is wrong, a @var{lookup-error} is signaled. For example: The cursor with ID 123 is interned in the hash table. An event is received with a field for window 123. When 123 is looked up in the hash table, a cursor is found. Since a window was expected, a @var{lookup-error} is signaled. This error indicates a problem with the extension code being used. The following items are reported along with the error: @itemize @bullet @item @emph{id} -- The resource ID. @item @emph{display} -- The display being used. @item @emph{type} -- The resource type. @item @emph{object} -- The @var{resource} object. @end itemize A @var{lookup-error} is a special case of the more general @var{x-error} (@pxref{x-error}). @end deftp @deftp {Condition} match-error In a graphics request, the root and depth of the GContext does not match that of the drawable. An @var{:input-only} window is used as a drawable. Some argument or pair of arguments has the correct type and range but fails to match in some other way required by the request. An @var{:input-only} window locks this attribute. The values do not exist for an @var{:input-only} window. A @var{match-error} is a special case of the more general @var{request-error} (@pxref{request-error}). @end deftp @deftp {Condition} missing-parameter One or more of the required keyword parameters is missing or @var{nil}. The missing parameters are reported along with the error. A @var{missing-parameter} condition is a special case of the more general @var{x-error} (@pxref{x-error}). @end deftp @deftp {Condition} name-error A font or color of the specified name does not exist. A @var{name-error} is a special case of the more general @var{request-error} (@pxref{request-error}). @end deftp @deftp {Condition} pixmap-error A value for a @emph{pixmap} argument does not name a defined pixmap. A @var{pixmap-error} is a special case of the more general @var{resource-error}. (@pxref{resource-error}.) @end deftp @deftp {Condition} reply-length-error (x-error) (slots*) The reply to a request has an unexpected length. The following items are reported along with the error: @itemize @bullet @item @emph{reply-length} -- The actual reply length. @item @emph{expected-length} -- The expected reply length. @item @emph{display} -- The display on which the error occurred. @end itemize A @var{reply-length-error} is a special case of the more general @var{x-error} (@pxref{x-error}). @end deftp @deftp {Condition} reply-timeout The @var{*reply-timeout*} parameter specifies the maximum number of seconds to wait for a request reply, or @var{nil} to wait forever (the default). When a reply has not been received after *@var{reply-timeout}* seconds, the @var{reply-timeout} condition is signaled. The @emph{timeout} @emph{period} and @emph{display} are reported along with the error. A @var{reply-timeout} condition is a special case of the more general @var{x-error} (@pxref{x-error}). @end deftp @deftp {Condition} request-error @anchor{request-error} The following items are reported along with the error: The major or minor opcode does not specify a valid request. @itemize @bullet @item @emph{display} -- The display on which the error occurred. @item @emph{error-key} -- The error (sub)type. @item @emph{major} -- The major opcode. @item @emph{minor} -- The minor opcode. @item @emph{sequence} -- The actual sequence number. @item @emph{current-sequence} -- The current sequence number. @end itemize A @var{request-error} condition is a special case of the more general @var{x-error} (@pxref{x-error}). @end deftp @deftp {Condition} resource-error @anchor{resource-error} All X11 errors for incorrect resource IDs are built on top of @var{resource-error}. These are @var{colormap-error}, @var{cursor-error}, @var{drawable-error}, @var{font-error}, @var{gcontext-error}, @var{id-choice-error}, @var{pixmap-error} and @var{window-error}. @var{resource-error} is never signaled directly. A @var{resource-error} is a special case of the more general @var{request-error} (@pxref{request-error}). @end deftp @deftp {Condition} sequence-error All X11 request replies contain the sequence number of their request. If a reply's sequence does not match the request count, a @var{sequence-error} is signaled. A @var{sequence-error} usually indicates a locking problem with a multi-processing Lisp. The following items are reported along with the error: @itemize @bullet @item @emph{display} -- The display on which the error occurred. @item @emph{req-sequence} -- The sequence number in the reply. @item @emph{msg-sequence} -- The current sequence number. @end itemize A @var{sequence-error} condition is a special case of the more general @var{x-error}. (@pxref{x-error}) @end deftp @deftp {Condition} server-disconnect The connection to the server was lost. The display on which the error occurred is reported along with the error. A @var{server-disconnect} condition is a special case of the more general @var{x-error}. (@pxref{x-error}) @end deftp @deftp {Condition} unexpected-reply A reply was found when none was expected. This indicates a problem with the extension code. The following items are reported along with the error: @table @code @item display The display on which the error occurred. @item req-sequence The sequence number in the reply. @item msg-sequence The current sequence number. @item length The message length of the reply. @end table An @var{unexpected-reply} condition is a special case of the more general @var{x-error}. (@pxref{x-error}.) @end deftp @deftp {Condition} unknown-error (request-error) (error-code) An error was received from the server with an unknown error code. This indicates a problem with the extension code. The undefined error code is reported. An @var{unknown-error} is a special case of the more general @var{request-error}. (@pxref{request-error}) @end deftp @deftp {Condition} value-error (request-error) (value) Some numeric value falls outside the range of values accepted by the request. Unless a specific range is specified for an argument, the full range defined by the argument's type is accepted. Any argument defined as a set of alternatives can generate this error. The erroneous value is reported. A @var{value-error} is a special case of the more general @var{request-error}. (@pxref{request-error}) @end deftp @deftp {Condition} window-error (resource-error) A value for a @emph{window} argument does not name a defined window. A @var{window-error} is a special case of the more general @var{resource-error}. (@pxref{resource-error}.) @end deftp @deftp {Condition} x-error @anchor{x-error} This is the most general error condition upon which all other conditions are defined. @end deftp @ignore @var{PROTOCOL VS. CLX FUNCTIONAL} @var{CROSS-REFERENCE LISTING} @var{X11 Request Name CLX Function Name} AllocColor @var{alloc-color} AllocColorCells @var{alloc-color-cells} AllocColorPlanes@var{alloc-color-planes} AllocNamedColor @var{alloc-color} AllowEvents @var{allow-events} Bell @var{bell} ChangeAccessControl (@code{setf} (@var{access-control} @emph{display}) ChangeActivePointerGrab @var{change-active-pointer-grab} ChangeCloseDownMode (@code{setf} (@var{close-down-mode} @emph{display})) ChangeGC @var{force-gcontext-changes} (See @var{with-gcontext}) (@code{setf} (@var{gcontext-function} @emph{gc})) (@code{setf} (@var{gcontext-plane-mask} @emph{gc})) (@code{setf} (@var{gcontext-foreground} @emph{gc})) (@code{setf} (@var{gcontext-background} @emph{gc})) (@code{setf} (@var{gcontext-line-width} @emph{gc})) (@code{setf} (@var{gcontext-line-style} @emph{gc})) (@code{setf} (@var{gcontext-cap-style} @emph{gc})) (@code{setf} (@var{gcontext-join-style} @emph{gc})) (@code{setf} (@var{gcontext-fill-style} @emph{gc})) (@code{setf} (@var{gcontext-fill-rule} @emph{gc})) (@code{setf} (@var{gcontext-tile} @emph{gc})) (@code{setf} (@var{gcontext-stipple} @emph{gc})) (@code{setf} (@var{gcontext-ts-x} @emph{gc})) (@code{setf} (@var{gcontext-ts-y} @emph{gc})) (@code{setf} (@var{gcontext-font} @emph{gc} &optional @var{metrics-p})) (@code{setf} (@var{gcontext-subwindow-mode} @emph{gc})) (@code{setf} (@var{gcontext-exposures} @emph{gc}))) (@code{setf} (@var{gcontext-clip-x} @emph{gc})) (@code{setf} (@var{gcontext-clip-y} @emph{gc})) (@code{setf} (@var{gcontext-clip-mask} @emph{gc} &optional @var{ordering})) (@code{setf} (@var{gcontext-dash-offset} @emph{gc})) (@code{setf} (@var{gcontext-dashes} @emph{gc})) (@code{setf} (@var{gcontext-arc-mode} @emph{gc})) (@code{setf} (@var{gcontext-clip-ordering} @emph{gc})) @var{X11 Request Name CLX Function Name} ChangeHosts @var{add-access-host} ChangeHosts @var{remove-access-host} ChangeKeyboardControl @var{change-keyboard-control} ChangePointerControl @var{change-pointer-control} ChangeProperty @var{change-property} ChangeSaveSet @var{remove-from-save-set} ChangeSaveSet @var{add-to-save-set} ChangeWindowAttributes (See @var{with-state}) (@code{setf} (@var{window-background} @emph{window})) (@code{setf} (@var{window-border} @emph{window})) (@code{setf} (@var{window-bit-gravity} @emph{window})) (@code{setf} (@var{window-gravity} @emph{window})) (@code{setf} (@var{window-backing-store} @emph{window})) (@code{setf} (@var{window-backing-planes} @emph{window})) (@code{setf} (@var{window-backing-pixel} @emph{window})) (@code{setf} (@var{window-override-redirect} @emph{window}) @code{(setf (window-save-under} @emph{window}@var{))} (@code{setf} (@var{window-colormap} @emph{window})) (@code{setf} (@var{window-cursor} @emph{window})) (@code{setf} (@var{window-event-mask} @emph{window})) (@code{setf} (@var{window-do-not-propagate-mask} @emph{window})) CirculateWindow @var{circulate-window-down} CirculateWindow @var{circulate-window-up} ClearToBackground @var{clear-area} CloseFont @var{close-font} ConfigureWindow (See @var{with-state}) (@code{setf} (@var{drawable-x} @emph{drawable})) (@code{setf} (@var{drawable-y} @emph{drawabl}e)) (@code{setf} (@var{drawable-width} @emph{drawable})) (@code{setf} (@var{drawable-height} @emph{drawable})) (@code{setf} (@var{drawable-depth} @emph{drawable})) (@code{setf} (@var{drawable-border-width} @emph{drawable})) (@code{setf} (@var{window-priority} @emph{window} &optional @var{sibling})) ConvertSelection@var{convert-selection} CopyArea @var{copy-area} CopyColormapAndFree @var{copy-colormap-and-free} CopyGC@var{copy-gcontext} CopyGC@var{copy-gcontext-components} CopyPlane @var{copy-plane} CreateColormap @var{create-colormap} CreateCursor @var{create-cursor} CreateGC @var{create-gcontext} CreateGlyphCursor @var{create-glyph-cursor} CreatePixmap @var{create-pixmap} CreateWindow @var{create-window} DeleteProperty @var{delete-property} DestroySubwindows @var{destroy-subwindows} DestroyWindow @var{destroy-window} FillPoly @var{draw-lines} ForceScreenSaver@var{reset-screen-saver} ForceScreenSaver@var{activate-screen-saver} FreeColormap @var{free-colormap} FreeColors @var{free-colors} FreeCursor @var{free-cursor} @var{X11 Request Name CLX Function Name} FreeGC@var{free-gcontext} FreePixmap @var{free-pixmap} GetAtomName @var{atom-name} GetFontPath @var{font-path} GetGeometry (See @var{with-state}) @var{drawable-root} @var{drawable-x} @var{drawable-y} @var{drawable-width} @var{drawable-height} @var{drawable-depth} @var{drawable-border-width} GetImage @var{get-raw-image} GetInputFocus @var{input-focus} GetKeyboardControl @var{keyboard-control} GetKeyboardMapping @var{keyboard-mapping} GetModifierMapping @var{modifier-mapping} GetMotionEvents @var{motion-events} GetPointerControl @var{pointer-control} GetPointerMapping @var{pointer-mapping} GetProperty @var{get-property} GetScreenSaver @var{screen-saver} GetSelectionOwner @var{selection-owner} GetWindowAttributes (See @var{with-state}) @var{window-visual} @var{window-class} @var{window-bit-gravity} @var{window-gravity} @var{window-backing-store} @var{window-backing-planes} @var{window-backing-pixel} @var{window-save-under} @var{window-override-redirect} @var{window-event-mask} @var{window-do-not-propagate-mask} @var{window-colormap} @var{window-colormap-installed-p} @var{window-all-event-masks} @var{window-map-state} GrabButton @var{grab-button} GrabKey @var{grab-key} GrabKeyboard @var{grab-keyboard} GrabPointer @var{grab-pointer} GrabServer @var{grab-server} ImageText16 @var{draw-image-glyphs} ImageText16 @var{draw-image-glyph} ImageText8 @var{draw-image-glyphs} InstallColormap @var{install-colormap} InternAtom @var{find-atom} InternAtom @var{intern-atom} KillClient @var{kill-temporary-clients} KillClient @var{kill-client} ListExtensions @var{list-extensions} ListFonts @var{list-font-names} ListFontsWithInfo @var{list-fonts} ListHosts @var{access-control} @var{X11 Request Name CLX Function Name} ListHosts @var{access-hosts} ListInstalledColormaps @var{installed-colormaps} ListProperties @var{list-properties} LookupColor @var{lookup-color} MapSubwindows @var{map-subwindows} MapWindow @var{map-window} OpenFont @var{open-font} PolyArc @var{draw-arc} PolyArc @var{draw-arcs} PolyFillArc @var{draw-arc} PolyFillArc @var{draw-arcs} PolyFillRectangle @var{draw-rectangle} PolyFillRectangle @var{draw-rectangles} PolyLine @var{draw-line} PolyLine @var{draw-lines} PolyPoint @var{draw-point} PolyPoint @var{draw-points} PolyRectangle @var{draw-rectangle} PolyRectangle @var{draw-rectangles} PolySegment @var{draw-segments} PolyText16 @var{draw-glyph} PolyText16 @var{draw-glyphs} PolyText8 @var{draw-glyphs} PutImage @var{put-raw-image} QueryBestSize @var{query-best-cursor} QueryBestSize @var{query-best-stipple} QueryBestSize @var{query-best-tile} QueryColors @var{query-colors} QueryExtension @var{query-extension} QueryFont @var{font-name} @var{font-name} @var{font-direction} @var{font-min-char} @var{font-max-char} @var{font-min-byte1} @var{font-max-byte1} @var{font-min-byte2} @var{font-max-byte2} @var{font-all-chars-exist-p} @var{font-default-char} @var{font-ascent} @var{font-descent} @var{font-properties} @var{font-property} @var{char-left-bearing} @var{char-right-bearing} @var{char-width} @var{char-ascent} @var{char-descent} @var{char-attributes} @var{min-char-left-bearing} @var{min-char-right-bearing} @var{min-char-width} @var{min-char-ascent} @var{min-char-descent} @var{min-char-attributes} @var{X11 Request Name CLX Function Name} @var{max-char-left-bearing} @var{max-char-right-bearing} @var{max-char-width} @var{max-char-ascent} @var{max-char-descent} @var{max-char-attributes} QueryKeymap @var{query-keymap} QueryPointer @var{global-pointer-position} QueryPointer @var{pointer-position} QueryPointer @var{query-pointer} QueryTextExtents@var{text-extents} QueryTextExtents@var{text-width} QueryTree @var{query-tree} RecolorCursor @var{recolor-cursor} ReparentWindow @var{reparent-window} RotateProperties@var{rotate-properties} SendEvent @var{send-event} SetClipRectangles @var{force-gcontext-changes} (See @var{with-gcontext}) (@code{setf} (@var{gcontext-clip-x} @emph{gc})) (@code{setf} (@var{gcontext-clip-y} @emph{gc})) (@code{setf} (@var{gcontext-clip-mask} @emph{gc} &optional @var{ordering})) (@code{setf} (@var{gcontext-clip-ordering} @emph{gc})) SetDashes @var{force-gcontext-changes} (See @var{with-gcontext}) (@code{setf} (@var{gcontext-dash-offset} @emph{gc})) (@code{setf} (@var{gcontext-dashes} @emph{gc})) SetFontPath (@code{setf} (@var{font-path} @emph{font}) SetInputFocus @var{set-input-focus} SetKeyboardMapping @var{change-keyboard-mapping} SetModifierMapping @var{set-modifier-mapping} SetPointerMapping @var{set-pointer-mapping} SetScreenSaver @var{set-screen-saver} SetSelectionOwner @var{set-selection-owner} StoreColors @var{store-color} StoreColors @var{store-colors} StoreNamedColor @var{store-color} StoreNamedColor @var{store-colors} TranslateCoords @var{translate-coordinates} UngrabButton @var{ungrab-button} UngrabKey @var{ungrab-key} UngrabKeyboard @var{ungrab-keyboard} UngrabPointer @var{ungrab-pointer} UngrabServer @var{ungrab-server} UninstallColormap @var{uninstall-colormap} UnmapSubwindows @var{unmap-subwindows} UnmapWindow @var{unmap-window} WarpPointer @var{warp-pointer} WarpPointer @var{warp-pointer-if-inside} WarpPointer @var{warp-pointer-relative} WarpPointer @var{warp-pointer-relative-if-inside} ListHosts @var{access-control} ListHosts @var{access-hosts} ForceScreenSaver@var{activate-screen-saver} ChangeHosts @var{add-access-host} @var{X11 Request Name CLX Function Name} ChangeSaveSet @var{add-to-save-set} AllocColor @var{alloc-color} AllocNamedColor @var{alloc-color} AllocColorCells @var{alloc-color-cells} AllocColorPlanes@var{alloc-color-planes} AllowEvents @var{allow-events} GetAtomName @var{atom-name} Bell @var{bell} ChangeActivePointerGrab @var{change-active-pointer-grab} ChangeKeyboardControl @var{change-keyboard-control} SetKeyboardMapping @var{change-keyboard-mapping} ChangePointerControl @var{change-pointer-control} ChangeProperty @var{change-property} QueryFont @var{char-ascent} QueryFont @var{char-attributes} QueryFont @var{char-descent} QueryFont @var{char-left-bearing} QueryFont @var{char-right-bearing} QueryFont @var{char-width} CirculateWindow @var{circulate-window-down} CirculateWindow @var{circulate-window-up} ClearToBackground @var{clear-area} CloseFont @var{close-font} ConvertSelection@var{convert-selection} CopyArea @var{copy-area} CopyColormapAndFree @var{copy-colormap-and-free} CopyGC@var{copy-gcontext} CopyGC@var{copy-gcontext-components} CopyPlane @var{copy-plane} CreateColormap @var{create-colormap} CreateCursor @var{create-cursor} CreateGC @var{create-gcontext} CreateGlyphCursor @var{create-glyph-cursor} CreatePixmap @var{create-pixmap} CreateWindow @var{create-window} DeleteProperty @var{delete-property} DestroySubwindows @var{destroy-subwindows} DestroyWindow @var{destroy-window} PolyArc @var{draw-arc} PolyArc @var{draw-arcs} PolyText16 @var{draw-glyph} PolyText16 @var{draw-glyphs} PolyText8 @var{draw-glyphs} ImageText16 @var{draw-image-glyph} ImageText16 @var{draw-image-glyphs} ImageText8 @var{draw-image-glyphs} PolyLine @var{draw-line} PolyLine @var{draw-lines} PolyPoint @var{draw-point} PolyPoint @var{draw-points} PolyFillRectangle @var{draw-rectangle} PolyRectangle @var{draw-rectangle} PolyFillRectangle @var{draw-rectangles} PolyRectangle @var{draw-rectangles} PolySegment @var{draw-segments} GetGeometry @var{drawable-border-width} @var{X11 Request Name CLX Function Name} GetGeometry @var{drawable-depth} GetGeometry @var{drawable-height} GetGeometry @var{drawable-root} GetGeometry @var{drawable-width} GetGeometry @var{drawable-x} GetGeometry @var{drawable-y} FillPoly @var{fill-polygon} InternAtom @var{find-atom} QueryFont @var{font-all-chars-exist-p} QueryFont @var{font-ascent} QueryFont @var{font-default-char} QueryFont @var{font-descent} QueryFont @var{font-direction} QueryFont @var{font-max-byte1} QueryFont @var{font-max-byte2} QueryFont @var{font-max-char} QueryFont @var{font-min-byte1} QueryFont @var{font-min-byte2} QueryFont @var{font-min-char} QueryFont @var{font-name} QueryFont @var{font-name} GetFontPath @var{font-path} QueryFont @var{font-properties} QueryFont @var{font-property} ChangeGC @var{force-gcontext-changes} SetClipRectangles @var{force-gcontext-changes} SetDashes @var{force-gcontext-changes} FreeColormap @var{free-colormap} FreeColors @var{free-colors} FreeCursor @var{free-cursor} FreeGC@var{free-gcontext} FreePixmap @var{free-pixmap} GetProperty @var{get-property} GetImage @var{get-raw-image} QueryPointer @var{global-pointer-position} GrabButton @var{grab-button} GrabKey @var{grab-key} GrabKeyboard @var{grab-keyboard} GrabPointer @var{grab-pointer} GrabServer @var{grab-server} GrabServer @var{with-server-grabbed} GetInputFocus @var{input-focus} InstallColormap @var{install-colormap} ListInstalledColormaps @var{installed-colormaps} InternAtom @var{intern-atom} GetKeyboardControl @var{keyboard-control} GetKeyboardMapping @var{keyboard-mapping} KillClient @var{kill-client} KillClient @var{kill-temporary-clients} ListExtensions @var{list-extensions} ListFonts @var{list-font-names} ListFontsWithInfo @var{list-fonts} ListProperties @var{list-properties} LookupColor @var{lookup-color} MapSubwindows @var{map-subwindows} MapWindow @var{map-window} @var{X11 Request Name CLX Function Name} QueryFont @var{max-char-ascent} QueryFont @var{max-char-attributes} QueryFont @var{max-char-descent} QueryFont @var{max-char-left-bearing} QueryFont @var{max-char-right-bearing} QueryFont @var{max-char-width} QueryFont @var{min-char-ascent} QueryFont @var{min-char-attributes} QueryFont @var{min-char-descent} QueryFont @var{min-char-left-bearing} QueryFont @var{min-char-right-bearing} QueryFont @var{min-char-width} GetModifierMapping @var{modifier-mapping} GetMotionEvents @var{motion-events} OpenFont @var{open-font} GetPointerControl @var{pointer-control} GetPointerMapping @var{pointer-mapping} QueryPointer @var{pointer-position} PutImage @var{put-raw-image} QueryBestSize @var{query-best-cursor} QueryBestSize @var{query-best-stipple} QueryBestSize @var{query-best-tile} QueryColors @var{query-colors} QueryExtension @var{query-extension} QueryKeymap @var{query-keymap} QueryPointer @var{query-pointer} QueryTree @var{query-tree} RecolorCursor @var{recolor-cursor} ChangeHosts @var{remove-access-host} ChangeSaveSet @var{remove-from-save-set} ReparentWindow @var{reparent-window} ForceScreenSaver@var{reset-screen-saver} RotateProperties@var{rotate-properties} GetScreenSaver @var{screen-saver} GetSelectionOwner @var{selection-owner} SendEvent @var{send-event} ChangeAccessControl @var{set-access-control} ChangeCloseDownMode @var{set-close-down-mode} SetInputFocus @var{set-input-focus} SetModifierMapping @var{set-modifier-mapping} SetPointerMapping @var{set-pointer-mapping} SetScreenSaver @var{set-screen-saver} SetSelectionOwner @var{set-selection-owner} StoreColors @var{store-color} StoreColors @var{store-colors} StoreNamedColor @var{store-color} StoreNamedColor @var{store-colors} QueryTextExtents@var{text-extents} QueryTextExtents@var{text-width} TranslateCoords @var{translate-coordinates} UngrabButton @var{ungrab-button} UngrabKey @var{ungrab-key} UngrabKeyboard @var{ungrab-keyboard} UngrabPointer @var{ungrab-pointer} UngrabServer @var{ungrab-server} UngrabServer @var{with-server-grabbed} @var{X11 Request Name CLX Function Name} UninstallColormap @var{uninstall-colormap} UnmapSubwindows @var{unmap-subwindows} UnmapWindow @var{unmap-window} WarpPointer @var{warp-pointer} WarpPointer @var{warp-pointer-if-inside} WarpPointer @var{warp-pointer-relative} WarpPointer @var{warp-pointer-relative-if-inside} GetWindowAttributes @var{window-all-event-masks} GetWindowAttributes @var{window-backing-pixel} GetWindowAttributes @var{window-backing-planes} GetWindowAttributes @var{window-backing-store} GetWindowAttributes @var{window-bit-gravity} GetWindowAttributes @var{window-class} GetWindowAttributes @var{window-colormap} GetWindowAttributes @var{window-colormap-installed-p} GetWindowAttributes @var{window-do-not-propagate-mask} GetWindowAttributes @var{window-event-mask} GetWindowAttributes @var{window-gravity} GetWindowAttributes @var{window-map-state} GetWindowAttributes @var{window-override-redirect} GetWindowAttributes @var{window-save-under} GetWindowAttributes @var{window-visual} ConfigureWindow (@code{setf} (@var{drawable-border-width} @emph{drawable})) ConfigureWindow (@code{setf} (@var{drawable-depth} @emph{drawable})) ConfigureWindow (@code{setf} (@var{drawable-height} @emph{drawable})) ConfigureWindow (@code{setf} (@var{drawable-width} @emph{drawabl}e)) ConfigureWindow (@code{setf} (@var{drawable-x} @emph{drawable})) ConfigureWindow (@code{setf} (@var{drawable-y} @emph{drawable})) SetFontPath (@code{setf} (@var{font-path} @emph{font}) @var{paths}) ChangeGC (@code{setf} (@var{gcontext-arc-mode} @emph{gc})) ChangeGC (@code{setf} (@var{gcontext-background} @emph{gc})) ChangeGC (@code{setf} (@var{gcontext-cap-style} @emph{gc})) SetClipRectangles (@code{setf} (@var{gcontext-clip-mask} @emph{gc} &optional @var{ordering})) SetClipRectangles (@code{setf} (@var{gcontext-clip-ordering} @emph{gc})) SetClipRectangles (@code{setf} (@var{gcontext-clip-x} @emph{gc})) SetClipRectangles (@code{setf} (@var{gcontext-clip-y} @emph{gc})) SetDashes (@code{setf} (@var{gcontext-dash-offset} @emph{gc})) SetDashes (@code{setf} (@var{gcontext-dashes} @emph{gc})) ChangeGC (@code{setf} (@var{gcontext-exposures} @emph{gc})) ChangeGC (@code{setf} (@var{gcontext-fill-rule} @emph{gc}) @var{keyword}) ChangeGC (@code{setf} (@var{gcontext-fill-style} @emph{gc}) @var{keyword}) ChangeGC (@code{setf} (@var{gcontext-font} @emph{gc} &optional @var{metrics-p}) ChangeGC (@code{setf} (@var{gcontext-foreground} @emph{gc}) @var{card32}) ChangeGC (@code{setf} (@var{gcontext-function} @emph{gc})) ChangeGC (@code{setf} (@var{gcontext-join-style} @emph{gc}) @var{keyword}) ChangeGC (@code{setf} (@var{gcontext-line-style} @emph{gc}) @var{keyword}) ChangeGC (@code{setf} (@var{gcontext-line-width} @emph{gc}) @var{card16}) ChangeGC (@code{setf} (@var{gcontext-plane-mask} @emph{gc}) @var{card32}) ChangeGC (@code{setf} (@var{gcontext-stipple} @emph{gc}) @var{pixmap}) ChangeGC (@code{setf} (@var{gcontext-subwindow-mode} @emph{gc})) ChangeGC (@code{setf} (@var{gcontext-tile} @emph{gc})) ChangeGC (@code{setf} (@var{gcontext-ts-x} @emph{gc})) ChangeGC (@code{setf} (@var{gcontext-ts-y} @emph{gc})) ChangeWindowAttributes (@code{setf} (@var{window-background} @emph{window})) @var{X11 Request Name CLX Function Name} ChangeWindowAttributes (@code{setf} (@var{window-backing-pixel} @emph{window})) ChangeWindowAttributes (@code{setf} (@var{window-backing-planes} @emph{window})) ChangeWindowAttributes (@code{setf} (@var{window-backing-store} @emph{window})) ChangeWindowAttributes (@code{setf} (@var{window-bit-gravity} @emph{window})) ChangeWindowAttributes (@code{setf} (@var{window-border} @emph{window})) ChangeWindowAttributes (@code{setf} (@var{window-colormap} @emph{window})) ChangeWindowAttributes (@code{setf} (@var{window-cursor} @emph{window})) ChangeWindowAttributes (@code{setf} (@var{window-do-not-propagate-mask} @emph{window})) ChangeWindowAttributes (@code{setf} (@var{window-event-mask} @emph{window})) ChangeWindowAttributes (@code{setf} (@var{window-gravity} @emph{window})) ChangeWindowAttributes (@code{setf} (@var{window-override-redirect} @emph{window})) ConfigureWindow (@code{setf} (@var{window-priority} @emph{window} &optional @var{sibling})) ChangeWindowAttributes (@code{setf} (@var{window-save-under} @emph{window})) @end ignore @node Undocumented, Glossary, Errors, Top @chapter Undocumented This section just lists all symbols exported from the @var{XLIB} package but not documented in this manual. @defun bitmap-image &optional plist &rest patterns @end defun @defun character->keysyms character &optional display @end defun @defun character-in-map-p display character keymap @table @var @item display A @var{display}. @end table @end defun @defun decode-core-error display event &optional arg @end defun @defun default-error-handler display error-key &rest key-vals &key asynchronous &allow-other-keys @end defun @defun default-keysym-index display keycode state @end defun @defun default-keysym-translate display state object @end defun @defun define-keysym object keysym &key lowercase translate modifiers mask display @end defun @defun define-keysym-set set first-keysym last-keysym @end defun @defun display-invoke-after-function display Explicitly invokes the @emph{after-function} of the display. (see @var{display-after-function}). This function is internally called after every request. @end defun @defun display-nscreens display @end defun @defun display-release-number object @end defun @defun event-handler handlers event-key @end defun @defun get-external-event-code display event @end defun @defun get-standard-colormap window property @end defun @defun get-wm-class window @end defun @defun icon-sizes window @end defun @defun iconify-window window screen @end defun @defun keysym->keycodes display keysym @end defun @defun keysym-in-map-p display keysym keymap @end defun @defun keysym-set keysym @end defun @defun mapping-notify display request start count Called on a @var{:mapping-notify} event to update the keyboard-mapping cache in @emph{display}. @end defun @defun no-operation display @end defun @defun parse-color colormap spec @end defun @defun resource-database-timestamp database @end defun @defun resource-key stringable @end defun @defun rgb-colormaps window property @end defun @defun root-resources screen &key database key test test-not Returns a resource database containing the contents of the root window @var{RESOURCE_MANAGER} property for the given @emph{screen}. If @emph{screen} is a display, then its default screen is used. If an existing @emph{database} is given, then resource values are merged with the @emph{database} and the modified @emph{database} is returned. @emph{test} and @emph{test-not} are predicates for selecting which resources are read. Arguments are a resource name list and a resource value. The @emph{key} function, if given, is called to convert a resource value string to the value given to @emph{test} or @emph{test-not}. @end defun @defun rotate-cut-buffers display &optional (delta 1) (careful-p t) @end defun @defun set-access-control display enabled-p @end defun @defun set-close-down-mode display mode @anchor{set-close-down-mode} @end defun @defun set-pointer-mapping display map @end defun @defun set-selection-owner display selection owner &optional time @end defun @defun set-standard-colormap window property colormap base-pixel max-color mult-color @end defun @defun set-standard-properties window &rest options @end defun @defun set-wm-class window resource-name resource-class @end defun @defun set-wm-properties window &rest options &key name icon-name resource-name resource-class command client-machine hints normal-hints zoom-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 input initial-state icon-pixmap icon-window icon-x icon-y icon-mask window-group @end defun @defun set-wm-resources database window &key write test test-not @end defun @defun transient-for window @end defun @defun translate-default src src-start src-end font dst dst-start @end defun @defun undefine-keysym object keysym &key display modifiers &allow-other-keys @end defun @defun visual-info-blue-mask object @end defun @defun visual-info-green-mask object @end defun @defun visual-info-red-mask object @end defun @defun window-cursor window @end defun @defun window-visual-info window @end defun @defun withdraw-window window screen @end defun @defun wm-client-machine window @end defun @defun wm-colormap-windows window @end defun @defun wm-command window @end defun @defun wm-hints window @end defun @defun wm-hints-flags object @end defun @defun wm-icon-name window @end defun @defun wm-name window @end defun @defun wm-normal-hints window @end defun @defun wm-protocols window @end defun @defun wm-resources database window &key key test test-not @end defun @defun wm-zoom-hints window @end defun @ignore XLIB:STATE-KEYSYM-P is undocumented. XLIB:*VERSION* is undocumented. XLIB:BITMAP-FORMAT-LSB-FIRST-P ??? [Function] XLIB:BITMAP-FORMAT-P ??? [Function] XLIB:BITMAP-FORMAT-PAD ???[Function] XLIB:BITMAP-FORMAT-UNIT ??? [Function] XLIB:CARD8->CHAR (card8) [Function] XLIB:CHAR->CARD8 (char) [Function] XLIB:COLORMAP-VISUAL-INFO ??? [Function] XLIB:CUT-BUFFER (display &key (buffer 0) (type :string) (result-type 'string) (transform #'card8->char) (start 0) end) [Function] XLIB:DEFINE-ERROR ??? [Function] XLIB:DEFINE-EXTENSION ??? [Function] XLIB:DEFINE-GCONTEXT-ACCESSOR ??? [Function] XLIB:DISPLAY-DEFAULT-SCREEN ??? [Function] XLIB:DISPLAY-HOST ??? [Function] XLIB:DISPLAY-REPORT-ASYNCHRONOUS-ERRORS ??? [Function] XLIB:DISPLAY-XDEFAULTS ???[Function] XLIB:EXTENSION-OPCODE ??? [Function] XLIB:GCONTEXT-CLIP-ORDERING is undocumented. XLIB:GENERALIZED-BOOLEAN is undocumented. XLIB:ILLEGAL-REQUEST-ERROR is undocumented. XLIB:IMAGE is undocumented. XLIB:IMAGE-PIXMAP (drawable image &key gcontext width height depth) [Function] XLIB:IMAGE-X is undocumented. XLIB:IMAGE-X-P ??? [Function] XLIB:IMAGE-XY is undocumented. XLIB:IMAGE-XY-P ??? [Function] XLIB:IMAGE-Z is undocumented. XLIB:IMAGE-Z-P ??? [Function] XLIB:INVALID-FONT is undocumented. XLIB:KEYCODE->CHARACTER (display keycode state &key keysym-index (keysym-index-function #'default-keysym-index)) [Function] XLIB:MAKE-EVENT-HANDLERS (&key (type 'array) default) [Function] XLIB:MAKE-WM-HINTS (&key ((:input #:g0) nil) ((:initial-state #:g1) nil) ((:icon-pixmap #:g2) nil) ((:icon-window #:g3) nil) ((:icon-x #:g4) nil) ((:icon-y #:g5) nil) ((:icon-mask #:g6) nil) ((:window-group #:g7) nil) ((:flags #:g8) 0)) [Function] XLIB:MAKE-WM-SIZE-HINTS (&key ((:user-specified-position-p #:g0) nil) ((:user-specified-size-p #:g1) nil) ((:x #:g2) nil) ((:y #:g3) nil) ((:width #:g4) nil) ((:height #:g5) nil) ((:min-width #:g6) nil) ((:min-height #:g7) nil) ((:max-width #:g8) nil) ((:max-height #:g9) nil) ((:width-inc #:g10) nil) ((:height-inc #:g11) nil) ((:min-aspect #:g12) nil) ((:max-aspect #:g13) nil) ((:base-width #:g14) nil) ((:base-height #:g15) nil) ((:win-gravity #:g16) nil) ((:program-specified-position-p #:g17) nil) ((:program-specified-size-p #:g18) nil)) [Function] XLIB:PIXMAP-FORMAT-BITS-PER-PIXEL ??? [Function] XLIB:PIXMAP-FORMAT-DEPTH ??? [Function] XLIB:PIXMAP-FORMAT-P ??? [Function] XLIB:PIXMAP-FORMAT-SCANLINE-PAD ??? [Function] XLIB:RESOURCE-DATABASE is undocumented. XLIB:SCREEN-ROOT-VISUAL-INFO ??? [Function] XLIB:TRANSLATION-FUNCTION is undocumented. XLIB:VISUAL-INFO-BITS-PER-RGB ??? [Function] XLIB:VISUAL-INFO-CLASS ???[Function] XLIB:VISUAL-INFO-COLORMAP-ENTRIES ??? [Function] XLIB:VISUAL-INFO-DISPLAY ??? [Function] XLIB:VISUAL-INFO-ID ??? [Function] XLIB:VISUAL-INFO-P ??? [Function] XLIB:VISUAL-INFO-PLIST ???[Function] XLIB:WINDOW-BACKGROUND is undocumented. XLIB:WINDOW-BORDER is undocumented. XLIB:WINDOW-PRIORITY is undocumented. XLIB:WM-HINTS-ICON-MASK ??? [Function] XLIB:WM-HINTS-ICON-PIXMAP ??? [Function] XLIB:WM-HINTS-ICON-WINDOW ??? [Function] XLIB:WM-HINTS-ICON-X ??? [Function] XLIB:WM-HINTS-ICON-Y ??? [Function] XLIB:WM-HINTS-INITIAL-STATE ??? [Function] XLIB:WM-HINTS-INPUT ??? [Function] XLIB:WM-HINTS-P ??? [Function] XLIB:WM-HINTS-WINDOW-GROUP ??? [Function] XLIB:WM-SIZE-HINTS-USER-SPECIFIED-POSITION-P ??? [Function] XLIB:WM-SIZE-HINTS-USER-SPECIFIED-SIZE-P ??? [Function] @end ignore @node Glossary, Function Index, Undocumented, Top @appendix Glossary @table @asis @item access control list X maintains a list of hosts from which client programs can be run. By default, only programs on the local host can use the display, plus any hosts specified in an initial list read by the server. This @emph{access control list} can be changed by clients on the local host. Some server implementations can also implement other authorization mechanisms in addition to or in place of this mechanism. The action of this mechanism can be conditional based on the authorization protocol name and data received by the server at connection setup. @item action A function that is designed to handle an input event. CLUE input processing consists of matching an event with an event specification found in a contact's @var{event-translations} slot and then calling actions associated with the matching event specification. @item active grab A grab is @emph{active} when the pointer or keyboard is actually owned by the single grabbing client. @item ancestors If W is an inferior of A, then A is an @emph{ancestor} of W. @item atom A unique ID corresponding to a string name. Atoms are used to identify properties, types, and selections. @item backing store When a server maintains the contents of a window, the off-screen saved pixels are known as a @emph{backing store}. @item before action An action of a @var{contact-display} that is called when an event is dispatched to a contact, but before any other contact input processing is performed. @item bit gravity When a window is resized, the contents of the window are not necessarily discarded. It is possible to request the server to relocate the previous contents to some region of the window. This attraction of window contents for some location of a window is known as @emph{bit} @emph{gravity}. @item bitmap A pixmap of depth one. @item button grabbing Buttons on the pointer can be passively @emph{grabbed} by a client. When the button is pressed, the pointer is then actively grabbed by the client. @item byte order For image (pixmap/bitmap) data, byte order is defined by the server, and clients with different native byte ordering must swap bytes as necessary. For all other parts of the protocol, the byte order is defined by the client, and the server swaps bytes as necessary. @item callback A function that represents a connection between a contact and the rest of an application program. A contact calls a callback function in order to report the results of the user interface component that it represents. @item children First-level subwindows of a window. @item class event Event translations that belong to all instances of a contact class. A class event @var{translations} translation is created by the @var{defevent} macro. @item class resources Resources defined for each instance of a contact class. Also see constraint resources. @item click A @var{:button-press} event followed immediately by a @var{:button-release} event for the same button, with no intervening change in pointer position or modifier key state. @item client An application program connects to the window system server by some interprocess communication (IPC) path, such as a TCP connection or a shared memory buffer. This program is referred to as a @emph{client} of the window system server. More precisely, the client is the IPC path itself. A program with multiple paths open to the server is viewed as multiple clients by the protocol. Resource lifetimes are controlled by connection lifetimes, not by program lifetimes. @item clipping regions In a graphics context, a bitmap or list of rectangles can be specified to restrict output to a particular region of the window. The image defined by the bitmap or rectangles is called a @emph{clipping region}. @item colormap A set of entries defining color values. The colormap associated with a window is used to display the contents of the window. Each pixel value indexes the colormap to produce RGB values that drive the guns of a monitor. Depending on hardware limitations, one or more colormaps can be installed at one time, such that windows associated with those maps display with correct colors. @item composite A subclass of @var{contact} representing contacts that are the parents of other contacts. A composite provides geometry management and input focus management services for the contacts that are its children. @item complete resource class A list of symbols containing the class of the contact, the class of the contact's @var{parent} (and so on), and the class of the @var{contact-display} to which the contact belongs. The complete resource class is one of the two items used as a key by a CLUE application in order to access a contact resource value in a resource database. @item complete resource name A list of symbols containing the @var{name} of the contact, the @var{name} of the contact's @var{parent} (and so on), and the name of the @var{contact-display} to which the contact belongs. The complete resource name is one of the two items used as a key by a CLUE application in order to access a contact resource value in a resource database. @item connection The IPC path between the server and client program. A client program typically has one connection to the server over which requests and events are sent. @item constraint resources Resources defined for each child belonging to a member of a composite class. Constraint resources are typically used to control the parent's geometry management policy. Also see class resources. @item contact The basic CLUE object for programming a user interface. @item contact-display The CLUE object type that represents a connection to an X server and that supports an event loop for application input. @item contact initialization The process of collecting initial values for all contact attributes. No server resources (windows and so on) are actually allocated until contact realization. @item contact realization The process of allocating contact resources. This process completes contact creation. @item containment A window contains the pointer if the window is viewable and the hot spot of the cursor is within a visible region of the window or a visible region of one of its inferiors. The border of the window is included as part of the window for containment. The pointer is in a window if the window contains the pointer but no inferior contains the pointer. @item content The single child of a shell. The basic geometry management policy implemented by the @var{shell} class constrains a shell and its content to have the same width and height; size changes to one are automatically applied to the other. @item coordinate system The coordinate system has x horizontal and y vertical, with the origin [0, 0] at the upper left. Coordinates are discrete and are in terms of pixels. Each window and pixmap has its own coordinate system. For a window, the origin is at the inside upper left, inside the border. @item cursor The visible shape of the pointer on a screen. It consists of a hot-spot, a source bitmap, a shape bitmap, and a pair of colors. The cursor defined for a window controls the visible appearance when the pointer is in that window. @item depth The depth of a window or pixmap is number of bits per pixel it has. The depth of a graphics context is the depth of the drawables it can be used in conjunction with for graphics output. @item descendant If W is an inferior of A, then W is a @emph{descendant} of A. @item device Keyboards, mice, tablets, track-balls, button boxes, and so forth, are all collectively known as input @emph{devices}. The core protocol only deals with two devices: the keyboard and the pointer. @item direct color A class of colormap in which a pixel value is decomposed into three separate subfields for indexing. One subfield indexes an array to produce red intensity values, the second subfield indexes a second array to produce blue intensity values, and the third subfield indexes a third array to produce green intensity values. The RGB values can be changed dynamically. @item dispatching an event The process of finding the appropriate contact and its actions. @item double-click A sequence of two clicks of the same button in rapid succession. @item drawable Both windows and pixmaps can be used as sources and destinations in graphics operations. These are collectively known as @emph{drawables}. However, an @var{:input-only} window cannot be used as a source or destination in a graphics operation. @item event Clients receive information asynchronously via @emph{events}. These events can be either asynchronously generated from devices, or generated as side effects of client requests. Events are grouped into types; events are never sent to a client by the server unless the client has specifically asked to be informed of that type of event, but clients can force events to be sent to other clients. Events are typically reported relative to a window. @item event compression Ignoring (or compressing) certain redundant input events. Compression of redundant events is controlled by the class slots @var{compress-exposures} and @var{compress-motion}, which are shared by all instances of a contact class. @item event loop The fundamental application control structure: wait for an event, figure out how to handle it, process the event, then go back and wait for the next one. In CLUE, the event loop is implemented using the @var{process-next-event} function. @item event mask Events are requested relative to a window. The set of event types a client requests relative to a window are described using an @emph{event mask}. @item event propagation Device-related events @emph{propagate} from the source window to ancestor windows until some client has expressed interest in handling that type of event, or until the event is discarded explicitly. @item event specification A notation for describing a certain sort of event. CLUE input processing consists of matching an event with an event specification found in a contact's @var{event-translations} slot and then calling actions associated with the matching event specification. @item event synchronization Certain race conditions are possible when demultiplexing device events to clients (in particular deciding where pointer and keyboard events should be sent when in the middle of window management operations). The event synchronization mechanism allows synchronous processing of device events. @item event source The smallest window containing the pointer is the @emph{source} of a device related event. @item event translation The process of determining which contact action functions will be executed. An event translation is a list found in a contact's @var{event-translations} slot associating an event specification with one or more action names. Also see class event translations. @item exposure event Servers do not guarantee to preserve the contents of windows when windows are obscured or reconfigured. @emph{Exposure} events are sent to clients to inform them when contents of regions of windows have been lost. @item extension Named @emph{extensions} to the core protocol can be defined to extend the system. Extension to output requests, resources, and event types are all possible, and expected. @item focus window Another term for the input focus. @item font A matrix of glyphs (typically characters). The protocol does no translation or interpretation of character sets. The client simply indicates values used to index the glyph array. A font contains additional metric information to determine inter-glyph and inter-line spacing. @item geometry management The process whereby a composite controls the geometrical properties of its child contacts; the composite is referred to as the geometry manager. @item glyph An image, typically of a character, in a font. @item grab Keyboard keys, the keyboard, pointer buttons, the pointer, and the server can be @emph{grabbed} for exclusive use by a client. In general, these facilities are not intended to be used by normal applications but are intended for various input and window managers to implement various styles of user interfaces. @item gcontext Shorthand for graphics context. @item graphics context Various information for graphics output is stored in a @emph{graphics context} (or gcontext), such as foreground pixel, background pixel, line width, clipping region, and so forth. A graphics context can only be used with drawables that have the same root and the same depth as the graphics context. @item gray scale A degenerate case of pseudo color, in which the red, green, and blue values in any given colormap entry are equal, thus producing shades of gray. The gray values can be changed dynamically. @item hot spot A cursor has an associated @emph{hot spot} that defines a point in the cursor that corresponds to the coordinates reported for the pointer. @item identifier Each resource has an @emph{identifier}, a unique value associated with it that clients use to name the resource. An identifier can be used over any connection to name the resource. @item inferiors All of the subwindows nested below a window: the children, the children's children, and so on. @item initialization See contact initialization. @item input event See event. @item input focus Normally a window defining the scope for processing of keyboard input. If a generated keyboard event would normally be reported to this window or one of its inferiors, the event is reported normally; otherwise, the event is reported with respect to the focus window. The input focus also can be set such that all keyboard events are discarded and that the focus window is dynamically taken to be the root window of whatever screen the pointer is on at each keyboard event. @item input-only window A window that cannot be used for graphics requests. @emph{input-only} windows are invisible, and can be used to control such things as cursors, input event generation, and grabbing. @emph{input-only} windows cannot have @emph{input/output} windows as inferiors. @item input/output window The normal kind of opaque window, used for both input and output. Input/output windows can have both @emph{input/output} and input-only windows as inferiors. @item insensitivity See sensitivity. @item interactive-stream A contact subclass designed to integrate CLUE with the conventional stream-based I/O of Common Lisp. @item key grabbing Keys on the keyboard can be passively @emph{grabbed} by a client. When the key is pressed, the keyboard is then actively grabbed by the client. @item keyboard grabbing A client can actively @emph{grab} control of the keyboard, and key events will be sent to that client rather than the client to which the events would normally have been sent. @item keysym An encoding of a symbol on a keycap on a keyboard. @item managed A contact under geometry management control. @item mapped A window is said to be @emph{mapped} if a map call has been performed on it. Unmapped windows and their inferiors are never viewable or visible. @item modifier keys SHIFT, CONTROL, META, SUPER, HYPER, ALT, Compose, Apple, CAPS LOCK, Shift Lock, and similar keys are called @emph{modifier keys}. @item monochrome A special case of static gray, in which there are only two colormap entries. @item obscure A window is @emph{obscured} if some other window obscures it. For example, window A obscures window B if: @itemize @bullet @item Both windows are viewable @var{:input-output} windows @item Window A is higher in the global stacking order than window B @item The rectangle defined by the outside edges of window A intersects the rectangle defined by the outside edges of window B @end itemize Notice that window borders are included in the calculation, and that a window can be obscured and yet still have visible regions. See occlude (there is a fine distinction between obscure and occlude). @item occlude A window is @emph{occluded} if some other window occludes it. For example, window A occludes window B if: @itemize @bullet @item Both windows are mapped @item Window A is higher in the global stacking order than window B @item The rectangle defined by the outside edges of window A intersects the rectangle defined by the outside edges of window B @end itemize Notice that window borders are included in the calculation. See obscure (there is a fine distinction between occlude and obscure). @item override-shell A subclass of @var{shell} used to override the window manager. This subclass contains pop-up menus and other temporary objects that the user can never resize and so on. @item padding Some padding bytes are inserted in the data stream to maintain alignment of the protocol requests on natural boundaries. This increases ease of portability to some machine architectures. @item parent window If C is a child of P, then P is the @emph{parent} of C. @item passive grab Grabbing a key or button is a @emph{passive grab}. The grab activates when the key or button is actually pressed. @item pixel value An @emph{n}-bit value, where @emph{n} is the number of bit planes used in (that is, the depth of) a particular window or pixmap. For a window, a pixel value indexes a colormap to derive an actual color to be displayed. @item pixmap A three dimensional array of bits. A pixmap is normally thought of as a two dimensional array of pixels, where each pixel can be a value from 0 to (2@emph{n})-1, where @emph{n} is the depth (z axis) of the pixmap. A pixmap can also be thought of as a stack of @emph{n} bitmaps. @item plane When a pixmap or window is thought of as a stack of bitmaps, each bitmap is called a @emph{plane} or @emph{bit plane}. @item plane mask Graphics operations can be restricted to only affect a subset of bit planes of a destination. A @emph{plane mask} is a bit mask describing which planes are to be modified, and it is stored in a graphics context. @item pointer The pointing device attached to the cursor and tracked on the screens. @item pointer grabbing A client can actively @emph{grab} control of the pointer, and button and motion events will be sent to that client rather than the client to which the events would normally have been sent. @item pointing device Typically a mouse or tablet, or some other device with effective dimensional motion. There is only one visible cursor defined by the core protocol, and it tracks whatever pointing device is attached as the pointer. @item pop-up One of the uses of a top-level shell (for example, a menu that pops up when a command button contact is activated). Setting the @var{state} of a shell to @var{:mapped} is sometimes referred to as @emph{mapping} or @emph{popping up} the shell. Setting the @var{state} of a shell to @var{:withdrawn} or @var{:iconic} is sometimes referred to as @emph{unmapping} or @emph{popping down} the shell. @item property Windows can have associated @emph{properties}, consisting of a name, a type, a data format, and some data. The protocol places no interpretation on properties; they are intended as a general-purpose naming mechanism for clients. For example, clients might share information such as resize hints, program names, and icon formats with a window manager via properties. @item property list The list of properties that have been defined for a window. @item pseudo color A class of colormap in which a pixel value indexes the colormap to produce independent red, green, and blue values. That is, the colormap is viewed as an array of triples (RGB values). The RGB values can be changed dynamically. @item realization See contact realization. @item redirecting control Window managers (or client programs) may choose to enforce window layout policy in various ways. When a client attempts to change the size or position of a window, the operation can be @emph{redirected} to a specified client, rather than the operation actually being performed. @item reply Information requested by a client program is sent back to the client with a @emph{reply}. Both events and replies are multiplexed on the same connection. Most requests do not generate replies. However, some requests generate multiple replies. @item representation type The type of representation of a resource value. For example, a color value might be represented either as a namestring ("red"), a pixel value, an RGB triplet, an HSV triplet, and so on. @item request A command to the server is called a @emph{request}. It is a single block of data sent over a connection. @item resource A value of the user interface that can be changed by the user in a resource database via CLX functions @var{add-resource}, @var{get-resource}, and so forth. See server resource. @item resource class, complete See complete resource class. @item resource database Conceptually, a set of resource name/value pairs (or resource bindings). CLX defines functions for storing and retrieving interface resources from a resource database. @item resource name, complete See complete resource name. @item RGB values @emph{Red}, @emph{green}, and @emph{blue} intensity values used to define color. These values are always represented as 16-bit unsigned numbers, with zero being the minimum intensity and 65535 being the maximum intensity. The values are scaled by the server to match the display hardware. @item root A special composite contact used to represent an entire display screen. @item root window Each screen has a @emph{root window} covering it. It cannot be reconfigured or unmapped, but otherwise acts as a full-fledged window. A root window has no parent. @item save set The @emph{save set} of a client is a list of other client's windows that, if they are inferiors of one of the client's windows at connection close, should not be destroyed and that should be remapped if it is unmapped. Save sets are typically used by window managers to avoid lost windows if the manager should terminate abnormally. @item scanline A list of pixel or bit values viewed as a horizontal row (all values having the same y coordinate) of an image, with the values ordered by increasing x coordinate. @item scanline order An image represented in @emph{scanline order} contains scanlines ordered by increasing y coordinate. @item screen A server can provide several independent @emph{screens}, which typically have physically independent monitors. This would be the expected configuration when there is only a single keyboard and pointer shared among the screens. @item selection A @emph{selection} can be thought of as an indirect property with dynamic type. That is, rather than having the property stored in the server, it is maintained by some client (the @emph{owner}). A selection is global in nature, being thought of as belonging to the user (but maintained by clients), rather than being private to a particular window subhierarchy or a particular set of clients. When a client asks for the contents of a selection, it specifies a selection @emph{target type}. This target type can be used to control the transmitted representation of the contents. For example, if the selection is "the last thing the user clicked on" and that is currently an image, then the target type might specify whether the contents of the image should be sent in XY Format or Z Format. The target type can also be used to control the class of contents transmitted; that is, asking for the looks (fonts, line spacing, indentation, and so forth) of a paragraph selection, rather than the text of the paragraph. The target type can also be used for other purposes; the semantics is not constrained by the protocol. @item sensitivity A condition in which a user interface component of an application will accept input. Conversely, when a contact is insensitive, events of particular types are not dispatched to the contact and are ignored. @item server The @emph{server} provides the basic windowing mechanism. It handles IPC connections from clients, demultiplexes graphics requests onto the screens, and multiplexes input back to the appropriate clients. @item server grabbing The server can be @emph{grabbed} by a single client for exclusive use. This prevents processing of any requests from other client connections until the grab is complete. This is typically only a transient state for such things as rubber-banding and pop-up menus, or to execute requests indivisibly. @item server resource Windows, pixmaps, cursors, fonts, gcontexts, and colormaps are known as resources. They all have unique identifiers associated with them for naming purposes. The lifetime of a resource is bounded by the lifetime of the connection over which the resource was created. See resource. @item shell A composite that handles the duties required by standard conventions for top-level X windows. @item sibling Children of the same parent window are known as @emph{sibling} windows. @item static color A degenerate case of pseudo color in which the RGB values are predefined and read-only. @item static gray A degenerate case of gray scale in which the gray values are predefined and read-only. The values are typically (near-)linear increasing ramps. @item stacking order Sibling windows can @emph{stack} on top of each other. Windows above both obscure and occlude lower windows. This is similar to paper on a desk. The relationship between sibling windows is known as the @emph{stacking order}. @item state A slot of @var{contact} that controls the visual effect of the contact. @item stipple A bitmap that is used to tile a region to serve as an additional clip mask for a fill operation with the foreground color. @item tile A pixmap can be replicated in two dimensions to @emph{tile} a region. The pixmap itself is also known as a tile. @item timer A CLUE object that provides support for animation and other types of time-sensitive user interfaces. A timer causes @var{:timer} events to be dispatched to a specific contact for processing. @item timestamp A time value, expressed in milliseconds, typically since the last server reset. Timestamp values wrap around (after about 49.7 days). The server, given its current time is represented by timestamp T, always interprets timestamps from clients by treating half of the timestamp space as being earlier in time than T and half of the timestamp space as being later in time than T. One timestamp value (named CurrentTime) is never generated by the server; this value is reserved for use in requests to represent the current server time. @item top-level contact A contact whose parent is a root. A top-level contact is usually a composite at the top of a hierarchy of other contacts created by an application program. @item top-level-session A subclass of @var{shell} that is used to communicate with a session manager. @item top-level-shell A subclass of @var{shell} that provides full window manager interaction. @item transient-shell A subclass of @var{shell} that a window manager typically will unmap when its owner becomes unmapped or iconified and will not allow to be individually iconified. @item true color A degenerate case of direct color in which the subfields in the pixel value directly encode the corresponding RGB values. That is, the colormap has predefined read-only RGB values. The values are typically (near-)linear increasing ramps. @item type An arbitrary atom used to identify the interpretation of property data. Types are completely uninterpreted by the server; they are solely for the benefit of clients. @item unmanaged A contact that is not under geometry management control. @item user interface A set of abstract interface objects used to control the dialog between an application and its human user. @item viewable A window is @emph{viewable} if it and all of its ancestors are mapped. This does not imply that any portion of the window is actually visible. Graphics requests can be performed on a window when it is not viewable, but output will not be retained unless the server is maintaining backing store. @item visible A region of a window is @emph{visible} if someone looking at the screen can actually see it; that is, the window is viewable and the region is not occluded by any other window. @item window gravity When windows are resized, subwindows can be repositioned automatically relative to some position in the window. This attraction of a subwindow to some part of its parent is known as @emph{window gravity}. @item window manager Manipulation of windows on the screen, and much of the user interface (policy) is typically provided by a @emph{window manager} client. @item window manager shell A subclass of @var{shell} called @var{wm-shell} that interacts with the window manager. @item XY Format The data for a pixmap is said to be in @emph{XY Format} if it is organized as a set of bitmaps representing individual bit planes, with the planes appearing from most to least significant in bit order. @item Z Format The data for a pixmap is said to be in @emph{Z Format} if it is organized as a set of pixel values in scanline order. @end table @node Function Index, Type Index, Glossary, Top @appendix Function Index @printindex fn @node Type Index, , Function Index, Top @appendix Type Index @printindex tp @bye cl-clx-sbcl-0.7.4.20160323.orig/debug/0000755000175000017500000000000012715665272014710 5ustar pdmpdmcl-clx-sbcl-0.7.4.20160323.orig/debug/trace.lisp0000644000175000017500000003757712715665272016722 0ustar pdmpdm;;; -*- 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 cl-clx-sbcl-0.7.4.20160323.orig/debug/event-test.lisp0000644000175000017500000001577612715665272017717 0ustar pdmpdm;;; -*- 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))) )) cl-clx-sbcl-0.7.4.20160323.orig/debug/describe.lisp0000644000175000017500000006101112715665272017360 0ustar pdmpdm;;; -*- Mode: Lisp; Package: XLIB; Syntax: COMMON-LISP; Base: 10; Lowercase: Yes; -*- ;;; Describe X11 protocol requests ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; ;;; Created 07/15/87 by LaMott G. OREN (in-package :xlib) (defparameter *request-parameters* (make-array (length *request-names*))) (defmacro x-request (name &rest fields) (unless (zerop (mod (length fields) 3)) (format t "~%Field length not a multiple of 3 for ~a" name)) (let ((request (position name *request-names* :test #'string-equal))) (if request `(setf (aref *request-parameters* ,request) ',fields) `(format t "~%~s isn't an X11 request name" ',name)))) (defun print-history-description (buffer &optional (start 0)) ;; Display an output history (reading-event (buffer) (let ((request (card8-get start)) (length (* 4 (card16-get (+ start 2)))) (margin 5)) (format t "~a (~d) length ~d" (request-name request) request length) (when (>= request (length *request-parameters*)) (setq request 0)) (do ((parms (aref *request-parameters* request) (cdddr parms)) (j start)) ((or (endp parms) (>= j length))) (let ((len (first parms)) (type (second parms)) (doc (third parms)) value) (setq value (case len (1 (card8-get j)) (2 (card16-get j)) (4 (card32-get j)))) (format t "~%~v@t" margin) (if value (progn (print-value j value type doc) (incf j len)) (progn (format t "~2d ~10a ~a" j type doc) (case type ((listofvalue listofcard32 listofatom) (format t " Words:~%~v@t" margin) (dotimes (k (floor (- length (- j start)) 4)) (format t " ~d" (card32-get j)) (incf j 4))) (listofrectangle (format t " Half-Words:~%~v@t" margin) (dotimes (k (floor (- length (- j start)) 2)) (format t " ~d" (card16-get j)) (incf j 2))) (x (when (integerp len) (incf j len))) ; Unused (string8 (format t " Bytes:~%~v@t" margin) (dotimes (k (- length (- j start))) (format t "~a" (int-char (card8-get j))) (incf j))) (otherwise (format t " Bytes:~%~v@t" margin) (dotimes (k (- length (- j start))) (format t " ~d" (card8-get j)) (incf j))))))))))) (defun print-value (i value type doc &aux temp) (format t "~2d ~3d " i value) (if (consp type) (case (first type) (bitmask (format t "~a" (nreverse (decode-mask (symbol-value (second type)) value))) (setq type (car type))) (member (if (null (setq temp (nth value (cdr type)))) (format t "*****ERROR*****") (format t "~a" temp)) (setq type (car type)))) (case type ((window pixmap drawable cursor font gcontext colormap atom) (format t "[#x~x]" value) #+comment (let ((temp (lookup-resource-id display value))) (when (eq (first type) 'atom) (setq temp (lookup-xatom display value))) (when temp (format t " (~s)" (type-of temp))))) (int16 (setq temp (card16->int16 value)) (when (minusp temp) (format t "~d" temp))) (otherwise (when (and (numberp type) (not (= type value))) (format t "*****ERROR*****"))))) (format t "~30,10t ~10a ~a" type doc)) (x-request Error 1 1 opcode 1 CARD8 data 2 8+n request-length n LISTofBYTE data ) (x-request CreateWindow 1 1 opcode 1 CARD8 depth 2 8+n request-length 4 WINDOW wid 4 WINDOW parent 2 INT16 x 2 INT16 y 2 CARD16 width 2 CARD16 height 2 CARD16 border-width 2 (MEMBER CopyFromParent InputOutput InputOnly) class 4 (OR (MEMBER CopyFromParent) VISUALID) visual 4 (BITMASK *create-bitmask*) value-mask 4n LISTofVALUE value-list ) (defparameter *create-bitmask* #(background-pixmap background-pixel border-pixmap border-pixel bit-gravity win-gravity backing-store backing-planes backing-pixel override-redirect save-under event-mask do-not-propagate-mask colormap cursor)) (x-request ChangeWindowAttributes 1 2 opcode 1 x unused 2 3+n request-length 4 WINDOW window 4 (BITMASK *create-bitmask*) value-mask 4n LISTofVALUE value-list ) (x-request GetWindowAttributes 1 3 opcode 1 x unused 2 2 request-length 4 WINDOW window ) (x-request DestroyWindow 1 4 opcode 1 x unused 2 2 request-length 4 WINDOW window ) (x-request DestroySubwindows 1 5 opcode 1 x unused 2 2 request-length 4 WINDOW window ) (x-request ChangeSaveSet 1 6 opcode 1 (MEMBER insert delete) mode 2 2 request-length 4 WINDOW window ) (x-request ReparentWindow 1 7 opcode 1 x unused 2 4 request-length 4 WINDOW window 4 WINDOW parent 2 INT16 x 2 INT16 y ) (x-request MapWindow 1 8 opcode 1 x unused 2 2 request-length 4 WINDOW window ) (x-request MapSubwindows 1 9 opcode 1 x unused 2 2 request-length 4 WINDOW window ) (x-request UnmapWindow 1 10 opcode 1 x unused 2 2 request-length 4 WINDOW window ) (x-request UnmapSubwindows 1 11 opcode 1 x unused 2 2 request-length 4 WINDOW window ) (x-request ConfigureWindow 1 12 opcode 1 x unused 2 3+n request-length 4 WINDOW window 2 BITMASK value-mask 2 x unused 4n LISTofVALUE value-list ) (x-request CirculateWindow 1 13 opcode 1 (MEMBER RaiseLowest LowerHighest) direction 2 2 request-length 4 WINDOW window ) (x-request GetGeometry 1 14 opcode 1 x unused 2 2 request-length 4 DRAWABLE drawable ) (x-request QueryTree 1 15 opcode 1 x unused 2 2 request-length 4 WINDOW window ) (x-request InternAtom 1 16 opcode 1 BOOL only-if-exists 2 |2+(n+p)/4| request-length 2 n length-of-name 2 x unused n STRING8 name p x unused ) (x-request GetAtomName 1 17 opcode 1 x unused 2 2 request-length 4 ATOM atom ) (x-request ChangeProperty 1 18 opcode 1 (MEMBER replace prepend append) mode 2 |6+(n+p)/4| request-length 4 WINDOW window 4 ATOM property 4 ATOM type 1 CARD8 format 3 x unused 4 CARD32 length-of-data-in-format-units n LISTofBYTE data p x unused ) (x-request DeleteProperty 1 19 opcode 1 x unused 2 3 request-length 4 WINDOW window 4 ATOM property ) (x-request GetProperty 1 20 opcode 1 BOOL delete 2 6 request-length 4 WINDOW window 4 ATOM property 4 (OR (MEMBER anypropertytype) ATOM) type 4 CARD32 long-offset 4 CARD32 long-length ) (x-request ListProperties 1 21 opcode 1 x unused 2 2 request-length 4 WINDOW window ) (x-request SetSelectionOwner 1 22 opcode 1 x unused 2 4 request-length 4 (OR (MEMBER none) WINDOW) owner 4 ATOM selection 4 (OR (MEMBER currenttime) TIMESTAMP) time ) (x-request GetSelectionOwner 1 23 opcode 1 x unused 2 2 request-length 4 ATOM selection ) (x-request ConvertSelection 1 24 opcode 1 x unused 2 6 request-length 4 WINDOW requestor 4 ATOM selection 4 ATOM target 4 (OR (MEMBER none) ATOM) property 4 (OR (MEMBER currenttime) TIMESTAMP) time ) (x-request SendEvent 1 25 opcode 1 BOOL propagate 2 11 request-length 4 (OR (MEMBER pointerwindow inputfocus) WINDOW) destination 4 SETofEVENT event-mask 32 n event ) (x-request GrabPointer 1 26 opcode 1 BOOL owner-events 2 6 request-length 4 WINDOW grab-window 2 SETofPOINTEREVENT event-mask 1 (MEMBER Synchronous Asynchronous) pointer-mode 1 (MEMBER Synchronous Asynchronous) keyboard-mode 4 (OR (MEMBER none) WINDOW) confine-to 4 (OR (MEMBER none) CURSOR) cursor 4 (OR (MEMBER currenttime) TIMESTAMP) timestamp ) (x-request UngrabPointer 1 27 opcode 1 x unused 2 2 request-length 4 (OR (MEMBER currenttime) TIMESTAMP) time ) (x-request GrabButton 1 28 opcode 1 BOOL owner-events 2 6 request-length 4 WINDOW grab-window 2 SETofPOINTEREVENT event-mask 1 (MEMBER Synchronous Asynchronous) pointer-mode 1 (MEMBER Synchronous Asynchronous) keyboard-mode 4 (OR (MEMBER none) WINDOW) confine-to 4 (OR (MEMBER none) CURSOR) cursor 1 (OR (MEMBER anybutton) BUTTON)button 1 x unused 2 SETofKEYMASK modifiers ) (x-request UngrabButton 1 29 opcode 1 (OR (MEMBER anybutton) BUTTON) button 2 3 request-length 4 WINDOW grab-window 2 SETofKEYMASK modifiers 2 x unused ) (x-request ChangeActivePointerGrab 1 30 opcode 1 x unused 2 4 request-length 4 (OR (MEMBER none) CURSOR) cursor 4 (OR (MEMBER currenttime) TIMESTAMP) time 2 SETofPOINTEREVENT event-mask 2 x unused ) (x-request GrabKeyboard 1 31 opcode 1 BOOL owner-events 2 4 request-length 4 WINDOW grab-window 4 (OR (MEMBER currenttime) TIMESTAMP) time 1 (MEMBER Synchronous Asynchronous) pointer-mode 1 (MEMBER Synchronous Asynchronous) keyboard-mode 2 x unused ) (x-request UngrabKeyboard 1 32 opcode 1 x unused 2 2 request-length 4 (OR (MEMBER currenttime) TIMESTAMP) time ) (x-request GrabKey 1 33 opcode 1 BOOL owner-events 2 4 request-length 4 WINDOW grab-window 2 SETofKEYMASK modifiers 1 (OR (MEMBER anykey) KEYCODE) key 1 (MEMBER Synchronous Asynchronous) pointer-mode 1 (MEMBER Synchronous Asynchronous) keyboard-mode 3 x unused ) (x-request UngrabKey 1 34 opcode 1 (OR (MEMBER anykey) KEYCODE) key 2 3 request-length 4 WINDOW grab-window 2 SETofKEYMASK modifiers 2 x unused ) (x-request AllowEvents 1 35 opcode 1 (MEMBER AsyncPointer SyncPointer ReplayPointer AsyncKeyboard SyncKeyboard ReplayKeyboard) mode 2 2 request-length 4 (OR (MEMBER currenttime) TIMESTAMP) time ) (x-request GrabServer 1 36 opcode 1 x unused 2 1 request-length ) (x-request UngrabServer 1 37 opcode 1 x unused 2 1 request-length ) (x-request QueryPointer 1 38 opcode 1 x unused 2 2 request-length 4 WINDOW window ) (x-request GetMotionEvents 1 39 opcode 1 x unused 2 4 request-length 4 WINDOW window 4 (OR (MEMBER CURRENTTIME) TIMESTAMP) start 4 (OR (MEMBER CURRENTTIME) TIMESTAMP) stop ) (x-request TranslateCoords 1 40 opcode 1 x unused 2 4 request-length 4 WINDOW src-window 4 WINDOW dst-window 2 INT16 src-x 2 INT16 src-y ) (x-request WarpPointer 1 41 opcode 1 x unused 2 6 request-length 4 (OR (MEMBER none) WINDOW) src-window 4 WINDOW dst-window 2 INT16 src-x 2 INT16 src-y 2 CARD16 src-width 2 CARD16 src-height 2 INT16 dst-x 2 INT16 dst-y ) (x-request SetInputFocus 1 42 opcode 1 (MEMBER none pointerroot parent) revert-to 2 3 request-length 4 (OR (MEMBER none pointerroot) WINDOW) focus 4 (OR (MEMBER CURRENTTIME) TIMESTAMP) time ) (x-request GetInputFocus 1 43 opcode 1 x unused 2 1 request-length ) (x-request QueryKeymap 1 44 opcode 1 x unused 2 1 request-length ) (x-request OpenFont 1 45 opcode 1 x unused 2 |3+(n+p)/4| request-length 4 FONT fid 2 n length-of-name 2 x unused n STRING8 name p x unused ) (x-request CloseFont 1 46 opcode 1 x unused 2 2 request-length 4 FONT font ) (x-request QueryFont 1 47 opcode 1 x unused 2 2 request-length 4 FONTABLE font ) (x-request QueryTextExtents 1 48 opcode 1 BOOL odd-length-p 2 |2+(2n+p)/4| request-length 4 FONTABLE font 2n STRING16 string p x unused ) (x-request ListFonts 1 49 opcode 1 x unused 2 |2+(n+p)/4| request-length 2 CARD16 max-names 2 n length-of-pattern n STRING8 pattern p x unused ) (x-request ListFontsWithInfo 1 50 opcode 1 x unused 2 |2+(n+p)/4| request-length 2 CARD16 max-names 2 n length-of-pattern n STRING8 pattern p x unused ) (x-request SetFontPath 1 51 opcode 1 x unused 2 |2+(n+p)/4| request-length 2 CARD16 number-of-STRs-in-path 2 x unused n LISTofSTR path p x unused ) (x-request GetFontPath 1 52 opcode 1 x unused 2 1 request-list ) (x-request CreatePixmap 1 53 opcode 1 CARD8 depth 2 4 request-length 4 PIXMAP pid 4 DRAWABLE drawable 2 CARD16 width 2 CARD16 height ) (x-request FreePixmap 1 54 opcode 1 x unused 2 2 request-length 4 PIXMAP pixmap ) (x-request CreateGC 1 55 opcode 1 x unused 2 4+n request-length 4 GCONTEXT cid 4 DRAWABLE drawable 4 (BITMASK *gc-bitmask*) value-mask 4n LISTofVALUE value-list ) (defconstant *gc-bitmask* #(function plane-mask foreground background line-width line-style cap-style join-style fill-style fill-rule tile stipple tile-stipple-x-origin tile-stipple-y-origin font subwindow-mode graphics-exposures clip-x-origin clip-y-origin clip-mask dash-offset dashes arc-mode)) (x-request ChangeGC 1 56 opcode 1 x unused 2 3+n request-length 4 GCONTEXT gc 4 (BITMASK *gc-bitmask*) value-mask 4n LISTofVALUE value-list ) (x-request CopyGC 1 57 opcode 1 x unused 2 4 request-length 4 GCONTEXT src-gc 4 GCONTEXT dst-gc 4 (BITMASK *gc-bitmask*) value-mask ) (x-request SetDashes 1 58 opcode 1 x unused 2 |3+(n+p)/4| request-length 4 GCONTEXT gc 2 CARD16 dash-offset 2 n length-of-dashes n LISTofCARD8 dashes p x unused ) (x-request SetClipRectangles 1 59 opcode 1 (MEMBER UnSorted YSorted YXSorted YXBanded) ordering 2 3+2n request-length 4 GCONTEXT gc 2 INT16 clip-x-origin 2 INT16 clip-y-origin 8n LISTofRECTANGLE rectangles ) (x-request FreeGC 1 60 opcode 1 x unused 2 2 request-length 4 GCONTEXT gc ) (x-request ClearToBackground 1 61 opcode 1 BOOL exposures 2 4 request-length 4 WINDOW window 2 INT16 x 2 INT16 y 2 CARD16 width 2 CARD16 height ) (x-request CopyArea 1 62 opcode 1 x unused 2 7 request-length 4 DRAWABLE src-drawable 4 DRAWABLE dst-drawable 4 GCONTEXT gc 2 INT16 src-x 2 INT16 src-y 2 INT16 dst-x 2 INT16 dst-y 2 CARD16 width 2 CARD16 height ) (x-request CopyPlane 1 63 opcode 1 x unused 2 8 request-length 4 DRAWABLE src-drawable 4 DRAWABLE dst-drawable 4 GCONTEXT gc 2 INT16 src-x 2 INT16 src-y 2 INT16 dst-x 2 INT16 dst-y 2 CARD16 width 2 CARD16 height 4 CARD32 bit-plane ) (x-request PolyPoint 1 64 opcode 1 (MEMBER origin previous) coordinate-mode 2 3+n request-length 4 DRAWABLE drawable 4 GCONTEXT gc 4n LISTofPOINT points ) (x-request PolyLine 1 65 opcode 1 (MEMBER origin previous) coordinate-mode 2 3+n request-length 4 DRAWABLE drawable 4 GCONTEXT gc 4n LISTofPOINT points ) (x-request PolySegment 1 66 opcode 1 x unused 2 3+2n request-length 4 DRAWABLE drawable 4 GCONTEXT gc 8n LISTofSEGMENT segments ) (x-request PolyRectangle 1 67 opcode 1 x unused 2 3+2n request-length 4 DRAWABLE drawable 4 GCONTEXT gc 8n LISTofRECTANGLE rectangles ) (x-request PolyArc 1 68 opcode 1 x unused 2 3+3n request-length 4 DRAWABLE drawable 4 GCONTEXT gc 12n LISTofARC arcs ) (x-request FillPoly 1 69 opcode 1 x unused 2 4+n request-length 4 DRAWABLE drawable 4 GCONTEXT gc 1 (MEMBER complex nonconvex convex) shape 1 (MEMBER origin previous) coordinate-mode 2 x unused 4n LISTofPOINT points ) (x-request PolyFillRectangle 1 70 opcode 1 x unused 2 3+2n request-length 4 DRAWABLE drawable 4 GCONTEXT gc 8n LISTofRECTANGLE rectangles ) (x-request PolyFillArc 1 71 opcode 1 x unused 2 3+3n request-length 4 DRAWABLE drawable 4 GCONTEXT gc 12n LISTofARC arcs ) (x-request PutImage 1 72 opcode 1 (bitmap xypixmap zpixmap) format 2 |6+(n+p)/4| request-length 4 DRAWABLE drawable 4 GCONTEXT gc 2 CARD16 width 2 CARD16 height 2 INT16 dst-x 2 INT16 dst-y 1 CARD8 left-pad 1 CARD8 depth 2 x unused n LISTofBYTE data p x unused ) (x-request GetImage 1 73 opcode 1 (MEMBER error xypixmap zpixmap) format 2 5 request-length 4 DRAWABLE drawable 2 INT16 x 2 INT16 y 2 CARD16 width 2 CARD16 height 4 CARD32 plane-mask ) (x-request PolyText8 1 74 opcode 1 x unused 2 |4+(n+p)/4| request-length 4 DRAWABLE drawable 4 GCONTEXT gc 2 INT16 x 2 INT16 y n LISTofTEXTITEM8 items p x unused ) (x-request PolyText16 1 75 opcode 1 x unused 2 |4+(n+p)/4| request-length 4 DRAWABLE drawable 4 GCONTEXT gc 2 INT16 x 2 INT16 y n LISTofTEXTITEM16 items p x unused ) (x-request ImageText8 1 76 opcode 1 n length-of-string 2 |4+(n+p)/4| request-length 4 DRAWABLE drawable 4 GCONTEXT gc 2 INT16 x 2 INT16 y n STRING8 string p x unused ) (x-request ImageText16 1 77 opcode 1 n number-of-CHAR2Bs-in-string 2 |4+(2n+p)/4| request-length 4 DRAWABLE drawable 4 GCONTEXT gc 2 INT16 x 2 INT16 y 2n STRING16 string p x unused ) (x-request CreateColormap 1 78 opcode 1 (MEMBER none all) alloc 2 4 request-length 4 COLORMAP mid 4 WINDOW window 4 VISUALID visual ) (x-request FreeColormap 1 79 opcode 1 x unused 2 2 request-length 4 COLORMAP cmap ) (x-request CopyColormapAndFree 1 80 opcode 1 x unused 2 3 request-length 4 COLORMAP mid 4 COLORMAP src-cmap ) (x-request InstallColormap 1 81 opcode 1 x unused 2 2 request-length 4 COLORMAP cmap ) (x-request UninstallColormap 1 82 opcode 1 x unused 2 2 request-length 4 COLORMAP cmap ) (x-request ListInstalledColormaps 1 83 opcode 1 x unused 2 2 request-length 4 WINDOW window ) (x-request AllocColor 1 84 opcode 1 x unused 2 4 request-length 4 COLORMAP cmap 2 CARD16 red 2 CARD16 green 2 CARD16 blue 2 x unused ) (x-request AllocNamedColor 1 85 opcode 1 x unused 2 |3+(n+p)/4| request-length 4 COLORMAP cmap 2 n length-of-name 2 x unused n STRING8 name p x unused ) (x-request AllocColorCells 1 86 opcode 1 BOOL contiguous 2 3 request-length 4 COLORMAP cmap 2 CARD16 colors 2 CARD16 planes ) (x-request AllocColorPlanes 1 87 opcode 1 BOOL contiguous 2 4 request-length 4 COLORMAP cmap 2 CARD16 colors 2 CARD16 reds 2 CARD16 greens 2 CARD16 blues ) (x-request FreeColors 1 88 opcode 1 x unused 2 3+n request-length 4 COLORMAP cmap 4 CARD32 plane-mask 4n LISTofCARD32 pixels ) (x-request StoreColors 1 89 opcode 1 x unused 2 2+3n request-length 4 COLORMAP cmap 12n LISTofCOLORITEM items ) (x-request StoreNamedColor 1 90 opcode 1 color-mask do-red_do-green_do-blue 2 |4+(n+p)/4| request-length 4 COLORMAP cmap 4 CARD32 pixel 2 n length-of-name 2 x unused n STRING8 name p x unused ) (x-request QueryColors 1 91 opcode 1 x unused 2 2+n request-length 4 COLORMAP cmap 4n LISTofCARD32 pixels ) (x-request LookupColor 1 92 opcode 1 x unused 2 |3+(n+p)/4| request-length 4 COLORMAP cmap 2 n length-of-name 2 x unused n STRING8 name p x unused ) (x-request CreateCursor 1 93 opcode 1 x unused 2 8 request-length 4 CURSOR cid 4 PIXMAP source 4 (OR (MEMBER none) PIXMAP) mask 2 CARD16 fore-red 2 CARD16 fore-green 2 CARD16 fore-blue 2 CARD16 back-red 2 CARD16 back-green 2 CARD16 back-blue 2 CARD16 x 2 CARD16 y ) (x-request CreateGlyphCursor 1 94 CreateGlyphCursor 1 x unused 2 8 request-length 4 CURSOR cid 4 FONT source-font 4 (OR (MEMBER none) FONT) mask-font 2 CARD16 source-char 2 CARD16 mask-char 2 CARD16 fore-red 2 CARD16 fore-green 2 CARD16 fore-blue 2 CARD16 back-red 2 CARD16 back-green 2 CARD16 back-blue ) (x-request FreeCursor 1 95 opcode 1 x unused 2 2 request-length 4 CURSOR cursor ) (x-request RecolorCursor 1 96 opcode 1 x unused 2 5 request-length 4 CURSOR cursor 2 CARD16 fore-red 2 CARD16 fore-green 2 CARD16 fore-blue 2 CARD16 back-red 2 CARD16 back-green 2 CARD16 back-blue ) (x-request QueryBestSize 1 97 opcode 1 (MEMBER cursor tile stipple) class 2 3 request-length 4 DRAWABLE drawable 2 CARD16 width 2 CARD16 height ) (x-request QueryExtension 1 98 opcode 1 x unused 2 |2+(n+p)/4| request-length 2 n length-of-name 2 x unused n STRING8 name p x unused ) (x-request ListExtensions 1 99 opcode 1 x unused 2 1 request-length ) (x-request SetKeyboardMapping 1 100 opcode 1 n keycode-count 2 2+nm request-length 1 KEYCODE first-keycode 1 m keysyms-per-keycode 2 x unused 4nm LISTofKEYSYM keysyms ) (x-request GetKeyboardMapping 1 101 opcode 1 x unused 2 2 request-length 1 KEYCODE first-keycode 1 CARD8 count 2 x unused ) (x-request ChangeKeyboardControl 1 102 opcode 1 x unused 2 2+n request-length 4 BITMASK value-mask 4n LISTofVALUE value-list ) (x-request GetKeyboardControl 1 103 opcode 1 x unused 2 1 request-length ) (x-request Bell 1 104 opcode 1 INT8 percent 2 1 request-length ) (x-request ChangePointerControl 1 105 opcode 1 x unused 2 3 request-length 2 INT16 acceleration-numerator 2 INT16 acceleration-denominator 2 INT16 threshold 1 BOOL do-acceleration 1 BOOL do-threshold ) (x-request GetPointerControl 1 106 GetPointerControl 1 x unused 2 1 request-length ) (x-request SetScreenSaver 1 107 opcode 1 x unused 2 3 request-length 2 INT16 timeout 2 INT16 interval 1 (MEMBER no yes default) prefer-blanking 1 (MEMBER no yes default) allow-exposures 2 x unused ) (x-request GetScreenSaver 1 108 opcode 1 x unused 2 1 request-length ) (x-request ChangeHosts 1 109 opcode 1 (MEMBER insert delete) mode 2 |2+(n+p)/4| request-length 1 (MEMBER internet decnet chaos) family 1 x unused 2 CARD16 length-of-address n LISTofCARD8 address p x unused ) (x-request ListHosts 1 110 opcode 1 x unused 2 1 request-length ) (x-request ChangeAccessControl 1 111 opcode 1 (MEMBER disable enable) mode 2 1 request-length ) (x-request ChangeCloseDownMode 1 112 opcode 1 (MEMBER destroy retainpermanent retaintemporary) mode 2 1 request-length ) (x-request KillClient 1 113 opcode 1 x unused 2 2 request-length 4 (MEMBER alltemporary CARD32) resource ) (x-request RotateProperties 1 114 opcode 1 x unused 2 3+n request-length 4 WINDOW window 2 n number-of-properties 2 INT16 delta 4n LISTofATOM properties ) (x-request ForceScreenSaver 1 115 ForceScreenSaver 1 (MEMBER reset activate) mode 2 1 request-length ) (x-request SetPointerMapping 1 116 opcode 1 n length-of-map 2 |1+(n+p)/4| request-length n LISTofCARD8 map p x unused ) (x-request GetPointerMapping 1 117 opcode 1 x unused 2 1 request-length ) (x-request SetModifierMapping 1 118 opcode 1 KEYCODE Lock 2 5 request-length 1 KEYCODE Shift_A 1 KEYCODE Shift_B 1 KEYCODE Control_A 1 KEYCODE Control_B 1 KEYCODE Mod1_A 1 KEYCODE Mod1_B 1 KEYCODE Mod2_A 1 KEYCODE Mod2_B 1 KEYCODE Mod3_A 1 KEYCODE Mod3_B 1 KEYCODE Mod4_A 1 KEYCODE Mod4_B 1 KEYCODE Mod5_A 1 KEYCODE Mod5_B 2 x unused ) (x-request GetModifierMapping 1 119 opcode 1 x unused 2 1 request-length ) #+comment (x-request NoOperation 1 127 opcode 1 x unused 2 1 request-length ) ;; End of file cl-clx-sbcl-0.7.4.20160323.orig/debug/debug.lisp0000644000175000017500000000416112715665272016671 0ustar pdmpdm;;; -*- 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 cl-clx-sbcl-0.7.4.20160323.orig/debug/util.lisp0000644000175000017500000001205012715665272016554 0ustar pdmpdm;;; -*- 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)) cl-clx-sbcl-0.7.4.20160323.orig/debug/keytrans.lisp0000644000175000017500000002317012715665272017444 0ustar pdmpdm;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- ;;; CLX keysym-translation test programs ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (in-package :xlib) (defun list-missing-keysyms () ;; Lists explorer characters which have no keysyms (dotimes (i 256) (unless (character->keysyms (int-char i)) (format t "~%(define-keysym ~@c ~d)" (int-char i) i)))) (defun list-multiple-keysyms () ;; Lists characters with more than one keysym (dotimes (i 256) (when (cdr (character->keysyms (int-char i))) (format t "~%Character ~@c [~d] has keysyms" (int-char i) i) (dolist (keysym (character->keysyms (int-char i))) (format t " ~d ~d" (ldb (byte 8 8) keysym) (ldb (byte 8 0) keysym)))))) (defun check-lowercase-keysyms () ;; Checks for keysyms with incorrect :lowercase parameters (maphash #'(lambda (key mapping) (let* ((value (car mapping)) (char (keysym-mapping-object value))) (if (and (characterp char) (both-case-p char) (= (char-int char) (char-int (char-upcase char)))) ;; uppercase alphabetic character (unless (eq (keysym-mapping-lowercase value) (char-int (char-downcase char))) (let ((lowercase (keysym-mapping-lowercase value)) (should-be (char-downcase char))) (format t "~%Error keysym ~3d ~3d (~@c) has :Lowercase ~3d ~3d (~s) Should be ~3d ~3d (~@c)" (ldb (byte 8 8) key) (ldb (byte 8 0) key) char (and lowercase (ldb (byte 8 8) lowercase)) (and lowercase (ldb (byte 8 0) lowercase)) (int-char lowercase) (ldb (byte 8 8) (char-int should-be)) (ldb (byte 8 0) (char-int should-be)) should-be))) (when (keysym-mapping-lowercase value) (let ((lowercase (keysym-mapping-lowercase value))) (format t "~%Error keysym ~3d ~3d (~@c) has :lowercase ~3d ~3d (~@c) and shouldn't" (ldb (byte 8 8) key) (ldb (byte 8 0) key) char (and lowercase (ldb (byte 8 8) (char-int lowercase))) (and lowercase (ldb (byte 8 0) (char-int lowercase))) lowercase )))))) *keysym->character-map*)) (defun print-all-keysyms () (let ((all nil)) (maphash #'(lambda (key value) (push (cons key value) all)) *keysym->character-map*) (setq all (sort all #'< :key #'car)) (format t "~%~d keysyms:" (length all)) (dolist (keysym all) (format t "~%~3d ~3d~{ ~s~}" (ldb (byte 8 8) (car keysym)) (ldb (byte 8 0) (car keysym)) (cadr keysym)) (dolist (mapping (cddr keysym)) (format t "~%~7@t~{ ~s~}" mapping))))) (defun keysym-mappings (keysym &key display (mask-format #'identity)) ;; Return all the keysym mappings for keysym. ;; Returns a list of argument lists that are argument-lists to define-keysym. ;; The following will re-create the mappings for KEYSYM: ;; (dolist (mapping (keysym-mappings) keysym) ;; (apply #'define-keysym mapping)) (let ((mappings (append (and display (cdr (assoc keysym (display-keysym-translation display)))) (gethash keysym *keysym->character-map*))) (result nil)) (dolist (mapping mappings) (let ((object (keysym-mapping-object mapping)) (translate (keysym-mapping-translate mapping)) (lowercase (keysym-mapping-lowercase mapping)) (modifiers (keysym-mapping-modifiers mapping)) (mask (keysym-mapping-mask mapping))) (push (append (list object keysym) (when translate (list :translate translate)) (when lowercase (list :lowercase lowercase)) (when modifiers (list :modifiers (funcall mask-format modifiers))) (when mask (list :mask (funcall mask-format mask)))) result))) (nreverse result))) #+comment (defun print-keysym-mappings (keysym &optional display) (format t "~%(keysym ~d ~3d) " (ldb (byte 8 8) keysym) (ldb (byte 8 0) keysym)) (dolist (mapping (keysym-mappings keysym :display display)) (format t "~16t~{ ~s~}~%" mapping))) (defun print-keysym-mappings (keysym &optional display) (flet ((format-mask (mask) (cond ((numberp mask) `(make-state-mask ,@(make-state-keys mask))) ((atom mask) mask) (t `(list ,@(mapcar #'(lambda (item) (if (numberp item) `(keysym ,(keysym-mapping-object (car (gethash item *keysym->character-map*)))) item)) mask)))))) (dolist (mapping (keysym-mappings keysym :display display :mask-format #'format-mask)) (format t "~%(define-keysym ~s (keysym ~d ~3d)~{ ~s~})" (car mapping) (ldb (byte 8 8) keysym) (ldb (byte 8 0) keysym) (cdr mapping))))) (defun keysym-test (host) ;; Server key-press Loop-back test (let* ((display (open-display host)) (width 400) (height 400) (screen (display-default-screen display)) (black (screen-black-pixel screen)) (white (screen-white-pixel screen)) (win (create-window :parent (screen-root screen) :background black :border white :border-width 1 :colormap (screen-default-colormap screen) :bit-gravity :center :event-mask '(:exposure :key-press) :x 20 :y 20 :width width :height height)) #+comment (gc (create-gcontext :drawable win :background black :foreground white))) (initialize-extensions display) (map-window win) ; Map the window ;; Handle events (unwind-protect (dotimes (state 64) (do ((code (display-min-keycode display) (1+ code))) ((> code (display-max-keycode display))) (send-event win :key-press '(:key-press) :code code :state state :window win :root (screen-root screen) :time 0 :x 1 :y 2 :root-x 10 :root-y 20 :same-screen-p t) (event-case (display :force-output-p t :discard-p t) (exposure ;; Come here on exposure events (window count) (when (zerop count) ;; Ignore all but the last exposure event (clear-area window)) nil) (key-press (display code state) (princ (keycode->character display code state)) t)))) (close-display display)))) (defun keysym-echo (host &optional keymap-p) ;; Echo characters typed to a window (let* ((display (open-display host)) (width 400) (height 400) (screen (display-default-screen display)) (black (screen-black-pixel screen)) (white (screen-white-pixel screen)) (win (create-window :parent (screen-root screen) :background black :border white :border-width 1 :colormap (screen-default-colormap screen) :bit-gravity :center :event-mask '(:exposure :key-press :keymap-state :enter-window) :x 20 :y 20 :width width :height height)) (gc (create-gcontext :drawable win :background black :foreground white))) (initialize-extensions display) (map-window win) ; Map the window ;; Handle events (unwind-protect (event-case (display :force-output-p t :discard-p t) (exposure ;; Come here on exposure events (window count) (when (zerop count) ;; Ignore all but the last exposure event (clear-area window) (draw-glyphs window gc 10 10 "Press to exit")) nil) (key-press (display code state) (let ((char (keycode->character display code state))) (format t "~%Code: ~s State: ~s Char: ~s" code state char) ;; (PRINC char) (PRINC " ") (when keymap-p (let ((keymap (query-keymap display))) (unless (character-in-map-p display char keymap) (print "character-in-map-p failed") (print-keymap keymap)))) ;; (when (eql char #\0) (setq disp display) (break)) (eql char #\escape))) (keymap-notify (keymap) (print "Keymap-notify") ;; we never get here. Server bug? (when (keysym-in-map-p display 65 keymap) (print "Found A")) (when (character-in-map-p display #\b keymap) (print "Found B"))) (enter-notify (event-window) (format t "~%Enter ~s" event-window))) (close-display display)))) (defun print-keymap (keymap) (do ((j 32 (+ j 32))) ;; first 32 bits is for window ((>= j 256)) (format t "~% ~3d: " j) (do ((i j (1+ i))) ((>= i (+ j 32))) (when (zerop (logand i 7)) (princ " ")) (princ (aref keymap i))))) (defun define-keysym-test (&key display printp (modifiers (list (keysym :left-meta))) (mask :modifiers)) (let* ((keysym 067) (args `(baz ,keysym :modifiers ,modifiers ,@(and mask `(:mask ,mask)))) (original (copy-tree (keysym-mappings keysym :display display)))) (when printp (print-keysym-mappings 67) (terpri)) (apply #'define-keysym args) (when printp (print-keysym-mappings 67) (terpri)) (let ((is (keysym-mappings keysym :display display)) (should-be (append original (list args)))) (unless (equal is should-be) (cerror "Ignore" "define-keysym error. ~%is: ~s ~%Should be: ~s" is should-be))) (apply #'undefine-keysym args) (when printp (print-keysym-mappings 67) (terpri)) (let ((is (keysym-mappings keysym :display display))) (unless (equal is original) (cerror "Ignore" "undefine-keysym error. ~%is: ~s ~%Should be: ~s" is original))))) (define-keysym-test) (define-keysym-test :modifiers (make-state-mask :shift :lock)) (define-keysym-test :modifiers (list :shift (keysym :left-meta) :control)) (define-keysym-test :modifiers (make-state-mask :shift :lock) :mask nil) cl-clx-sbcl-0.7.4.20160323.orig/manager.lisp0000644000175000017500000010124212715665272016125 0ustar pdmpdm;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- ;;; Window Manager Property functions ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (in-package :xlib) (defun wm-name (window) (declare (type window window)) (declare (clx-values string)) (get-property window :WM_NAME :type :STRING :result-type 'string :transform #'card8->char)) (defsetf wm-name (window) (name) `(set-string-property ,window :WM_NAME ,name)) (defun set-string-property (window property string) (declare (type window window) (type keyword property) (type stringable string)) (change-property window property (string string) :STRING 8 :transform #'char->card8) string) (defun wm-icon-name (window) (declare (type window window)) (declare (clx-values string)) (get-property window :WM_ICON_NAME :type :STRING :result-type 'string :transform #'card8->char)) (defsetf wm-icon-name (window) (name) `(set-string-property ,window :WM_ICON_NAME ,name)) (defun wm-client-machine (window) (declare (type window window)) (declare (clx-values string)) (get-property window :WM_CLIENT_MACHINE :type :STRING :result-type 'string :transform #'card8->char)) (defsetf wm-client-machine (window) (name) `(set-string-property ,window :WM_CLIENT_MACHINE ,name)) (defun get-wm-class (window) (declare (type window window)) (declare (clx-values (or null name-string) (or null class-string))) (let ((value (get-property window :WM_CLASS :type :STRING :result-type '(vector card8)))) (declare (type (or null (vector card8)) value)) (when value (let* ((name-len (position 0 (the (vector card8) value))) (name (subseq (the (vector card8) value) 0 name-len)) (class (when name-len (subseq (the (vector card8) value) (1+ name-len) (position 0 (the (vector card8) value) :start (1+ name-len)))))) (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 *) 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 ;; the next four fields are obsolete when using a modern window manager ;; (that will use min-width and friends instead), but they should be set by ;; clients in case an old window manager is used (x nil :type (or null int32)) (y nil :type (or null int32)) (width nil :type (or null card32)) (height nil :type (or null card32)) (min-width nil :type (or null card32)) (min-height nil :type (or null card32)) (max-width nil :type (or null card32)) (max-height nil :type (or null card32)) (width-inc nil :type (or null card32)) (height-inc nil :type (or null card32)) (min-aspect nil :type (or null number)) (max-aspect nil :type (or null number)) (base-width nil :type (or null card32)) (base-height nil :type (or null card32)) (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 int32) x y) (type (or null card32) 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 card32) icon-x icon-y) (type (or null resource-id) window-group) (dynamic-extent options)) (when name (setf (wm-name window) name)) (when icon-name (setf (wm-icon-name window) icon-name)) (when client-machine (setf (wm-client-machine window) client-machine)) (when (or resource-name resource-class) (set-wm-class window resource-name resource-class)) (when command (setf (wm-command window) command)) ;; WM-HINTS (if (dolist (arg '(:input :initial-state :icon-pixmap :icon-window :icon-x :icon-y :icon-mask :window-group)) (when (getf options arg) (return t))) (let ((wm-hints (if hints (copy-wm-hints hints) (make-wm-hints)))) (when input (setf (wm-hints-input wm-hints) input)) (when initial-state (setf (wm-hints-initial-state wm-hints) initial-state)) (when icon-pixmap (setf (wm-hints-icon-pixmap wm-hints) icon-pixmap)) (when icon-window (setf (wm-hints-icon-window wm-hints) icon-window)) (when icon-x (setf (wm-hints-icon-x wm-hints) icon-x)) (when icon-y (setf (wm-hints-icon-y wm-hints) icon-y)) (when icon-mask (setf (wm-hints-icon-mask wm-hints) icon-mask)) (when window-group (setf (wm-hints-window-group wm-hints) window-group)) (setf (wm-hints window) wm-hints)) (when hints (setf (wm-hints window) hints))) ;; WM-NORMAL-HINTS (if (dolist (arg '(:x :y :width :height :min-width :min-height :max-width :max-height :width-inc :height-inc :min-aspect :max-aspect :user-specified-position-p :user-specified-size-p :program-specified-position-p :program-specified-size-p :base-width :base-height :win-gravity)) (when (getf options arg) (return t))) (let ((size (if normal-hints (copy-wm-size-hints normal-hints) (make-wm-size-hints)))) (when x (setf (wm-size-hints-x size) x)) (when y (setf (wm-size-hints-y size) y)) (when width (setf (wm-size-hints-width size) width)) (when height (setf (wm-size-hints-height size) height)) (when min-width (setf (wm-size-hints-min-width size) min-width)) (when min-height (setf (wm-size-hints-min-height size) min-height)) (when max-width (setf (wm-size-hints-max-width size) max-width)) (when max-height (setf (wm-size-hints-max-height size) max-height)) (when width-inc (setf (wm-size-hints-width-inc size) width-inc)) (when height-inc (setf (wm-size-hints-height-inc size) height-inc)) (when min-aspect (setf (wm-size-hints-min-aspect size) min-aspect)) (when max-aspect (setf (wm-size-hints-max-aspect size) max-aspect)) (when base-width (setf (wm-size-hints-base-width size) base-width)) (when base-height (setf (wm-size-hints-base-height size) base-height)) (when win-gravity (setf (wm-size-hints-win-gravity size) win-gravity)) (when usppp (setf (wm-size-hints-user-specified-position-p size) user-specified-position-p)) (when usspp (setf (wm-size-hints-user-specified-size-p size) user-specified-size-p)) (when psppp (setf (wm-size-hints-program-specified-position-p size) program-specified-position-p)) (when psspp (setf (wm-size-hints-program-specified-size-p size) program-specified-size-p)) (setf (wm-normal-hints window) size)) (when normal-hints (setf (wm-normal-hints window) normal-hints))) (when zoom-hints (setf (wm-zoom-hints window) zoom-hints)) ) ;;; OBSOLETE (defun set-standard-properties (window &rest options) (declare (dynamic-extent options)) (apply #'set-wm-properties window options)) ;;----------------------------------------------------------------------------- ;; WM Control (defun iconify-window (window screen) (declare (type window window) (type screen screen)) (let ((root (screen-root screen))) (declare (type window root)) (send-event root :client-message '(:substructure-redirect :substructure-notify) :window window :format 32 :type :WM_CHANGE_STATE :data (list 3)))) (defun withdraw-window (window screen) (declare (type window window) (type screen screen)) (unmap-window window) (let ((root (screen-root screen))) (declare (type window root)) (send-event root :unmap-notify '(:substructure-redirect :substructure-notify) :window window :event-window root :configure-p nil))) ;;----------------------------------------------------------------------------- ;; Colormaps (def-clx-class (standard-colormap (:copier nil) (:predicate nil)) (colormap nil :type (or null colormap)) (base-pixel 0 :type pixel) (max-color nil :type (or null color)) (mult-color nil :type (or null color)) (visual nil :type (or null visual-info)) (kill nil :type (or (member nil :release-by-freeing-colormap) drawable gcontext cursor colormap font))) (defun rgb-colormaps (window property) (declare (type window window) (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP :RGB_GREEN_MAP :RGB_BLUE_MAP) property)) (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector))) (declare (type (or null simple-vector) prop)) (when prop (list (make-standard-colormap :colormap (lookup-colormap (window-display window) (aref prop 0)) :base-pixel (aref prop 7) :max-color (make-color :red (card16->rgb-val (aref prop 1)) :green (card16->rgb-val (aref prop 3)) :blue (card16->rgb-val (aref prop 5))) :mult-color (make-color :red (card16->rgb-val (aref prop 2)) :green (card16->rgb-val (aref prop 4)) :blue (card16->rgb-val (aref prop 6))) :visual (and (<= 9 (length prop)) (visual-info (window-display window) (aref prop 8))) :kill (and (<= 10 (length prop)) (let ((killid (aref prop 9))) (if (= killid 1) :release-by-freeing-colormap (lookup-resource-id (window-display window) killid))))))))) (defsetf rgb-colormaps set-rgb-colormaps) (defun set-rgb-colormaps (window property maps) (declare (type window window) (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP :RGB_GREEN_MAP :RGB_BLUE_MAP) property) (type list maps)) (let ((prop (make-array (* 10 (length maps)) :element-type 'card32)) (index -1)) (dolist (map maps) (setf (aref prop (incf index)) (encode-type colormap (standard-colormap-colormap map))) (setf (aref prop (incf index)) (encode-type rgb-val (color-red (standard-colormap-max-color map)))) (setf (aref prop (incf index)) (encode-type rgb-val (color-red (standard-colormap-mult-color map)))) (setf (aref prop (incf index)) (encode-type rgb-val (color-green (standard-colormap-max-color map)))) (setf (aref prop (incf index)) (encode-type rgb-val (color-green (standard-colormap-mult-color map)))) (setf (aref prop (incf index)) (encode-type rgb-val (color-blue (standard-colormap-max-color map)))) (setf (aref prop (incf index)) (encode-type rgb-val (color-blue (standard-colormap-mult-color map)))) (setf (aref prop (incf index)) (standard-colormap-base-pixel map)) (setf (aref prop (incf index)) (visual-info-id (standard-colormap-visual map))) (setf (aref prop (incf index)) (let ((kill (standard-colormap-kill map))) (etypecase kill (symbol (ecase kill ((nil) 0) ((:release-by-freeing-colormap) 1))) (drawable (drawable-id kill)) (gcontext (gcontext-id kill)) (cursor (cursor-id kill)) (colormap (colormap-id kill)) (font (font-id kill)))))) (change-property window property prop :RGB_COLOR_MAP 32))) ;;; OBSOLETE (defun get-standard-colormap (window property) (declare (type window window) (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP :RGB_GREEN_MAP :RGB_BLUE_MAP) property)) (declare (clx-values colormap base-pixel max-color mult-color)) (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector))) (declare (type (or null simple-vector) prop)) (when prop (values (lookup-colormap (window-display window) (aref prop 0)) (aref prop 7) ;Base Pixel (make-color :red (card16->rgb-val (aref prop 1)) ;Max Color :green (card16->rgb-val (aref prop 3)) :blue (card16->rgb-val (aref prop 5))) (make-color :red (card16->rgb-val (aref prop 2)) ;Mult color :green (card16->rgb-val (aref prop 4)) :blue (card16->rgb-val (aref prop 6))))))) ;;; OBSOLETE (defun set-standard-colormap (window property colormap base-pixel max-color mult-color) (declare (type window window) (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP :RGB_GREEN_MAP :RGB_BLUE_MAP) property) (type colormap colormap) (type pixel base-pixel) (type color max-color mult-color)) (let ((prop (vector (encode-type colormap colormap) (encode-type rgb-val (color-red max-color)) (encode-type rgb-val (color-red mult-color)) (encode-type rgb-val (color-green max-color)) (encode-type rgb-val (color-green mult-color)) (encode-type rgb-val (color-blue max-color)) (encode-type rgb-val (color-blue mult-color)) base-pixel))) (change-property window property prop :RGB_COLOR_MAP 32))) ;;----------------------------------------------------------------------------- ;; Cut-Buffers (defun cut-buffer (display &key (buffer 0) (type :STRING) (result-type 'string) (transform #'card8->char) (start 0) end) ;; Return the contents of cut-buffer BUFFER (declare (type display display) (type (integer 0 7) buffer) (type xatom type) (type array-index start) (type (or null array-index) end) (type t result-type) ;a sequence type (type (or null (function (integer) t)) transform)) (declare (clx-values sequence type format bytes-after)) (let* ((root (screen-root (first (display-roots display)))) (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7) buffer))) (get-property root property :type type :result-type result-type :start start :end end :transform transform))) ;; Implement the following: ;; (defsetf cut-buffer (display &key (buffer 0) (type :string) (format 8) ;; (transform #'char->card8) (start 0) end) (data) ;; In order to avoid having to pass positional parameters to set-cut-buffer, ;; We've got to do the following. WHAT A PAIN... #-clx-ansi-common-lisp (define-setf-method cut-buffer (display &rest option-list) (declare (dynamic-extent option-list)) (do* ((options (copy-list option-list)) (option options (cddr option)) (store (gensym)) (dtemp (gensym)) (temps (list dtemp)) (values (list display))) ((endp option) (values (nreverse temps) (nreverse values) (list store) `(set-cut-buffer ,store ,dtemp ,@options) `(cut-buffer ,@options))) (unless (member (car option) '(:buffer :type :format :start :end :transform)) (error "Keyword arg ~s isn't recognized" (car option))) (let ((x (gensym))) (push x temps) (push (cadr option) values) (setf (cadr option) x)))) (defun #+clx-ansi-common-lisp (setf cut-buffer) #-clx-ansi-common-lisp set-cut-buffer (data display &key (buffer 0) (type :STRING) (format 8) (start 0) end (transform #'char->card8)) (declare (type sequence data) (type display display) (type (integer 0 7) buffer) (type xatom type) (type (member 8 16 32) format) (type array-index start) (type (or null array-index) end) (type (or null (function (integer) t)) transform)) (let* ((root (screen-root (first (display-roots display)))) (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7) buffer))) (change-property root property data type format :transform transform :start start :end end) data)) (defun rotate-cut-buffers (display &optional (delta 1) (careful-p t)) ;; Positive rotates left, negative rotates right (opposite of actual protocol request). ;; When careful-p, ensure all cut-buffer properties are defined, to prevent errors. (declare (type display display) (type int16 delta) (type generalized-boolean careful-p)) (let* ((root (screen-root (first (display-roots display)))) (buffers '#(:cut_buffer0 :cut_buffer1 :cut_buffer2 :cut_buffer3 :cut_buffer4 :cut_buffer5 :cut_buffer6 :cut_buffer7))) (when careful-p (let ((props (list-properties root))) (dotimes (i 8) (unless (member (aref buffers i) props) (setf (cut-buffer display :buffer i) ""))))) (rotate-properties root buffers delta))) cl-clx-sbcl-0.7.4.20160323.orig/bufmac.lisp0000644000175000017500000001561012715665272015753 0ustar pdmpdm;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; This file contains macro definitions for the BUFFER object for Common-Lisp ;;; X windows version 11 ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (in-package :xlib) ;;; The read- macros are in buffer.lisp, because event-case depends on (most of) them. (defmacro write-card8 (byte-index item) `(aset-card8 (the card8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro write-int8 (byte-index item) `(aset-int8 (the int8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro write-card16 (byte-index item) #+clx-overlapping-arrays `(aset-card16 (the card16 ,item) buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1))) #-clx-overlapping-arrays `(aset-card16 (the card16 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro write-int16 (byte-index item) #+clx-overlapping-arrays `(aset-int16 (the int16 ,item) buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1))) #-clx-overlapping-arrays `(aset-int16 (the int16 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro write-card32 (byte-index item) #+clx-overlapping-arrays `(aset-card32 (the card32 ,item) buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) #-clx-overlapping-arrays `(aset-card32 (the card32 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro write-int32 (byte-index item) #+clx-overlapping-arrays `(aset-int32 (the int32 ,item) buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) #-clx-overlapping-arrays `(aset-int32 (the int32 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro write-card29 (byte-index item) #+clx-overlapping-arrays `(aset-card29 (the card29 ,item) buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) #-clx-overlapping-arrays `(aset-card29 (the card29 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index))) ;; This is used for 2-byte characters, which may not be aligned on 2-byte boundaries ;; and always are written high-order byte first. (defmacro write-char2b (byte-index item) ;; It is impossible to do an overlapping write, so only nonoverlapping here. `(let ((%item ,item) (%byte-index (index+ buffer-boffset ,byte-index))) (declare (type card16 %item) (type array-index %byte-index)) (aset-card8 (the card8 (ldb (byte 8 8) %item)) buffer-bbuf %byte-index) (aset-card8 (the card8 (ldb (byte 8 0) %item)) buffer-bbuf (index+ %byte-index 1)))) (defmacro set-buffer-offset (value &environment env) env `(let ((.boffset. ,value)) (declare (type array-index .boffset.)) (setq buffer-boffset .boffset.) #+clx-overlapping-arrays ,@(when (member 16 (macroexpand '(%buffer-sizes) env)) `((setq buffer-woffset (index-ash .boffset. -1)))) #+clx-overlapping-arrays ,@(when (member 32 (macroexpand '(%buffer-sizes) env)) `((setq buffer-loffset (index-ash .boffset. -2)))) #+clx-overlapping-arrays .boffset.)) (defmacro advance-buffer-offset (value) `(set-buffer-offset (index+ buffer-boffset ,value))) (defmacro with-buffer-output ((buffer &key (sizes '(8 16 32)) length index) &body body) (unless (listp sizes) (setq sizes (list sizes))) `(let ((%buffer ,buffer)) (declare (type display %buffer)) ,(declare-bufmac) ,(when length `(when (index>= (index+ (buffer-boffset %buffer) ,length) (buffer-size %buffer)) (buffer-flush %buffer))) (let* ((buffer-boffset (the array-index ,(or index `(buffer-boffset %buffer)))) #-clx-overlapping-arrays (buffer-bbuf (buffer-obuf8 %buffer)) #+clx-overlapping-arrays ,@(append (when (member 8 sizes) `((buffer-bbuf (buffer-obuf8 %buffer)))) (when (or (member 16 sizes) (member 160 sizes)) `((buffer-woffset (index-ash buffer-boffset -1)) (buffer-wbuf (buffer-obuf16 %buffer)))) (when (member 32 sizes) `((buffer-loffset (index-ash buffer-boffset -2)) (buffer-lbuf (buffer-obuf32 %buffer)))))) (declare (type array-index buffer-boffset)) #-clx-overlapping-arrays (declare (type buffer-bytes buffer-bbuf)) #+clx-overlapping-arrays ,@(append (when (member 8 sizes) '((declare (type buffer-bytes buffer-bbuf)))) (when (member 16 sizes) '((declare (type array-index buffer-woffset)) (declare (type buffer-words buffer-wbuf)))) (when (member 32 sizes) '((declare (type array-index buffer-loffset)) (declare (type buffer-longs buffer-lbuf))))) buffer-boffset #-clx-overlapping-arrays buffer-bbuf #+clx-overlapping-arrays ,@(append (when (member 8 sizes) '(buffer-bbuf)) (when (member 16 sizes) '(buffer-woffset buffer-wbuf)) (when (member 32 sizes) '(buffer-loffset buffer-lbuf))) #+clx-overlapping-arrays (macrolet ((%buffer-sizes () ',sizes)) ,@body) #-clx-overlapping-arrays ,@body))) ;;; This macro is just used internally in buffer (defmacro writing-buffer-chunks (type args decls &body body) (when (> (length body) 2) (error "writing-buffer-chunks called with too many forms")) (let* ((size (* 8 (index-increment type))) (form #-clx-overlapping-arrays (first body) #+clx-overlapping-arrays ; XXX type dependencies (or (second body) (first body)))) `(with-buffer-output (buffer :index boffset :sizes ,(reverse (adjoin size '(8)))) ;; Loop filling the buffer (do* (,@args ;; Number of bytes needed to output (len ,(if (= size 8) `(index- end start) `(index-ash (index- end start) ,(truncate size 16))) (index- len chunk)) ;; Number of bytes available in buffer (chunk (index-min len (index- (buffer-size buffer) buffer-boffset)) (index-min len (index- (buffer-size buffer) buffer-boffset)))) ((not (index-plusp len))) (declare ,@decls (type array-index len chunk)) ,form (index-incf buffer-boffset chunk) ;; Flush the buffer (when (and (index-plusp len) (index>= buffer-boffset (buffer-size buffer))) (setf (buffer-boffset buffer) buffer-boffset) (buffer-flush buffer) (setq buffer-boffset (buffer-boffset buffer)) #+clx-overlapping-arrays ,(case size (16 '(setq buffer-woffset (index-ash buffer-boffset -1))) (32 '(setq buffer-loffset (index-ash buffer-boffset -2)))))) (setf (buffer-boffset buffer) (lround buffer-boffset))))) cl-clx-sbcl-0.7.4.20160323.orig/macros.lisp0000644000175000017500000011760612715665272016012 0ustar pdmpdm;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; ;;; CLX basically implements a very low overhead remote procedure call ;;; to the server. This file contains macros which generate the code ;;; for both the client AND the server, given a specification of the ;;; interface. This was done to eliminate errors that may occur because ;;; the client and server code get/put bytes in different places, and ;;; it makes it easier to extend the protocol. ;;; This is built on top of BUFFER (in-package :xlib) (defmacro type-check (value type) value type (when +type-check?+ `(unless (type? ,value ,type) (x-type-error ,value ,type)))) ;;; This variable is used by the required-arg macro just to satisfy compilers. (defvar *required-arg-dummy*) ;;; An error signalling macro use to specify that keyword arguments are required. (defmacro required-arg (name) `(progn (x-error 'missing-parameter :parameter ',name) *required-arg-dummy*)) (defmacro lround (index) ;; Round up to the next 32 bit boundary `(the array-index (logand (index+ ,index 3) -4))) (defmacro wround (index) ;; Round up to the next 16 bit boundary `(the array-index (logand (index+ ,index 1) -2))) ;; ;; Data-type accessor functions ;; ;; These functions translate between lisp data-types and the byte, ;; half-word or word that gets transmitted across the client/server ;; connection (defun index-increment (type) ;; Given a type, return its field width in bytes (let* ((name (if (consp type) (car type) type)) (increment (get name 'byte-width :not-found))) (when (eq increment :not-found) ;; Check for TYPE in a different package (when (not (eq (symbol-package name) *xlib-package*)) (setq name (xintern name)) (setq increment (get name 'byte-width :not-found))) (when (eq increment :not-found) (error "~s isn't a known field accessor" name))) increment)) (eval-when (:compile-toplevel :load-toplevel :execute) (defun getify (name) (xintern name '-get)) (defun putify (name &optional predicate-p) (xintern name '-put (if predicate-p '-predicating ""))) ;;; Use &body so zmacs indents properly (defmacro define-accessor (name (width) &body get-put-macros) ;; The first body form defines the get macro ;; The second body form defines the put macro ;; The third body form is optional, and defines a put macro that does ;; type checking and does a put when ok, else NIL when the type is incorrect. ;; If no third body form is present, then these macros assume that ;; (AND (TYPEP ,thing 'type) (PUT-type ,thing)) can be generated. ;; these predicating puts are used by the OR accessor. (declare (arglist name (width) get-macro put-macro &optional predicating-put-macro)) (when (cdddr get-put-macros) (error "Too many parameters to define-accessor: ~s" (cdddr get-put-macros))) (let ((get-macro (or (first get-put-macros) (error "No GET macro form for ~s" name))) (put-macro (or (second get-put-macros) (error "No PUT macro form for ~s" name)))) `(within-definition (,name define-accessor) (setf (get ',name 'byte-width) ,(and width (floor width 8))) (defmacro ,(getify name) ,(car get-macro) ,@(cdr get-macro)) (defmacro ,(putify name) ,(car put-macro) ,@(cdr put-macro)) ,@(when +type-check?+ (let ((predicating-put (third get-put-macros))) (when predicating-put `((setf (get ',name 'predicating-put) t) (defmacro ,(putify name t) ,(car predicating-put) ,@(cdr predicating-put))))))))) ) ;; End eval-when (define-accessor card32 (32) ((index) `(read-card32 ,index)) ((index thing) `(write-card32 ,index ,thing))) (define-accessor card29 (32) ((index) `(read-card29 ,index)) ((index thing) `(write-card29 ,index ,thing))) (define-accessor card16 (16) ((index) `(read-card16 ,index)) ((index thing) `(write-card16 ,index ,thing))) (define-accessor card8 (8) ((index) `(read-card8 ,index)) ((index thing) `(write-card8 ,index ,thing))) (define-accessor integer (32) ((index) `(read-int32 ,index)) ((index thing) `(write-int32 ,index ,thing))) (define-accessor int16 (16) ((index) `(read-int16 ,index)) ((index thing) `(write-int16 ,index ,thing))) (define-accessor rgb-val (16) ;; Used for color's ((index) `(card16->rgb-val (read-card16 ,index))) ((index thing) `(write-card16 ,index (rgb-val->card16 ,thing)))) (define-accessor angle (16) ;; Used for drawing arcs ((index) `(int16->radians (read-int16 ,index))) ((index thing) `(write-int16 ,index (radians->int16 ,thing)))) (define-accessor bit (0) ;; Like BOOLEAN, but tests bits ;; only used by declare-event (:enter-notify :leave-notify) ((index bit) `(logbitp ,bit (read-card8 ,index))) ((index thing bit) (if (zerop bit) `(write-card8 ,index (if ,thing 1 0)) `(write-card8 ,index (dpb (if ,thing 1 0) (byte 1 ,bit) (read-card8 ,index)))))) (define-accessor boolean (8) ((index) `(plusp (read-card8 ,index))) ((index thing) `(write-card8 ,index (if ,thing 1 0)))) (define-accessor drawable (32) ((index &optional (buffer '%buffer)) `(lookup-drawable ,buffer (read-card29 ,index))) ((index thing) `(write-card29 ,index (drawable-id ,thing)))) (define-accessor window (32) ((index &optional (buffer '%buffer)) `(lookup-window ,buffer (read-card29 ,index))) ((index thing) `(write-card29 ,index (window-id ,thing)))) (define-accessor pixmap (32) ((index &optional (buffer '%buffer)) `(lookup-pixmap ,buffer (read-card29 ,index))) ((index thing) `(write-card29 ,index (pixmap-id ,thing)))) (define-accessor gcontext (32) ((index &optional (buffer '%buffer)) `(lookup-gcontext ,buffer (read-card29 ,index))) ((index thing) `(write-card29 ,index (gcontext-id ,thing)))) (define-accessor cursor (32) ((index &optional (buffer '%buffer)) `(lookup-cursor ,buffer (read-card29 ,index))) ((index thing) `(write-card29 ,index (cursor-id ,thing)))) (define-accessor colormap (32) ((index &optional (buffer '%buffer)) `(lookup-colormap ,buffer (read-card29 ,index))) ((index thing) `(write-card29 ,index (colormap-id ,thing)))) (define-accessor font (32) ((index &optional (buffer '%buffer)) `(lookup-font ,buffer (read-card29 ,index))) ;; The FONT-ID accessor may make a OpenFont request. Since we don't support recursive ;; with-buffer-request, issue a compile time error, rather than barf at run-time. ((index thing) (declare (ignore index thing)) (error "FONT-ID must be called OUTSIDE with-buffer-request. Use RESOURCE-ID instead."))) ;; Needed to get and put xatom's in events (define-accessor keyword (32) ((index &optional (buffer '%buffer)) `(atom-name ,buffer (read-card29 ,index))) ((index thing &key (buffer '%buffer)) `(write-card29 ,index (or (atom-id ,thing ,buffer) (error "CLX implementation error in KEYWORD-PUT"))))) (define-accessor resource-id (32) ((index) `(read-card29 ,index)) ((index thing) `(write-card29 ,index ,thing))) (define-accessor resource-id-or-nil (32) ((index) (let ((id (gensym))) `(let ((,id (read-card29 ,index))) (and (plusp ,id) ,id)))) ((index thing) `(write-card29 ,index (or ,thing 0)))) (defmacro char-info-get (index) `(make-char-info :left-bearing (int16-get ,index) :right-bearing (int16-get ,(+ index 2)) :width (int16-get ,(+ index 4)) :ascent (int16-get ,(+ index 6)) :descent (int16-get ,(+ index 8)) :attributes (card16-get ,(+ index 10)))) (define-accessor member8 (8) ((index &rest keywords) (let ((value (gensym))) `(let ((,value (read-card8 ,index))) (declare (type (integer 0 (,(length keywords))) ,value)) (type-check ,value '(integer 0 (,(length keywords)))) (svref ',(apply #'vector keywords) ,value)))) ((index thing &rest keywords) `(write-card8 ,index (position ,thing #+lispm ',keywords ;; Lispm's prefer lists #-lispm (the simple-vector ',(apply #'vector keywords)) :test #'eq))) ((index thing &rest keywords) (let ((value (gensym))) `(let ((,value (position ,thing #+lispm ',keywords #-lispm (the simple-vector ',(apply #'vector keywords)) :test #'eq))) (and ,value (write-card8 ,index ,value)))))) (define-accessor member16 (16) ((index &rest keywords) (let ((value (gensym))) `(let ((,value (read-card16 ,index))) (declare (type (integer 0 (,(length keywords))) ,value)) (type-check ,value '(integer 0 (,(length keywords)))) (svref ',(apply #'vector keywords) ,value)))) ((index thing &rest keywords) `(write-card16 ,index (position ,thing #+lispm ',keywords ;; Lispm's prefer lists #-lispm (the simple-vector ',(apply #'vector keywords)) :test #'eq))) ((index thing &rest keywords) (let ((value (gensym))) `(let ((,value (position ,thing #+lispm ',keywords #-lispm (the simple-vector ',(apply #'vector keywords)) :test #'eq))) (and ,value (write-card16 ,index ,value)))))) (define-accessor member (32) ((index &rest keywords) (let ((value (gensym))) `(let ((,value (read-card29 ,index))) (declare (type (integer 0 (,(length keywords))) ,value)) (type-check ,value '(integer 0 (,(length keywords)))) (svref ',(apply #'vector keywords) ,value)))) ((index thing &rest keywords) `(write-card29 ,index (position ,thing #+lispm ',keywords ;; Lispm's prefer lists #-lispm (the simple-vector ',(apply #'vector keywords)) :test #'eq))) ((index thing &rest keywords) (if (cdr keywords) ;; IF more than one (let ((value (gensym))) `(let ((,value (position ,thing #+lispm ',keywords #-lispm (the simple-vector ',(apply #'vector keywords)) :test #'eq))) (and ,value (write-card29 ,index ,value)))) `(and (eq ,thing ,(car keywords)) (write-card29 ,index 0))))) (deftype member-vector (vector) `(member ,@(coerce (symbol-value vector) 'list))) (define-accessor member-vector (32) ((index membership-vector) `(member-get ,index ,@(coerce (eval membership-vector) 'list))) ((index thing membership-vector) `(member-put ,index ,thing ,@(coerce (eval membership-vector) 'list))) ((index thing membership-vector) `(member-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))) (define-accessor member16-vector (16) ((index membership-vector) `(member16-get ,index ,@(coerce (eval membership-vector) 'list))) ((index thing membership-vector) `(member16-put ,index ,thing ,@(coerce (eval membership-vector) 'list))) ((index thing membership-vector) `(member16-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))) (define-accessor member8-vector (8) ((index membership-vector) `(member8-get ,index ,@(coerce (eval membership-vector) 'list))) ((index thing membership-vector) `(member8-put ,index ,thing ,@(coerce (eval membership-vector) 'list))) ((index thing membership-vector) `(member8-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))) (define-accessor boole-constant (32) ;; this isn't member-vector because we need eql instead of eq ((index) (let ((value (gensym))) `(let ((,value (read-card29 ,index))) (declare (type (integer 0 (,(length +boole-vector+))) ,value)) (type-check ,value '(integer 0 (,(length +boole-vector+)))) (svref +boole-vector+ ,value)))) ((index thing) `(write-card29 ,index (position ,thing (the simple-vector +boole-vector+)))) ((index thing) (let ((value (gensym))) `(let ((,value (position ,thing (the simple-vector +boole-vector+)))) (and ,value (write-card29 ,index ,value)))))) (define-accessor null (32) ((index) `(if (zerop (read-card32 ,index)) nil (read-card32 ,index))) ((index value) (declare (ignore value)) `(write-card32 ,index 0))) (define-accessor pad8 (8) ((index) (declare (ignore index)) nil) ((index value) (declare (ignore index value)) nil)) (define-accessor pad16 (16) ((index) (declare (ignore index)) nil) ((index value) (declare (ignore index value)) nil)) (define-accessor pad32 (32) ((index) (declare (ignore index)) nil) ((index value) (declare (ignore index value)) nil)) (define-accessor bit-vector256 (256) ;; used for key-maps ;; REAL-INDEX parameter provided so the default index can be over-ridden. ;; This is needed for the :keymap-notify event where the keymap overlaps ;; the window id. ((index &optional (real-index index) data) `(read-bitvector256 buffer-bbuf ,real-index ,data)) ((index map &optional (real-index index) (buffer '%buffer)) `(write-bitvector256 ,buffer (index+ buffer-boffset ,real-index) ,map))) (define-accessor string (nil) ((length index &key reply-buffer) `(read-sequence-char ,(or reply-buffer '%reply-buffer) 'string ,length nil nil 0 ,index)) ((index string &key buffer (start 0) end header-length appending) (unless buffer (setq buffer '%buffer)) (unless header-length (setq header-length (lround index))) (let* ((real-end (if appending (or end `(length ,string)) (gensym))) (form `(write-sequence-char ,buffer (index+ buffer-boffset ,header-length) ,string ,start ,real-end))) (if appending form `(let ((,real-end ,(or end `(length ,string)))) (write-card16 2 (index-ceiling (index+ (index- ,real-end ,start) ,header-length) 4)) ,form))))) (define-accessor sequence (nil) ((&key length (format 'card32) result-type transform reply-buffer data index start) `(,(ecase format (card8 'read-sequence-card8) (int8 'read-sequence-int8) (card16 'read-sequence-card16) (int16 'read-sequence-int16) (card32 'read-sequence-card32) (int32 'read-sequence-int32)) ,(or reply-buffer '%reply-buffer) ,result-type ,length ,transform ,data ,@(when (or start index) `(,(or start 0))) ,@(when index `(,index)))) ((index data &key (format 'card32) (start 0) end transform buffer appending) (unless buffer (setq buffer '%buffer)) (let* ((real-end (if appending (or end `(length ,data)) (gensym))) (writer (xintern 'write-sequence- format)) (form `(,writer ,buffer (index+ buffer-boffset ,(lround index)) ,data ,start ,real-end ,transform))) (flet ((maker (size) (if appending form (let ((idx `(index- ,real-end ,start))) (unless (= size 1) (setq idx `(index-ceiling ,idx ,size))) `(let ((,real-end ,(or end `(length ,data)))) (write-card16 2 (index+ ,idx ,(index-ceiling index 4))) ,form))))) (ecase format ((card8 int8) (maker 4)) ((card16 int16 char2b) (maker 2)) ((card32 int32) (maker 1))))))) (defmacro client-message-event-get-sequence () '(let* ((format (read-card8 1)) (sequence (make-array (ceiling 160 format) :element-type `(unsigned-byte ,format)))) (declare (type (member 8 16 32) format)) (do ((i 12) (j 0 (index1+ j))) ((>= i 32)) (case format (8 (setf (aref sequence j) (read-card8 i)) (index-incf i)) (16 (setf (aref sequence j) (read-card16 i)) (index-incf i 2)) (32 (setf (aref sequence j) (read-card32 i)) (index-incf i 4)))) sequence)) (defmacro client-message-event-put-sequence (format sequence) `(ecase ,format (8 (sequence-put 12 ,sequence :format card8 :end (min (length ,sequence) 20) :appending t)) (16 (sequence-put 12 ,sequence :format card16 :end (min (length ,sequence) 10) :appending t)) (32 (sequence-put 12 ,sequence :format card32 :end (min (length ,sequence) 5) :appending t)))) ;; Used only in declare-event (define-accessor client-message-sequence (160) ((index format) (declare (ignore index format)) `(client-message-event-get-sequence)) ((index value format) (declare (ignore index)) `(client-message-event-put-sequence ,format ,value))) ;;; ;;; Compound accessors ;;; Accessors that take other accessors as parameters ;;; (define-accessor code (0) ((index) (declare (ignore index)) '(read-card8 0)) ((index value) (declare (ignore index)) `(write-card8 0 ,value)) ((index value) (declare (ignore index)) `(write-card8 0 ,value))) (define-accessor length (0) ((index) (declare (ignore index)) '(read-card16 2)) ((index value) (declare (ignore index)) `(write-card16 2 ,value)) ((index value) (declare (ignore index)) `(write-card16 2 ,value))) (deftype data () 'card8) (define-accessor data (0) ;; Put data in byte 1 of the reqeust ((index &optional stuff) (declare (ignore index)) (if stuff (if (consp stuff) `(,(getify (car stuff)) 1 ,@(cdr stuff)) `(,(getify stuff) 1)) `(read-card8 1))) ((index thing &optional stuff) (if stuff (if (consp stuff) `(macrolet ((write-card32 (index value) index value)) (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff)))) `(,(putify stuff) 1 ,thing)) `(write-card8 1 ,thing))) ((index thing &optional stuff) (if stuff `(and (type? ,thing ',stuff) ,(if (consp stuff) `(macrolet ((write-card32 (index value) index value)) (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff)))) `(,(putify stuff) 1 ,thing))) `(and (type? ,thing 'card8) (write-card8 1 ,thing))))) ;; Macroexpand the result of OR-GET to allow the macros file to not be loaded ;; when using event-case. This is pretty gross. (defmacro or-expand (&rest forms &environment environment) `(cond ,@(mapcar #'(lambda (forms) (mapcar #'(lambda (form) (clx-macroexpand form environment)) forms)) forms))) ;; ;; the OR type ;; (define-accessor or (32) ;; Select from among several types (usually NULL and something else) ((index &rest type-list &environment environment) (do ((types type-list (cdr types)) (value (gensym)) (result)) ((endp types) `(let ((,value (read-card32 ,index))) (macrolet ((read-card32 (index) index ',value) (read-card29 (index) index ',value)) ,(clx-macroexpand `(or-expand ,@(nreverse result)) environment)))) (let ((item (car types)) (args nil)) (when (consp item) (setq args (cdr item) item (car item))) (if (eq item 'null) ;; Special case for NULL (push `((zerop ,value) nil) result) (push `((,(getify item) ,index ,@args)) result))))) ((index value &rest type-list) (do ((types type-list (cdr types)) (result)) ((endp types) `(cond ,@(nreverse result) ,@(when +type-check?+ `((t (x-type-error ,value '(or ,@type-list))))))) (let* ((type (car types)) (type-name type) (args nil)) (when (consp type) (setq args (cdr type) type-name (car type))) (push `(,@(cond ((get type-name 'predicating-put) nil) ((or +type-check?+ (cdr types)) `((type? ,value ',type))) (t '(t))) (,(putify type-name (get type-name 'predicating-put)) ,index ,value ,@args)) result))))) ;; ;; the MASK type... ;; is used to specify a subset of a collection of "optional" arguments. ;; A mask type consists of a 32 bit mask word followed by a word for each one-bit ;; in the mask. The MASK type is ALWAYS the LAST item in a request. ;; (setf (get 'mask 'byte-width) nil) (defun mask-get (index type-values body-function) (declare (type function body-function) #+clx-ansi-common-lisp (dynamic-extent body-function) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg body-function)) ;; This is a function, because it must return more than one form (called by get-put-items) ;; Functions that use this must have a binding for %MASK (let* ((bit 0) (result (mapcar #'(lambda (form) (if (atom form) form ;; Hack to allow BODY-FUNCTION to return keyword/value pairs (prog1 `(when (logbitp ,bit %mask) ;; Execute form when bit is set ,form) (incf bit)))) (get-put-items (+ index 4) type-values nil #'(lambda (type index item args) (declare (ignore index)) (funcall body-function type '(* (incf %index) 4) item args)))))) ;; First form must load %MASK `(,@(when (atom (car result)) (list (pop result))) (progn (setq %mask (read-card32 ,index)) (setq %index ,(ceiling index 4)) ,(car result)) ,@(cdr result)))) ;; MASK-PUT (defun mask-put (index type-values body-function) (declare (type function body-function) #+clx-ansi-common-lisp (dynamic-extent body-function) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg body-function)) ;; The MASK type writes a 32 bit mask with 1 bits for each non-nil value in TYPE-VALUES ;; A 32 bit value follows for each non-nil value. `((let ((%mask 0) (%index ,index)) ,@(let ((bit 1)) (get-put-items index type-values t #'(lambda (type index item args) (declare (ignore index)) (if (or (symbolp item) (constantp item)) `((unless (null ,item) (setq %mask (logior %mask ,(shiftf bit (ash bit 1)))) ,@(funcall body-function type `(index-incf %index 4) item args))) `((let ((.item. ,item)) (unless (null .item.) (setq %mask (logior %mask ,(shiftf bit (ash bit 1)))) ,@(funcall body-function type `(index-incf %index 4) '.item. args)))))))) (write-card32 ,index %mask) (write-card16 2 (index-ceiling (index-incf %index 4) 4)) (incf (buffer-boffset %buffer) %index)))) (define-accessor progn (nil) ;; Catch-all for inserting random code ;; Note that code using this is then responsible for setting the request length ((index statement) (declare (ignore index)) statement) ((index statement) (declare (ignore index)) statement)) ; ; Wrapper macros, for use around the above ; ;;; type-check was here, and has been moved up (defmacro check-put (index value type &rest args &environment env) (let* ((var (if (or (symbolp value) (constantp value)) value '.value.)) (body (if (or (null (macroexpand `(type-check ,var ',type) env)) (member type '(or progn pad8 pad16)) (constantp value)) `(,(putify type) ,index ,var ,@args) ;; Do type checking (if (get type 'predicating-put) `(or (,(putify type t) ,index ,var ,@args) (x-type-error ,var ',(if args `(,type ,@args) type))) `(if (type? ,var ',type) (,(putify type) ,index ,var ,@args) (x-type-error ,var ',(if args `(,type ,@args) type))))))) (if (eq var value) body `(let ((,var ,value)) ,body)))) (defun get-put-items (index type-args putp &optional body-function) (declare (type (or null function) body-function) #+clx-ansi-common-lisp (dynamic-extent body-function) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg body-function)) ;; Given a lists of the form (type item item ... item) ;; Calls body-function with four arguments, a function name, ;; index, item name, and optional arguments. ;; The results are appended together and retured. (unless body-function (setq body-function #'(lambda (type index item args) `((check-put ,index ,item ,type ,@args))))) (do* ((items type-args (cdr items)) (type (caar items) (caar items)) (args nil nil) (result nil) (sizes nil)) ((endp items) (values result index sizes)) (when (consp type) (setq args (cdr type) type (car type))) (cond ((member type '(return buffer))) ((eq type 'mask) ;; Hack to enable mask-get/put to return multiple values (setq result (append result (if putp (mask-put index (cdar items) body-function) (mask-get index (cdar items) body-function))) index nil)) (t (do* ((item (cdar items) (cdr item)) (increment (index-increment type))) ((endp item)) (when (constantp index) (case increment ;Round up index when needed (2 (setq index (wround index))) (4 (setq index (lround index))))) (setq result (append result (funcall body-function type index (car item) args))) (when (constantp index) ;; Variable length requests have null length increment. ;; Variable length requests set the request size ;; & maintain buffer pointers (if (null increment) (setq index nil) (progn (incf index increment) (when (and increment (zerop increment)) (setq increment 1)) (pushnew (* increment 8) sizes))))))))) (defmacro with-buffer-request-internal ((buffer opcode &key length sizes &allow-other-keys) &body type-args) (multiple-value-bind (code index item-sizes) (get-put-items 4 type-args t) (let ((length (if length `(index+ ,length +requestsize+) '+requestsize+)) (sizes (remove-duplicates (append '(8 16) item-sizes sizes)))) `(with-buffer-output (,buffer :length ,length :sizes ,sizes) (setf (buffer-last-request ,buffer) buffer-boffset) (write-card8 0 ,opcode) ;; Stick in the opcode ,@code ,@(when index (setq index (lround index)) `((write-card16 2 ,(ceiling index 4)) (setf (buffer-boffset ,buffer) (index+ buffer-boffset ,index)))) (buffer-new-request-number ,buffer))))) (defmacro with-buffer-request ((buffer opcode &rest options &key inline gc-force &allow-other-keys) &body type-args &environment env) (if (and (null inline) (macroexpand '(use-closures) env)) `(flet ((.request-body. (.display.) (declare (type display .display.)) (with-buffer-request-internal (.display. ,opcode ,@options) ,@type-args))) #+clx-ansi-common-lisp (declare (dynamic-extent #'.request-body.)) (,(if (eq (car (macroexpand '(with-buffer (buffer)) env)) 'progn) 'with-buffer-request-function-nolock 'with-buffer-request-function) ,buffer ,gc-force #'.request-body.)) `(let ((.display. ,buffer)) (declare (type display .display.)) (with-buffer (.display.) ,@(when gc-force `((force-gcontext-changes-internal ,gc-force))) (multiple-value-prog1 (without-aborts (with-buffer-request-internal (.display. ,opcode ,@options) ,@type-args)) (display-invoke-after-function .display.)))))) (defmacro with-buffer-request-and-reply ((buffer opcode reply-size &key sizes multiple-reply inline) type-args &body reply-forms &environment env) (declare (indentation 0 4 1 4 2 1)) (let* ((inner-reply-body `(with-buffer-input (.reply-buffer. :display .display. ,@(and sizes (list :sizes sizes))) nil ,@reply-forms)) (reply-body (if (or (not (symbolp reply-size)) (constantp reply-size)) inner-reply-body `(let ((,reply-size (reply-data-size (the reply-buffer .reply-buffer.)))) (declare (type array-index ,reply-size)) ,inner-reply-body)))) (if (and (null inline) (macroexpand '(use-closures) env)) `(flet ((.request-body. (.display.) (declare (type display .display.)) (with-buffer-request-internal (.display. ,opcode) ,@type-args)) (.reply-body. (.display. .reply-buffer.) (declare (type display .display.) (type reply-buffer .reply-buffer.)) (progn .display. .reply-buffer. nil) ,reply-body)) #+clx-ansi-common-lisp (declare (dynamic-extent #'.request-body. #'.reply-body.)) (with-buffer-request-and-reply-function ,buffer ,multiple-reply #'.request-body. #'.reply-body.)) `(let ((.display. ,buffer) (.pending-command. nil) (.reply-buffer. nil)) (declare (type display .display.) (type (or null pending-command) .pending-command.) (type (or null reply-buffer) .reply-buffer.)) (unwind-protect (progn (with-buffer (.display.) (setq .pending-command. (start-pending-command .display.)) (without-aborts (with-buffer-request-internal (.display. ,opcode) ,@type-args)) (buffer-force-output .display.) (display-invoke-after-function .display.)) ,@(if multiple-reply `((loop (setq .reply-buffer. (read-reply .display. .pending-command.)) (when ,reply-body (return nil)) (deallocate-reply-buffer (shiftf .reply-buffer. nil)))) `((setq .reply-buffer. (read-reply .display. .pending-command.)) ,reply-body))) (when .reply-buffer. (deallocate-reply-buffer .reply-buffer.)) (when .pending-command. (stop-pending-command .display. .pending-command.))))))) (defmacro compare-request ((index) &body body) `(macrolet ((write-card32 (index item) `(= ,item (read-card32 ,index))) (write-int32 (index item) `(= ,item (read-int32 ,index))) (write-card29 (index item) `(= ,item (read-card29 ,index))) (write-int29 (index item) `(= ,item (read-int29 ,index))) (write-card16 (index item) `(= ,item (read-card16 ,index))) (write-int16 (index item) `(= ,item (read-int16 ,index))) (write-card8 (index item) `(= ,item (read-card8 ,index))) (write-int8 (index item) `(= ,item (read-int8 ,index)))) (macrolet ((type-check (value type) value type nil)) (and ,@(get-put-items index body t))))) (defmacro put-items ((index) &body body) `(progn ,@(get-put-items index body t))) (defmacro decode-type (type value) ;; Given an integer and type, return the value (let ((args nil)) (when (consp type) (setq args (cdr type) type (car type))) `(macrolet ((read-card29 (value) value) (read-card32 (value) value) (read-int32 (value) `(card32->int32 ,value)) (read-card16 (value) value) (read-int16 (value) `(card16->int16 ,value)) (read-card8 (value) value) (read-int8 (value) `(int8->card8 ,value))) (,(getify type) ,value ,@args)))) (defmacro encode-type (type value) ;; Given a value and type, return an integer ;; When check-p, do type checking on value (let ((args nil)) (when (consp type) (setq args (cdr type) type (car type))) `(macrolet ((write-card29 (index value) index value) (write-card32 (index value) index value) (write-int32 (index value) index `(int32->card32 ,value)) (write-card16 (index value) index value) (write-int16 (index value) index `(int16->card16 ,value)) (write-card8 (index value) index value) (write-int8 (index value) index `(int8->card8 ,value))) (check-put 0 ,value ,type ,@args)))) (defmacro set-decode-type (type accessor value) `(setf ,accessor (encode-type ,type ,value))) (defsetf decode-type set-decode-type) ;;; ;;; Request codes ;;; (defconstant +x-createwindow+ 1) (defconstant +x-changewindowattributes+ 2) (defconstant +x-getwindowattributes+ 3) (defconstant +x-destroywindow+ 4) (defconstant +x-destroysubwindows+ 5) (defconstant +x-changesaveset+ 6) (defconstant +x-reparentwindow+ 7) (defconstant +x-mapwindow+ 8) (defconstant +x-mapsubwindows+ 9) (defconstant +x-unmapwindow+ 10) (defconstant +x-unmapsubwindows+ 11) (defconstant +x-configurewindow+ 12) (defconstant +x-circulatewindow+ 13) (defconstant +x-getgeometry+ 14) (defconstant +x-querytree+ 15) (defconstant +x-internatom+ 16) (defconstant +x-getatomname+ 17) (defconstant +x-changeproperty+ 18) (defconstant +x-deleteproperty+ 19) (defconstant +x-getproperty+ 20) (defconstant +x-listproperties+ 21) (defconstant +x-setselectionowner+ 22) (defconstant +x-getselectionowner+ 23) (defconstant +x-convertselection+ 24) (defconstant +x-sendevent+ 25) (defconstant +x-grabpointer+ 26) (defconstant +x-ungrabpointer+ 27) (defconstant +x-grabbutton+ 28) (defconstant +x-ungrabbutton+ 29) (defconstant +x-changeactivepointergrab+ 30) (defconstant +x-grabkeyboard+ 31) (defconstant +x-ungrabkeyboard+ 32) (defconstant +x-grabkey+ 33) (defconstant +x-ungrabkey+ 34) (defconstant +x-allowevents+ 35) (defconstant +x-grabserver+ 36) (defconstant +x-ungrabserver+ 37) (defconstant +x-querypointer+ 38) (defconstant +x-getmotionevents+ 39) (defconstant +x-translatecoords+ 40) (defconstant +x-warppointer+ 41) (defconstant +x-setinputfocus+ 42) (defconstant +x-getinputfocus+ 43) (defconstant +x-querykeymap+ 44) (defconstant +x-openfont+ 45) (defconstant +x-closefont+ 46) (defconstant +x-queryfont+ 47) (defconstant +x-querytextextents+ 48) (defconstant +x-listfonts+ 49) (defconstant +x-listfontswithinfo+ 50) (defconstant +x-setfontpath+ 51) (defconstant +x-getfontpath+ 52) (defconstant +x-createpixmap+ 53) (defconstant +x-freepixmap+ 54) (defconstant +x-creategc+ 55) (defconstant +x-changegc+ 56) (defconstant +x-copygc+ 57) (defconstant +x-setdashes+ 58) (defconstant +x-setcliprectangles+ 59) (defconstant +x-freegc+ 60) (defconstant +x-cleartobackground+ 61) (defconstant +x-copyarea+ 62) (defconstant +x-copyplane+ 63) (defconstant +x-polypoint+ 64) (defconstant +x-polyline+ 65) (defconstant +x-polysegment+ 66) (defconstant +x-polyrectangle+ 67) (defconstant +x-polyarc+ 68) (defconstant +x-fillpoly+ 69) (defconstant +x-polyfillrectangle+ 70) (defconstant +x-polyfillarc+ 71) (defconstant +x-putimage+ 72) (defconstant +x-getimage+ 73) (defconstant +x-polytext8+ 74) (defconstant +x-polytext16+ 75) (defconstant +x-imagetext8+ 76) (defconstant +x-imagetext16+ 77) (defconstant +x-createcolormap+ 78) (defconstant +x-freecolormap+ 79) (defconstant +x-copycolormapandfree+ 80) (defconstant +x-installcolormap+ 81) (defconstant +x-uninstallcolormap+ 82) (defconstant +x-listinstalledcolormaps+ 83) (defconstant +x-alloccolor+ 84) (defconstant +x-allocnamedcolor+ 85) (defconstant +x-alloccolorcells+ 86) (defconstant +x-alloccolorplanes+ 87) (defconstant +x-freecolors+ 88) (defconstant +x-storecolors+ 89) (defconstant +x-storenamedcolor+ 90) (defconstant +x-querycolors+ 91) (defconstant +x-lookupcolor+ 92) (defconstant +x-createcursor+ 93) (defconstant +x-createglyphcursor+ 94) (defconstant +x-freecursor+ 95) (defconstant +x-recolorcursor+ 96) (defconstant +x-querybestsize+ 97) (defconstant +x-queryextension+ 98) (defconstant +x-listextensions+ 99) (defconstant +x-setkeyboardmapping+ 100) (defconstant +x-getkeyboardmapping+ 101) (defconstant +x-changekeyboardcontrol+ 102) (defconstant +x-getkeyboardcontrol+ 103) (defconstant +x-bell+ 104) (defconstant +x-changepointercontrol+ 105) (defconstant +x-getpointercontrol+ 106) (defconstant +x-setscreensaver+ 107) (defconstant +x-getscreensaver+ 108) (defconstant +x-changehosts+ 109) (defconstant +x-listhosts+ 110) (defconstant +x-changeaccesscontrol+ 111) (defconstant +x-changeclosedownmode+ 112) (defconstant +x-killclient+ 113) (defconstant +x-rotateproperties+ 114) (defconstant +x-forcescreensaver+ 115) (defconstant +x-setpointermapping+ 116) (defconstant +x-getpointermapping+ 117) (defconstant +x-setmodifiermapping+ 118) (defconstant +x-getmodifiermapping+ 119) (defconstant +x-nooperation+ 127) ;;; Some macros for threaded lists (defmacro threaded-atomic-push (item list next type) (let ((x (gensym)) (y (gensym))) `(let ((,x ,item)) (declare (type ,type ,x)) (loop (let ((,y ,list)) (declare (type (or null ,type) ,y) (optimize (speed 3) (safety 0))) (setf (,next ,x) ,y) (when (conditional-store ,list ,y ,x) (return ,x))))))) (defmacro threaded-atomic-pop (list next type) (let ((y (gensym))) `(loop (let ((,y ,list)) (declare (type (or null ,type) ,y) (optimize (speed 3) (safety 0))) (if (null ,y) (return nil) (when (conditional-store ,list ,y (,next (the ,type ,y))) (setf (,next (the ,type ,y)) nil) (return ,y))))))) (defmacro threaded-nconc (item list next type) (let ((first (gensym)) (x (gensym)) (y (gensym)) (z (gensym))) `(let ((,z ,item) (,first ,list)) (declare (type ,type ,z) (type (or null ,type) ,first) (optimize (speed 3) (safety 0))) (if (null ,first) (setf ,list ,z) (do* ((,x ,first ,y) (,y (,next ,x) (,next ,x))) ((null ,y) (setf (,next ,x) ,z) ,first) (declare (type ,type ,x) (type (or null ,type) ,y))))))) (defmacro threaded-push (item list next type) (let ((x (gensym))) `(let ((,x ,item)) (declare (type ,type ,x) (optimize (speed 3) (safety 0))) (shiftf (,next ,x) ,list ,x) ,x))) (defmacro threaded-pop (list next type) (let ((x (gensym))) `(let ((,x ,list)) (declare (type (or null ,type) ,x) (optimize (speed 3) (safety 0))) (when ,x (shiftf ,list (,next (the ,type ,x)) nil)) ,x))) (defmacro threaded-enqueue (item head tail next type) (let ((x (gensym))) `(let ((,x ,item)) (declare (type ,type ,x) (optimize (speed 3) (safety 0))) (if (null ,tail) (threaded-nconc ,x ,head ,next ,type) (threaded-nconc ,x (,next (the ,type ,tail)) ,next ,type)) (setf ,tail ,x)))) (defmacro threaded-dequeue (head tail next type) (let ((x (gensym))) `(let ((,x ,head)) (declare (type (or null ,type) ,x) (optimize (speed 3) (safety 0))) (when ,x (when (eq ,x ,tail) (setf ,tail (,next (the ,type ,x)))) (setf ,head (,next (the ,type ,x)))) ,x))) (defmacro threaded-requeue (item head tail next type) (let ((x (gensym))) `(let ((,x ,item)) (declare (type ,type ,x) (optimize (speed 3) (safety 0))) (if (null ,tail) (setf ,tail (setf ,head ,x)) (shiftf (,next ,x) ,head ,x)) ,x))) (defmacro threaded-dolist ((variable list next type) &body body) `(block nil (do* ((,variable ,list (,next (the ,type ,variable)))) ((null ,variable)) (declare (type (or null ,type) ,variable)) ,@body))) (defmacro threaded-delete (item list next type) (let ((x (gensym)) (y (gensym)) (z (gensym)) (first (gensym))) `(let ((,x ,item) (,first ,list)) (declare (type ,type ,x) (type (or null ,type) ,first) (optimize (speed 3) (safety 0))) (when ,first (if (eq ,first ,x) (setf ,first (setf ,list (,next ,x))) (do* ((,y ,first ,z) (,z (,next ,y) (,next ,y))) ((or (null ,z) (eq ,z ,x)) (when (eq ,z ,x) (setf (,next ,y) (,next ,x)))) (declare (type ,type ,y)) (declare (type (or null ,type) ,z))))) (setf (,next ,x) nil) ,first))) (defmacro threaded-length (list next type) (let ((x (gensym)) (count (gensym))) `(do ((,x ,list (,next (the ,type ,x))) (,count 0 (index1+ ,count))) ((null ,x) ,count) (declare (type (or null ,type) ,x) (type array-index ,count) (optimize (speed 3) (safety 0)))))) cl-clx-sbcl-0.7.4.20160323.orig/text.lisp0000644000175000017500000012650012715665272015503 0ustar pdmpdm;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; CLX text keyboard and pointer requests ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (in-package :xlib) ;; Strings are broken up into chunks of this size (defparameter *max-string-size* 254) ;; In the functions below, the transform is used to convert an element of the ;; sequence into a font index. The transform is applied to each element of the ;; (sub)sequence, until either the transform returns nil or the end of the ;; (sub)sequence is reached. If transform returns nil for an element, the ;; index of that element in the sequence is returned, otherwise nil is ;; returned. (deftype translation-function () #+explorer t #-explorer '(function (sequence array-index array-index (or null font) vector array-index) (values array-index (or null int16 font) (or null int32)))) ;; In the functions below, if width is specified, it is assumed to be the pixel ;; width of whatever string of glyphs is actually drawn. Specifying width will ;; allow for appending the output of subsequent calls to the same protocol ;; request, provided gcontext has not been modified in the interim. If width ;; is not specified, appending of subsequent output might not occur. ;; Specifying width is simply a hint, for performance. Note that specifying ;; width may be difficult if transform can return nil. (defun translate-default (src src-start src-end font dst dst-start) ;; dst is guaranteed to have room for (- src-end src-start) integer elements, ;; starting at dst-start; whether dst holds 8-bit or 16-bit elements depends ;; on context. font is the current font, if known. The function should ;; translate as many elements of src as possible into indexes in the current ;; font, and store them into dst. ;; ;; The first return value should be the src index of the first untranslated ;; element. If no further elements need to be translated, the second return ;; value should be nil. If a horizontal motion is required before further ;; translation, the second return value should be the delta in x coordinate. ;; If a font change is required for further translation, the second return ;; value should be the new font. If known, the pixel width of the translated ;; text can be returned as the third value; this can allow for appending of ;; subsequent output to the same protocol request, if no overall width has ;; been specified at the higher level. ;; (returns values: ending-index ;; (OR null horizontal-motion font) ;; (OR null translated-width)) (declare (type sequence src) (type array-index src-start src-end dst-start) (type (or null font) font) (type vector dst) (inline graphic-char-p)) (declare (clx-values integer (or null integer font) (or null integer))) (let ((min-char-index (and font (xlib:font-min-char font))) (max-char-index (and font (xlib:font-max-char font)))) (if (stringp src) (do ((i src-start (index+ i 1)) (j dst-start (index+ j 1)) (char)) ((index>= i src-end) i) (declare (type array-index i j)) (setf char (char->card8 (char src i))) (if (and font (or (< char min-char-index) (> char max-char-index))) (return i) (setf (aref dst j) char))) (do ((i src-start (index+ i 1)) (j dst-start (index+ j 1)) (elt)) ((index>= i src-end) i) (declare (type array-index i j)) (setq elt (elt src i)) (when (characterp elt) (setq elt (char->card8 elt))) (if (or (not (integerp elt)) (and font (< elt min-char-index) (> elt max-char-index))) (return i) (setf (aref dst j) elt)))))) ;; There is a question below of whether translate should always be required, or ;; if not, what the default should be or where it should come from. For ;; example, the default could be something that expected a string as src and ;; translated the CL standard character set to ASCII indexes, and ignored fonts ;; and bits. Or the default could expect a string but otherwise be "system ;; dependent". Or the default could be something that expected a vector of ;; integers and did no translation. Or the default could come from the ;; gcontext (but what about text-extents and text-width?). (defun text-extents (font sequence &key (start 0) end translate) ;; If multiple fonts are involved, font-ascent and font-descent will be the ;; maximums. If multiple directions are involved, the direction will be nil. ;; Translate will always be called with a 16-bit dst buffer. (declare (type sequence sequence) (type (or font gcontext) font)) (declare (type (or null translation-function) translate) #+clx-ansi-common-lisp (dynamic-extent translate) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg #+Genera * #-Genera translate)) (declare (clx-values width ascent descent left right font-ascent font-descent direction (or null array-index))) (when (type? font 'gcontext) (force-gcontext-changes font) (setq font (gcontext-font font t))) (check-type font font) (let* ((left-bearing 0) (right-bearing 0) ;; Sum of widths (width 0) (ascent 0) (descent 0) (overall-ascent (font-ascent font)) (overall-descent (font-descent font)) (overall-direction (font-direction font)) (next-start nil) (display (font-display font))) (declare (type int16 ascent descent overall-ascent overall-descent) (type int32 left-bearing right-bearing width) (type (or null array-index) next-start) (type display display)) (with-display (display) (do* ((wbuf (display-tbuf16 display)) (src-end (or end (length sequence))) (src-start start (index+ src-start buf-end)) (end (index-min src-end (index+ src-start +buffer-text16-size+)) (index-min src-end (index+ src-start +buffer-text16-size+))) (buf-end 0) (new-font) (font-ascent 0) (font-descent 0) (font-direction) (stop-p nil)) ((or stop-p (index>= src-start src-end)) (when (index< src-start src-end) (setq next-start src-start))) (declare (type buffer-text16 wbuf) (type array-index src-start src-end end buf-end) (type int16 font-ascent font-descent) (type generalized-boolean stop-p)) ;; Translate the text (multiple-value-setq (buf-end new-font) (funcall (or translate #'translate-default) sequence src-start end font wbuf 0)) (setq buf-end (- buf-end src-start)) (cond ((null new-font) (setq stop-p t)) ((integerp new-font) (incf width (the int32 new-font)))) (let (w a d l r) (if (or (font-char-infos-internal font) (font-local-only-p font)) ;; Calculate text extents locally (progn (multiple-value-setq (w a d l r) (text-extents-local font wbuf 0 buf-end nil)) (setq font-ascent (the int16 (font-ascent font)) font-descent (the int16 (font-descent font)) font-direction (font-direction font))) ;; Let the server calculate text extents (multiple-value-setq (w a d l r font-ascent font-descent font-direction) (text-extents-server font wbuf 0 buf-end))) (incf width (the int32 w)) (cond ((index= src-start start) (setq left-bearing (the int32 l)) (setq right-bearing (the int32 r)) (setq ascent (the int16 a)) (setq descent (the int16 d))) (t (setq left-bearing (the int32 (min left-bearing (the int32 l)))) (setq right-bearing (the int32 (max right-bearing (the int32 r)))) (setq ascent (the int16 (max ascent (the int16 a)))) (setq descent (the int16 (max descent (the int16 d))))))) (when (type? new-font 'font) (setq font new-font)) (setq overall-ascent (the int16 (max overall-ascent font-ascent))) (setq overall-descent (the int16 (max overall-descent font-descent))) (case overall-direction (:unknown (setq overall-direction font-direction)) (:left-to-right (unless (eq font-direction :left-to-right) (setq overall-direction nil))) (:right-to-left (unless (eq font-direction :right-to-left) (setq overall-direction nil)))))) (values width ascent descent left-bearing right-bearing overall-ascent overall-descent overall-direction next-start))) (defun text-width (font sequence &key (start 0) end translate) ;; Translate will always be called with a 16-bit dst buffer. (declare (type sequence sequence) (type (or font gcontext) font) (type array-index start) (type (or null array-index) end)) (declare (type (or null translation-function) translate) #+clx-ansi-common-lisp (dynamic-extent translate) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg #+Genera * #-Genera translate)) (declare (clx-values integer (or null integer))) (when (type? font 'gcontext) (force-gcontext-changes font) (setq font (gcontext-font font t))) (check-type font font) (let* ((width 0) (next-start nil) (display (font-display font))) (declare (type int32 width) (type (or null array-index) next-start) (type display display)) (with-display (display) (do* ((wbuf (display-tbuf16 display)) (src-end (or end (length sequence))) (src-start start (index+ src-start buf-end)) (end (index-min src-end (index+ src-start +buffer-text16-size+)) (index-min src-end (index+ src-start +buffer-text16-size+))) (buf-end 0) (new-font) (stop-p nil)) ((or stop-p (index>= src-start src-end)) (when (index< src-start src-end) (setq next-start src-start))) (declare (type buffer-text16 wbuf) (type array-index src-start src-end end buf-end) (type generalized-boolean stop-p)) ;; Translate the text (multiple-value-setq (buf-end new-font) (funcall (or translate #'translate-default) sequence src-start end font wbuf 0)) (setq buf-end (- buf-end src-start)) (cond ((null new-font) (setq stop-p t)) ((integerp new-font) (incf width (the int32 new-font)))) (incf width (if (or (font-char-infos-internal font) (font-local-only-p font)) (text-extents-local font wbuf 0 buf-end :width-only) (text-width-server font wbuf 0 buf-end))) (when (type? new-font 'font) (setq font new-font)))) (values width next-start))) (defun text-extents-server (font sequence start end) (declare (type font font) (type sequence sequence) (type array-index start end)) (declare (clx-values width ascent descent left right font-ascent font-descent direction)) (let ((display (font-display font)) (length (index- end start)) (font-id (font-id font))) (declare (type display display) (type array-index length) (type resource-id font-id)) (with-buffer-request-and-reply (display +x-querytextextents+ 28 :sizes (8 16 32)) (((data boolean) (oddp length)) (length (index+ (index-ceiling length 2) 2)) (resource-id font-id) ((sequence :format char2b :start start :end end :appending t) sequence)) (values (integer-get 16) (int16-get 12) (int16-get 14) (integer-get 20) (integer-get 24) (int16-get 8) (int16-get 10) (member8-get 1 :left-to-right :right-to-left))))) (defun text-width-server (font sequence start end) (declare (type (or font gcontext) font) (type sequence sequence) (type array-index start end)) (declare (clx-values integer)) (let ((display (font-display font)) (length (index- end start)) (font-id (font-id font))) (declare (type display display) (type array-index length) (type resource-id font-id)) (with-buffer-request-and-reply (display +x-querytextextents+ 28 :sizes 32) (((data boolean) (oddp length)) (length (index+ (index-ceiling length 2) 2)) (resource-id font-id) ((sequence :format char2b :start start :end end :appending t) sequence)) (values (integer-get 16))))) (defun text-extents-local (font sequence start end width-only-p) (declare (type font font) (type sequence sequence) (type integer start end) (type generalized-boolean width-only-p)) (declare (clx-values width ascent descent overall-left overall-right)) (let* ((char-infos (font-char-infos font)) (font-info (font-font-info font))) (declare (type font-info font-info)) (declare (type (simple-array int16 (*)) char-infos)) (if (zerop (length char-infos)) ;; Fixed width font (let* ((font-width (max-char-width font)) (font-ascent (max-char-ascent font)) (font-descent (max-char-descent font)) (width (* (index- end start) font-width))) (declare (type int16 font-width font-ascent font-descent) (type int32 width)) (if width-only-p width (values width font-ascent font-descent (max-char-left-bearing font) (+ width (- font-width) (max-char-right-bearing font))))) ;; Variable-width font (let* ((first-col (font-info-min-byte2 font-info)) (num-cols (1+ (- (font-info-max-byte2 font-info) first-col))) (first-row (font-info-min-byte1 font-info)) (last-row (font-info-max-byte1 font-info)) (num-rows (1+ (- last-row first-row)))) (declare (type card8 first-col first-row last-row) (type card16 num-cols num-rows)) (if (or (plusp first-row) (plusp last-row)) ;; Matrix (16 bit) font (macrolet ((char-info-elt (sequence elt) `(let* ((char (the card16 (elt ,sequence ,elt))) (row (- (ash char -8) first-row)) (col (- (logand char #xff) first-col))) (declare (type card16 char) (type int16 row col)) (if (and (< -1 row num-rows) (< -1 col num-cols)) (index* 6 (index+ (index* row num-cols) col)) -1)))) (if width-only-p (do ((i start (index1+ i)) (width 0)) ((index>= i end) width) (declare (type array-index i) (type int32 width)) (let ((n (char-info-elt sequence i))) (declare (type fixnum n)) (unless (minusp n) ;; Ignore characters not in the font (incf width (the int16 (aref char-infos (index+ 2 n))))))) ;; extents (do ((i start (index1+ i)) (width 0) (ascent #x-7fff) (descent #x-7fff) (left #x7fff) (right #x-7fff)) ((index>= i end) (values width ascent descent left right)) (declare (type array-index i) (type int16 ascent descent) (type int32 width left right)) (let ((n (char-info-elt sequence i))) (declare (type fixnum n)) (unless (minusp n) ;; Ignore characters not in the font (setq left (min left (+ width (aref char-infos n)))) (setq right (max right (+ width (aref char-infos (index1+ n))))) (incf width (aref char-infos (index+ 2 n))) (setq ascent (max ascent (aref char-infos (index+ 3 n)))) (setq descent (max descent (aref char-infos (index+ 4 n))))))))) ;; Non-matrix (8 bit) font ;; The code here is identical to the above, except for the following macro: (macrolet ((char-info-elt (sequence elt) `(let ((col (- (the card16 (elt ,sequence ,elt)) first-col))) (declare (type int16 col)) (if (< -1 col num-cols) (index* 6 col) -1)))) (if width-only-p (do ((i start (index1+ i)) (width 0)) ((index>= i end) width) (declare (type array-index i) (type int32 width)) (let ((n (char-info-elt sequence i))) (declare (type fixnum n)) (unless (minusp n) ;; Ignore characters not in the font (incf width (the int16 (aref char-infos (index+ 2 n))))))) ;; extents (do ((i start (index1+ i)) (width 0) (ascent #x-7fff) (descent #x-7fff) (left #x7fff) (right #x-7fff)) ((index>= i end) (values width ascent descent left right)) (declare (type array-index i) (type int16 ascent descent) (type int32 width left right)) (let ((n (char-info-elt sequence i))) (declare (type fixnum n)) (unless (minusp n) ;; Ignore characters not in the font (setq left (min left (+ width (aref char-infos n)))) (setq right (max right (+ width (aref char-infos (index1+ n))))) (incf width (aref char-infos (index+ 2 n))) (setq ascent (max ascent (aref char-infos (index+ 3 n)))) (setq descent (max descent (aref char-infos (index+ 4 n))))) )))) ))))) ;;----------------------------------------------------------------------------- ;; This controls the element size of the dst buffer given to translate. If ;; :default is specified, the size will be based on the current font, if known, ;; and otherwise 16 will be used. [An alternative would be to pass the buffer ;; size to translate, and allow it to return the desired size if it doesn't ;; like the current size. The problem is that the protocol doesn't allow ;; switching within a single request, so to allow switching would require ;; knowing the width of text, which isn't necessarily known. We could call ;; text-width to compute it, but perhaps that is doing too many favors?] [An ;; additional possibility is to allow an index-size of :two-byte, in which case ;; translate would be given a double-length 8-bit array, and translate would be ;; expected to store first-byte/second-byte instead of 16-bit integers.] (deftype index-size () '(member :default 8 16)) ;; In the functions below, if width is specified, it is assumed to be the total ;; pixel width of whatever string of glyphs is actually drawn. Specifying ;; width will allow for appending the output of subsequent calls to the same ;; protocol request, provided gcontext has not been modified in the interim. ;; If width is not specified, appending of subsequent output might not occur ;; (unless translate returns the width). Specifying width is simply a hint, ;; for performance. (defun draw-glyph (drawable gcontext x y elt &key translate width (size :default)) ;; Returns true if elt is output, nil if translate refuses to output it. ;; Second result is width, if known. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type (or null int32) width) (type index-size size)) (declare (type (or null translation-function) translate) #+clx-ansi-common-lisp (dynamic-extent translate) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg #+Genera * #-Genera translate)) (declare (clx-values generalized-boolean (or null int32))) (let* ((display (gcontext-display gcontext)) (result t) (opcode +x-polytext8+)) (declare (type display display)) (let ((vector (allocate-gcontext-state))) (declare (type gcontext-state vector)) (setf (aref vector 0) elt) (multiple-value-bind (new-start new-font translate-width) (funcall (or translate #'translate-default) vector 0 1 (gcontext-font gcontext nil) vector 1) ;; Allow translate to set a new font (when (type? new-font 'font) (setf (gcontext-font gcontext) new-font) (multiple-value-setq (new-start new-font translate-width) (funcall translate vector 0 1 new-font vector 1))) ;; If new-start is zero, translate refuses to output it (setq result (index-plusp new-start) elt (aref vector 1)) (deallocate-gcontext-state vector) (when translate-width (setq width translate-width)))) (when result (when (eql size 16) (setq opcode +x-polytext16+) (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt)))) (with-buffer-request (display opcode :gc-force gcontext) (drawable drawable) (gcontext gcontext) (int16 x y) (card8 1 0) (card8 (ldb (byte 8 0) elt)) (card8 (ldb (byte 8 8) elt))) (values t width)))) (defun draw-glyphs (drawable gcontext x y sequence &key (start 0) end translate width (size :default)) ;; First result is new start, if end was not reached. Second result is ;; overall width, if known. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type array-index start) (type sequence sequence) (type (or null array-index) end) (type (or null int32) width) (type index-size size)) (declare (type (or null translation-function) translate) #+clx-ansi-common-lisp (dynamic-extent translate) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg #+Genera * #-Genera translate)) (declare (clx-values (or null array-index) (or null int32))) (unless end (setq end (length sequence))) (ecase size ((:default 8) (draw-glyphs8 drawable gcontext x y sequence start end (or translate #'translate-default) width)) (16 (draw-glyphs16 drawable gcontext x y sequence start end (or translate #'translate-default) width)))) (defun draw-glyphs8 (drawable gcontext x y sequence start end translate width) ;; First result is new start, if end was not reached. Second result is ;; overall width, if known. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type array-index start) (type sequence sequence) (type (or null array-index) end) (type (or null int32) width)) (declare (clx-values (or null array-index) (or null int32))) (declare (type translation-function translate) #+clx-ansi-common-lisp (dynamic-extent translate) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg translate)) (let* ((src-start start) (src-end (or end (length sequence))) (next-start nil) (length (index- src-end src-start)) (request-length (* length 2)) ; Leave lots of room for font shifts. (display (gcontext-display gcontext)) (font (gcontext-font gcontext nil))) (declare (type array-index src-start src-end length) (type (or null array-index) next-start) (type display display)) (with-buffer-request (display +x-polytext8+ :gc-force gcontext :length request-length) (drawable drawable) (gcontext gcontext) (int16 x y) (progn ;; Don't let any flushes happen since we manually set the request ;; length when we're done. (with-buffer-flush-inhibited (display) (do* ((boffset (index+ buffer-boffset 16)) (src-chunk 0) (dst-chunk 0) (offset 0) (overall-width 0) (stop-p nil)) ((or stop-p (zerop length)) ;; Ensure terminated with zero bytes (do ((end (the array-index (lround boffset)))) ((index>= boffset end)) (setf (aref buffer-bbuf boffset) 0) (index-incf boffset)) (length-put 2 (index-ash (index- boffset buffer-boffset) -2)) (setf (buffer-boffset display) boffset) (unless (index-zerop length) (setq next-start src-start)) (when overall-width (setq width overall-width))) (declare (type array-index src-chunk dst-chunk offset) (type (or null int32) overall-width) (type generalized-boolean stop-p)) (setq src-chunk (index-min length *max-string-size*)) (multiple-value-bind (new-start new-font translated-width) (funcall translate sequence src-start (index+ src-start src-chunk) font buffer-bbuf (index+ boffset 2)) (setq dst-chunk (index- new-start src-start) length (index- length dst-chunk) src-start new-start) (if translated-width (when overall-width (incf overall-width translated-width)) (setq overall-width nil)) (when (index-plusp dst-chunk) (setf (aref buffer-bbuf boffset) dst-chunk) (setf (aref buffer-bbuf (index+ boffset 1)) offset) (incf boffset (index+ dst-chunk 2))) (setq offset 0) (cond ((null new-font) ;; Don't stop if translate copied whole chunk (unless (index= src-chunk dst-chunk) (setq stop-p t))) ((integerp new-font) (setq offset new-font)) ((type? new-font 'font) (setq font new-font) (let ((font-id (font-id font)) (buffer-boffset boffset)) (declare (type resource-id font-id) (type array-index buffer-boffset)) ;; This changes the gcontext font in the server ;; Update the gcontext cache (both local and server state) (let ((local-state (gcontext-local-state gcontext)) (server-state (gcontext-server-state gcontext))) (declare (type gcontext-state local-state server-state)) (setf (gcontext-internal-font-obj server-state) font (gcontext-internal-font server-state) font-id) (without-interrupts (setf (gcontext-internal-font-obj local-state) font (gcontext-internal-font local-state) font-id))) (card8-put 0 #xff) (card8-put 1 (ldb (byte 8 24) font-id)) (card8-put 2 (ldb (byte 8 16) font-id)) (card8-put 3 (ldb (byte 8 8) font-id)) (card8-put 4 (ldb (byte 8 0) font-id))) (index-incf boffset 5))) ))))) (values next-start width))) ;; NOTE: After the first font change by the TRANSLATE function, characters are no-longer ;; on 16bit boundaries and this function garbles the bytes. (defun draw-glyphs16 (drawable gcontext x y sequence start end translate width) ;; First result is new start, if end was not reached. Second result is ;; overall width, if known. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type array-index start) (type sequence sequence) (type (or null array-index) end) (type (or null int32) width)) (declare (clx-values (or null array-index) (or null int32))) (declare (type translation-function translate) #+clx-ansi-common-lisp (dynamic-extent translate) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg translate)) (let* ((src-start start) (src-end (or end (length sequence))) (next-start nil) (length (index- src-end src-start)) (request-length (* length 3)) ; Leave lots of room for font shifts. (display (gcontext-display gcontext)) (font (gcontext-font gcontext nil)) (buffer (display-tbuf16 display))) (declare (type array-index src-start src-end length) (type (or null array-index) next-start) (type display display) (type buffer-text16 buffer)) (with-buffer-request (display +x-polytext16+ :gc-force gcontext :length request-length) (drawable drawable) (gcontext gcontext) (int16 x y) (progn ;; Don't let any flushes happen since we manually set the request ;; length when we're done. (with-buffer-flush-inhibited (display) (do* ((boffset (index+ buffer-boffset 16)) (src-chunk 0) (dst-chunk 0) (offset 0) (overall-width 0) (stop-p nil)) ((or stop-p (zerop length)) ;; Ensure terminated with zero bytes (do ((end (lround boffset))) ((index>= boffset end)) (setf (aref buffer-bbuf boffset) 0) (index-incf boffset)) (length-put 2 (index-ash (index- boffset buffer-boffset) -2)) (setf (buffer-boffset display) boffset) (unless (zerop length) (setq next-start src-start)) (when overall-width (setq width overall-width))) (declare (type array-index boffset src-chunk dst-chunk offset) (type (or null int32) overall-width) (type generalized-boolean stop-p)) (setq src-chunk (index-min length *max-string-size*)) (multiple-value-bind (new-start new-font translated-width) (funcall translate sequence src-start (index+ src-start src-chunk) font buffer 0) (setq dst-chunk (index- new-start src-start) length (index- length dst-chunk) src-start new-start) (write-sequence-char2b display (index+ boffset 2) buffer 0 dst-chunk) (if translated-width (when overall-width (incf overall-width translated-width)) (setq overall-width nil)) (when (index-plusp dst-chunk) (setf (aref buffer-bbuf boffset) dst-chunk) (setf (aref buffer-bbuf (index+ boffset 1)) offset) (index-incf boffset (index+ dst-chunk dst-chunk 2))) (setq offset 0) (cond ((null new-font) ;; Don't stop if translate copied whole chunk (unless (index= src-chunk dst-chunk) (setq stop-p t))) ((integerp new-font) (setq offset new-font)) ((type? new-font 'font) (setq font new-font) (let ((font-id (font-id font)) (buffer-boffset boffset)) (declare (type resource-id font-id) (type array-index buffer-boffset)) ;; This changes the gcontext font in the SERVER ;; Update the gcontext cache (both local and server state) (let ((local-state (gcontext-local-state gcontext)) (server-state (gcontext-server-state gcontext))) (declare (type gcontext-state local-state server-state)) (setf (gcontext-internal-font-obj server-state) font (gcontext-internal-font server-state) font-id) (without-interrupts (setf (gcontext-internal-font-obj local-state) font (gcontext-internal-font local-state) font-id))) (card8-put 0 #xff) (card8-put 1 (ldb (byte 8 24) font-id)) (card8-put 2 (ldb (byte 8 16) font-id)) (card8-put 3 (ldb (byte 8 8) font-id)) (card8-put 4 (ldb (byte 8 0) font-id))) (index-incf boffset 5))) ))))) (values next-start width))) (defun draw-image-glyph (drawable gcontext x y elt &key translate width (size :default)) ;; Returns true if elt is output, nil if translate refuses to output it. ;; Second result is overall width, if known. An initial font change is ;; allowed from translate. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type (or null int32) width) (type index-size size)) (declare (type (or null translation-function) translate) #+clx-ansi-common-lisp (dynamic-extent translate) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg #+Genera * #-Genera translate)) (declare (clx-values generalized-boolean (or null int32))) (let* ((display (gcontext-display gcontext)) (result t) (opcode +x-imagetext8+)) (declare (type display display)) (let ((vector (allocate-gcontext-state))) (declare (type gcontext-state vector)) (setf (aref vector 0) elt) (multiple-value-bind (new-start new-font translate-width) (funcall (or translate #'translate-default) vector 0 1 (gcontext-font gcontext nil) vector 1) ;; Allow translate to set a new font (when (type? new-font 'font) (setf (gcontext-font gcontext) new-font) (multiple-value-setq (new-start new-font translate-width) (funcall translate vector 0 1 new-font vector 1))) ;; If new-start is zero, translate refuses to output it (setq result (index-plusp new-start) elt (aref vector 1)) (deallocate-gcontext-state vector) (when translate-width (setq width translate-width)))) (when result (when (eql size 16) (setq opcode +x-imagetext16+) (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt)))) (with-buffer-request (display opcode :gc-force gcontext) (drawable drawable) (gcontext gcontext) (data 1) ;; 1 character (int16 x y) (card8 (ldb (byte 8 0) elt)) (card8 (ldb (byte 8 8) elt))) (values t width)))) (defun draw-image-glyphs (drawable gcontext x y sequence &key (start 0) end translate width (size :default)) ;; An initial font change is allowed from translate, but any subsequent font ;; change or horizontal motion will cause termination (because the protocol ;; doesn't support chaining). [Alternatively, font changes could be accepted ;; as long as they are accompanied with a width return value, or always ;; accept font changes and call text-width as required. However, horizontal ;; motion can't really be accepted, due to semantics.] First result is new ;; start, if end was not reached. Second result is overall width, if known. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type array-index start) (type (or null array-index) end) (type sequence sequence) (type (or null int32) width) (type index-size size)) (declare (type (or null translation-function) translate) #+clx-ansi-common-lisp (dynamic-extent translate) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg #+Genera * #-Genera translate)) (declare (clx-values (or null array-index) (or null int32))) (setf end (index-min (index+ start 255) (or end (length sequence)))) (ecase size ((:default 8) (draw-image-glyphs8 drawable gcontext x y sequence start end translate width)) (16 (draw-image-glyphs16 drawable gcontext x y sequence start end translate width)))) (defun draw-image-glyphs8 (drawable gcontext x y sequence start end translate width) ;; An initial font change is allowed from translate, but any subsequent font ;; change or horizontal motion will cause termination (because the protocol ;; doesn't support chaining). [Alternatively, font changes could be accepted ;; as long as they are accompanied with a width return value, or always ;; accept font changes and call text-width as required. However, horizontal ;; motion can't really be accepted, due to semantics.] First result is new ;; start, if end was not reached. Second result is overall width, if known. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type array-index start) (type sequence sequence) (type (or null array-index) end) (type (or null int32) width)) (declare (type (or null translation-function) translate) #+clx-ansi-common-lisp (dynamic-extent translate) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg translate)) (declare (clx-values (or null array-index) (or null int32))) (do* ((display (gcontext-display gcontext)) (length (index- end start)) (font (gcontext-font gcontext nil)) (font-change nil) (new-start) (translated-width) (chunk)) (nil) ;; forever (declare (type display display) (type array-index length) (type (or null array-index) new-start chunk)) (when font-change (setf (gcontext-font gcontext) font)) (block change-font (with-buffer-request (display +x-imagetext8+ :gc-force gcontext :length length) (drawable drawable) (gcontext gcontext) (int16 x y) (progn ;; Don't let any flushes happen since we manually set the request ;; length when we're done. (with-buffer-flush-inhibited (display) ;; Translate the sequence into the buffer (multiple-value-setq (new-start font translated-width) (funcall (or translate #'translate-default) sequence start end font buffer-bbuf (index+ buffer-boffset 16))) ;; Number of glyphs translated (setq chunk (index- new-start start)) ;; Check for initial font change (when (and (index-zerop chunk) (type? font 'font)) (setq font-change t) ;; Loop around changing font (return-from change-font)) ;; Quit when nothing translated (when (index-zerop chunk) (return-from draw-image-glyphs8 new-start)) ;; Update buffer pointers (data-put 1 chunk) (let ((blen (lround (index+ 16 chunk)))) (length-put 2 (index-ash blen -2)) (setf (buffer-boffset display) (index+ buffer-boffset blen)))))) ;; Normal exit (return-from draw-image-glyphs8 (values (if (index= chunk length) nil new-start) (or translated-width width)))))) (defun draw-image-glyphs16 (drawable gcontext x y sequence start end translate width) ;; An initial font change is allowed from translate, but any subsequent font ;; change or horizontal motion will cause termination (because the protocol ;; doesn't support chaining). [Alternatively, font changes could be accepted ;; as long as they are accompanied with a width return value, or always ;; accept font changes and call text-width as required. However, horizontal ;; motion can't really be accepted, due to semantics.] First result is new ;; start, if end was not reached. Second result is overall width, if known. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type array-index start) (type sequence sequence) (type (or null array-index) end) (type (or null int32) width)) (declare (type (or null translation-function) translate) #+clx-ansi-common-lisp (dynamic-extent translate) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg translate)) (declare (clx-values (or null array-index) (or null int32))) (do* ((display (gcontext-display gcontext)) (length (index- end start)) (font (gcontext-font gcontext nil)) (font-change nil) (new-start) (translated-width) (chunk) (buffer (buffer-tbuf16 display))) (nil) ;; forever (declare (type display display) (type array-index length) (type (or null array-index) new-start chunk) (type buffer-text16 buffer)) (when font-change (setf (gcontext-font gcontext) font)) (block change-font (with-buffer-request (display +x-imagetext16+ :gc-force gcontext :length length) (drawable drawable) (gcontext gcontext) (int16 x y) (progn ;; Don't let any flushes happen since we manually set the request ;; length when we're done. (with-buffer-flush-inhibited (display) ;; Translate the sequence into the buffer (multiple-value-setq (new-start font translated-width) (funcall (or translate #'translate-default) sequence start end font buffer 0)) ;; Number of glyphs translated (setq chunk (index- new-start start)) ;; Check for initial font change (when (and (index-zerop chunk) (type? font 'font)) (setq font-change t) ;; Loop around changing font (return-from change-font)) ;; Quit when nothing translated (when (index-zerop chunk) (return-from draw-image-glyphs16 new-start)) (write-sequence-char2b display (index+ buffer-boffset 16) buffer 0 chunk) ;; Update buffer pointers (data-put 1 chunk) (let ((blen (lround (index+ 16 (index-ash chunk 1))))) (length-put 2 (index-ash blen -2)) (setf (buffer-boffset display) (index+ buffer-boffset blen)))))) ;; Normal exit (return-from draw-image-glyphs16 (values (if (index= chunk length) nil new-start) (or translated-width width)))))) ;;----------------------------------------------------------------------------- (defun display-keycode-range (display) (declare (type display display)) (declare (clx-values min max)) (values (display-min-keycode display) (display-max-keycode display))) ;; Should this signal device-busy like the pointer-mapping setf, and return a ;; generalized-boolean instead (true for success)? Alternatively, should the ;; pointer-mapping setf be changed to set-pointer-mapping with a (member ;; :success :busy) result? (defun set-modifier-mapping (display &key shift lock control mod1 mod2 mod3 mod4 mod5) ;; Setf ought to allow multiple values. (declare (type display display) (type sequence shift lock control mod1 mod2 mod3 mod4 mod5)) (declare (clx-values (member :success :busy :failed))) (let* ((keycodes-per-modifier (index-max (length shift) (length lock) (length control) (length mod1) (length mod2) (length mod3) (length mod4) (length mod5))) (data (make-array (index* 8 keycodes-per-modifier) :element-type 'card8 :initial-element 0))) (replace data shift) (replace data lock :start1 keycodes-per-modifier) (replace data control :start1 (index* 2 keycodes-per-modifier)) (replace data mod1 :start1 (index* 3 keycodes-per-modifier)) (replace data mod2 :start1 (index* 4 keycodes-per-modifier)) (replace data mod3 :start1 (index* 5 keycodes-per-modifier)) (replace data mod4 :start1 (index* 6 keycodes-per-modifier)) (replace data mod5 :start1 (index* 7 keycodes-per-modifier)) (with-buffer-request-and-reply (display +x-setmodifiermapping+ 4 :sizes 8) ((data keycodes-per-modifier) ((sequence :format card8) data)) (values (member8-get 1 :success :busy :failed))))) (defun modifier-mapping (display) ;; each value is a list of integers (declare (type display display)) (declare (clx-values shift lock control mod1 mod2 mod3 mod4 mod5)) (let ((lists nil)) (with-buffer-request-and-reply (display +x-getmodifiermapping+ nil :sizes 8) () (do* ((keycodes-per-modifier (card8-get 1)) (advance-by +replysize+ keycodes-per-modifier) (keys nil nil) (i 0 (index+ i 1))) ((index= i 8)) (advance-buffer-offset advance-by) (dotimes (j keycodes-per-modifier) (let ((key (read-card8 j))) (unless (zerop key) (push key keys)))) (push (nreverse keys) lists))) (values-list (nreverse lists)))) ;; Either we will want lots of defconstants for well-known values, or perhaps ;; an integer-to-keyword translation function for well-known values. (defun change-keyboard-mapping (display keysyms &key (start 0) end (first-keycode start)) ;; start/end give subrange of keysyms ;; first-keycode is the first-keycode to store at (declare (type display display) (type array-index start) (type card8 first-keycode) (type (or null array-index) end) (type (array * (* *)) keysyms)) (let* ((keycode-end (or end (array-dimension keysyms 0))) (keysyms-per-keycode (array-dimension keysyms 1)) (length (index- keycode-end start)) (size (index* length keysyms-per-keycode)) (request-length (index+ size 2))) (declare (type array-index keycode-end keysyms-per-keycode length request-length)) (with-buffer-request (display +x-setkeyboardmapping+ :length (index-ash request-length 2) :sizes (32)) (data length) (length request-length) (card8 first-keycode keysyms-per-keycode) (progn (do ((limit (index-ash (buffer-size display) -2)) (w (index+ 2 (index-ash buffer-boffset -2))) (i start (index+ i 1))) ((index>= i keycode-end) (setf (buffer-boffset display) (index-ash w 2))) (declare (type array-index limit w i)) (when (index> w limit) (buffer-flush display) (setq w (index-ash (buffer-boffset display) -2))) (do ((j 0 (index+ j 1))) ((index>= j keysyms-per-keycode)) (declare (type array-index j)) (card29-put (index* w 4) (aref keysyms i j)) (index-incf w))))))) (defun keyboard-mapping (display &key first-keycode start end data) ;; First-keycode specifies which keycode to start at (defaults to min-keycode). ;; Start specifies where (in result) to put first-keycode. (defaults to first-keycode) ;; (- end start) is the number of keycodes to get. (End defaults to (1+ max-keycode)). ;; If DATA is specified, the results are put there. (declare (type display display) (type (or null card8) first-keycode) (type (or null array-index) start end) (type (or null (array * (* *))) data)) (declare (clx-values (array * (* *)))) (unless first-keycode (setq first-keycode (display-min-keycode display))) (unless start (setq start first-keycode)) (unless end (setq end (1+ (display-max-keycode display)))) (with-buffer-request-and-reply (display +x-getkeyboardmapping+ nil :sizes (8 32)) ((card8 first-keycode (index- end start))) (do* ((keysyms-per-keycode (card8-get 1)) (bytes-per-keycode (* keysyms-per-keycode 4)) (advance-by +replysize+ bytes-per-keycode) (keycode-count (floor (card32-get 4) keysyms-per-keycode) (index- keycode-count 1)) (result (if (and (arrayp data) (= (array-rank data) 2) (>= (array-dimension data 0) (index+ start keycode-count)) (>= (array-dimension data 1) keysyms-per-keycode)) data (make-array `(,(index+ start keycode-count) ,keysyms-per-keycode) :element-type 'keysym :initial-element 0))) (i start (1+ i))) ((zerop keycode-count) (setq data result)) (advance-buffer-offset advance-by) (dotimes (j keysyms-per-keycode) (setf (aref result i j) (card29-get (* j 4)))))) data) cl-clx-sbcl-0.7.4.20160323.orig/dependent.lisp0000644000175000017500000041740112715665272016470 0ustar pdmpdm;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- ;; This file contains some of the system dependent code for CLX ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (in-package :xlib) (proclaim '(declaration array-register)) #+cmu (setf (getf ext:*herald-items* :xlib) `(" CLX X Library " ,*version*)) ;;; The size of the output buffer. Must be a multiple of 4. (defparameter *output-buffer-size* 8192) #+explorer (zwei:define-indentation event-case (1 1)) ;;; Number of seconds to wait for a reply to a server request (defparameter *reply-timeout* nil) #-(or clx-overlapping-arrays (not clx-little-endian)) (progn (defconstant +word-0+ 0) (defconstant +word-1+ 1) (defconstant +long-0+ 0) (defconstant +long-1+ 1) (defconstant +long-2+ 2) (defconstant +long-3+ 3)) #-(or clx-overlapping-arrays clx-little-endian) (progn (defconstant +word-0+ 1) (defconstant +word-1+ 0) (defconstant +long-0+ 3) (defconstant +long-1+ 2) (defconstant +long-2+ 1) (defconstant +long-3+ 0)) ;;; Set some compiler-options for often used code (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +buffer-speed+ #+clx-debugging 1 #-clx-debugging 3 "Speed compiler option for buffer code.") (defconstant +buffer-safety+ #+clx-debugging 3 #-clx-debugging 0 "Safety compiler option for buffer code.") (defconstant +buffer-debug+ #+clx-debugging 2 #-clx-debugging 1 "Debug compiler option for buffer code>") (defun declare-bufmac () `(declare (optimize (speed ,+buffer-speed+) (safety ,+buffer-safety+) (debug ,+buffer-debug+)))) ;; It's my impression that in lucid there's some way to make a ;; declaration called fast-entry or something that causes a function ;; to not do some checking on args. Sadly, we have no lucid manuals ;; here. If such a declaration is available, it would be a good ;; idea to make it here when +buffer-speed+ is 3 and +buffer-safety+ ;; is 0. (defun declare-buffun () `(declare (optimize (speed ,+buffer-speed+) (safety ,+buffer-safety+) (debug ,+buffer-debug+))))) (declaim (inline card8->int8 int8->card8 card16->int16 int16->card16 card32->int32 int32->card32)) #-Genera (progn (defun card8->int8 (x) (declare (type card8 x)) (declare (clx-values int8)) #.(declare-buffun) (the int8 (if (logbitp 7 x) (the int8 (- x #x100)) x))) (defun int8->card8 (x) (declare (type int8 x)) (declare (clx-values card8)) #.(declare-buffun) (the card8 (ldb (byte 8 0) x))) (defun card16->int16 (x) (declare (type card16 x)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (if (logbitp 15 x) (the int16 (- x #x10000)) x))) (defun int16->card16 (x) (declare (type int16 x)) (declare (clx-values card16)) #.(declare-buffun) (the card16 (ldb (byte 16 0) x))) (defun card32->int32 (x) (declare (type card32 x)) (declare (clx-values int32)) #.(declare-buffun) (the int32 (if (logbitp 31 x) (the int32 (- x #x100000000)) x))) (defun int32->card32 (x) (declare (type int32 x)) (declare (clx-values card32)) #.(declare-buffun) (the card32 (ldb (byte 32 0) x))) ) #+Genera (progn (defun card8->int8 (x) (declare lt:(side-effects simple reducible)) (if (logbitp 7 x) (- x #x100) x)) (defun int8->card8 (x) (declare lt:(side-effects simple reducible)) (ldb (byte 8 0) x)) (defun card16->int16 (x) (declare lt:(side-effects simple reducible)) (if (logbitp 15 x) (- x #x10000) x)) (defun int16->card16 (x) (declare lt:(side-effects simple reducible)) (ldb (byte 16 0) x)) (defun card32->int32 (x) (declare lt:(side-effects simple reducible)) (sys:%logldb (byte 32 0) x)) (defun int32->card32 (x) (declare lt:(side-effects simple reducible)) (ldb (byte 32 0) x)) ) (declaim (inline aref-card8 aset-card8 aref-int8 aset-int8)) #-(or Genera lcl3.0 excl) (progn (defun aref-card8 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card8)) #.(declare-buffun) (the card8 (aref a i))) (defun aset-card8 (v a i) (declare (type card8 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a i) v)) (defun aref-int8 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int8)) #.(declare-buffun) (card8->int8 (aref a i))) (defun aset-int8 (v a i) (declare (type int8 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a i) (int8->card8 v))) ) #+Genera (progn (defun aref-card8 (a i) (aref a i)) (defun aset-card8 (v a i) (zl:aset v a i)) (defun aref-int8 (a i) (card8->int8 (aref a i))) (defun aset-int8 (v a i) (zl:aset (int8->card8 v) a i)) ) #+(or excl lcl3.0 clx-overlapping-arrays) (declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29 aset-card16 aset-int16 aset-card32 aset-int32 aset-card29)) #+(and clx-overlapping-arrays Genera) (progn (defun aref-card16 (a i) (aref a i)) (defun aset-card16 (v a i) (zl:aset v a i)) (defun aref-int16 (a i) (card16->int16 (aref a i))) (defun aset-int16 (v a i) (zl:aset (int16->card16 v) a i) v) (defun aref-card32 (a i) (int32->card32 (aref a i))) (defun aset-card32 (v a i) (zl:aset (card32->int32 v) a i)) (defun aref-int32 (a i) (aref a i)) (defun aset-int32 (v a i) (zl:aset v a i)) (defun aref-card29 (a i) (aref a i)) (defun aset-card29 (v a i) (zl:aset v a i)) ) #+(and clx-overlapping-arrays (not Genera)) (progn (defun aref-card16 (a i) (aref a i)) (defun aset-card16 (v a i) (setf (aref a i) v)) (defun aref-int16 (a i) (card16->int16 (aref a i))) (defun aset-int16 (v a i) (setf (aref a i) (int16->card16 v)) v) (defun aref-card32 (a i) (aref a i)) (defun aset-card32 (v a i) (setf (aref a i) v)) (defun aref-int32 (a i) (card32->int32 (aref a i))) (defun aset-int32 (v a i) (setf (aref a i) (int32->card32 v)) v) (defun aref-card29 (a i) (aref a i)) (defun aset-card29 (v a i) (setf (aref a i) v)) ) #+excl (progn (defun aref-card8 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card8)) #.(declare-buffun) (the card8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :unsigned-byte))) (defun aset-card8 (v a i) (declare (type card8 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :unsigned-byte) v)) (defun aref-int8 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int8)) #.(declare-buffun) (the int8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :signed-byte))) (defun aset-int8 (v a i) (declare (type int8 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :signed-byte) v)) (defun aref-card16 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card16)) #.(declare-buffun) (the card16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :unsigned-word))) (defun aset-card16 (v a i) (declare (type card16 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :unsigned-word) v)) (defun aref-int16 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :signed-word))) (defun aset-int16 (v a i) (declare (type int16 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :signed-word) v)) (defun aref-card32 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card32)) #.(declare-buffun) (the card32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :unsigned-long))) (defun aset-card32 (v a i) (declare (type card32 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :unsigned-long) v)) (defun aref-int32 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int32)) #.(declare-buffun) (the int32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :signed-long))) (defun aset-int32 (v a i) (declare (type int32 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :signed-long) v)) (defun aref-card29 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card29)) #.(declare-buffun) (the card29 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :unsigned-long))) (defun aset-card29 (v a i) (declare (type card29 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :unsigned-long) v)) ) #+lcl3.0 (progn (defun aref-card8 (a i) (declare (type buffer-bytes a) (type array-index i) (clx-values card8)) #.(declare-buffun) (the card8 (lucid::%svref-8bit a i))) (defun aset-card8 (v a i) (declare (type card8 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (lucid::%svref-8bit a i) v)) (defun aref-int8 (a i) (declare (type buffer-bytes a) (type array-index i) (clx-values int8)) #.(declare-buffun) (the int8 (lucid::%svref-signed-8bit a i))) (defun aset-int8 (v a i) (declare (type int8 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (lucid::%svref-signed-8bit a i) v)) (defun aref-card16 (a i) (declare (type buffer-bytes a) (type array-index i) (clx-values card16)) #.(declare-buffun) (the card16 (lucid::%svref-16bit a (index-ash i -1)))) (defun aset-card16 (v a i) (declare (type card16 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (lucid::%svref-16bit a (index-ash i -1)) v)) (defun aref-int16 (a i) (declare (type buffer-bytes a) (type array-index i) (clx-values int16)) #.(declare-buffun) (the int16 (lucid::%svref-signed-16bit a (index-ash i -1)))) (defun aset-int16 (v a i) (declare (type int16 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (lucid::%svref-signed-16bit a (index-ash i -1)) v)) (defun aref-card32 (a i) (declare (type buffer-bytes a) (type array-index i) (clx-values card32)) #.(declare-buffun) (the card32 (lucid::%svref-32bit a (index-ash i -2)))) (defun aset-card32 (v a i) (declare (type card32 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (lucid::%svref-32bit a (index-ash i -2)) v)) (defun aref-int32 (a i) (declare (type buffer-bytes a) (type array-index i) (clx-values int32)) #.(declare-buffun) (the int32 (lucid::%svref-signed-32bit a (index-ash i -2)))) (defun aset-int32 (v a i) (declare (type int32 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (lucid::%svref-signed-32bit a (index-ash i -2)) v)) (defun aref-card29 (a i) (declare (type buffer-bytes a) (type array-index i) (clx-values card29)) #.(declare-buffun) (the card29 (lucid::%svref-32bit a (index-ash i -2)))) (defun aset-card29 (v a i) (declare (type card29 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (lucid::%svref-32bit a (index-ash i -2)) v)) ) #-(or excl lcl3.0 clx-overlapping-arrays) (progn (defun aref-card16 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card16)) #.(declare-buffun) (the card16 (logior (the card16 (ash (the card8 (aref a (index+ i +word-1+))) 8)) (the card8 (aref a (index+ i +word-0+)))))) (defun aset-card16 (v a i) (declare (type card16 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-int16 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (logior (the int16 (ash (the int8 (aref-int8 a (index+ i +word-1+))) 8)) (the card8 (aref a (index+ i +word-0+)))))) (defun aset-int16 (v a i) (declare (type int16 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-card32 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card32)) #.(declare-buffun) (the card32 (logior (the card32 (ash (the card8 (aref a (index+ i +long-3+))) 24)) (the card29 (ash (the card8 (aref a (index+ i +long-2+))) 16)) (the card16 (ash (the card8 (aref a (index+ i +long-1+))) 8)) (the card8 (aref a (index+ i +long-0+)))))) (defun aset-card32 (v a i) (declare (type card32 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-int32 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int32)) #.(declare-buffun) (the int32 (logior (the int32 (ash (the int8 (aref-int8 a (index+ i +long-3+))) 24)) (the card29 (ash (the card8 (aref a (index+ i +long-2+))) 16)) (the card16 (ash (the card8 (aref a (index+ i +long-1+))) 8)) (the card8 (aref a (index+ i +long-0+)))))) (defun aset-int32 (v a i) (declare (type int32 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-card29 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card29)) #.(declare-buffun) (the card29 (logior (the card29 (ash (the card8 (aref a (index+ i +long-3+))) 24)) (the card29 (ash (the card8 (aref a (index+ i +long-2+))) 16)) (the card16 (ash (the card8 (aref a (index+ i +long-1+))) 8)) (the card8 (aref a (index+ i +long-0+)))))) (defun aset-card29 (v a i) (declare (type card29 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) v) ) (defsetf aref-card8 (a i) (v) `(aset-card8 ,v ,a ,i)) (defsetf aref-int8 (a i) (v) `(aset-int8 ,v ,a ,i)) (defsetf aref-card16 (a i) (v) `(aset-card16 ,v ,a ,i)) (defsetf aref-int16 (a i) (v) `(aset-int16 ,v ,a ,i)) (defsetf aref-card32 (a i) (v) `(aset-card32 ,v ,a ,i)) (defsetf aref-int32 (a i) (v) `(aset-int32 ,v ,a ,i)) (defsetf aref-card29 (a i) (v) `(aset-card29 ,v ,a ,i)) ;;; Other random conversions (defun rgb-val->card16 (value) ;; Short floats are good enough (declare (type rgb-val value)) (declare (clx-values card16)) #.(declare-buffun) ;; Convert VALUE from float to card16 (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff))))) (defun card16->rgb-val (value) ;; Short floats are good enough (declare (type card16 value)) (declare (clx-values short-float)) #.(declare-buffun) ;; Convert VALUE from card16 to float (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff)))) (defun radians->int16 (value) ;; Short floats are good enough (declare (type angle value)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0))))) (defun int16->radians (value) ;; Short floats are good enough (declare (type int16 value)) (declare (clx-values short-float)) #.(declare-buffun) (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float)))) #+(or cmu sbcl clisp) (progn ;;; 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 protocol 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)))) ) ;;----------------------------------------------------------------------------- ;; Character transformation ;;----------------------------------------------------------------------------- ;;; This stuff transforms chars to ascii codes in card8's and back. ;;; You might have to hack it a little to get it to work for your machine. (declaim (inline char->card8 card8->char)) (macrolet ((char-translators () (let ((alist `(#-lispm ;; The normal ascii codes for the control characters. ,@`((#\Return . 13) (#\Linefeed . 10) (#\Rubout . 127) (#\Page . 12) (#\Tab . 9) (#\Backspace . 8) (#\Newline . 10) (#\Space . 32)) ;; One the lispm, #\Newline is #\Return, but we'd really like ;; #\Newline to translate to ascii code 10, so we swap the ;; Ascii codes for #\Return and #\Linefeed. We also provide ;; mappings from the counterparts of these control characters ;; so that the character mapping from the lisp machine ;; character set to ascii is invertible. #+lispm ,@`((#\Return . 10) (,(code-char 10) . ,(char-code #\Return)) (#\Linefeed . 13) (,(code-char 13) . ,(char-code #\Linefeed)) (#\Rubout . 127) (,(code-char 127) . ,(char-code #\Rubout)) (#\Page . 12) (,(code-char 12) . ,(char-code #\Page)) (#\Tab . 9) (,(code-char 9) . ,(char-code #\Tab)) (#\Backspace . 8) (,(code-char 8) . ,(char-code #\Backspace)) (#\Newline . 10) (,(code-char 10) . ,(char-code #\Newline)) (#\Space . 32) (,(code-char 32) . ,(char-code #\Space))) ;; The rest of the common lisp charater set with the normal ;; ascii codes for them. (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) (#\} . 125) (#\~ . 126)))) (cond ((dolist (pair alist nil) (when (not (= (char-code (car pair)) (cdr pair))) (return t))) `(progn (defconstant *char-to-card8-translation-table* ',(let ((array (make-array (let ((max-char-code 255)) (dolist (pair alist) (setq max-char-code (max max-char-code (char-code (car pair))))) (1+ max-char-code)) :element-type 'card8))) (dotimes (i (length array)) (setf (aref array i) (mod i 256))) (dolist (pair alist) (setf (aref array (char-code (car pair))) (cdr pair))) array)) (defconstant *card8-to-char-translation-table* ',(let ((array (make-array 256))) (dotimes (i (length array)) (setf (aref array i) (code-char i))) (dolist (pair alist) (setf (aref array (cdr pair)) (car pair))) array)) #-Genera (progn (defun char->card8 (char) (declare (type base-char char)) #.(declare-buffun) (the card8 (aref (the (simple-array card8 (*)) *char-to-card8-translation-table*) (the array-index (char-code char))))) (defun card8->char (card8) (declare (type card8 card8)) #.(declare-buffun) (the base-char (or (aref (the simple-vector *card8-to-char-translation-table*) card8) (error "Invalid CHAR code ~D." card8)))) ) #+Genera (progn (defun char->card8 (char) (declare lt:(side-effects reader reducible)) (aref *char-to-card8-translation-table* (char-code char))) (defun card8->char (card8) (declare lt:(side-effects reader reducible)) (aref *card8-to-char-translation-table* card8)) ) #-Minima (dotimes (i 256) (unless (= i (char->card8 (card8->char i))) (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" (list i (card8->char i) (char->card8 (card8->char i)))) (return nil))) #-Minima (dotimes (i (length *char-to-card8-translation-table*)) (let ((char (code-char i))) (unless (eql char (card8->char (char->card8 char))) (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S" (list char (char->card8 char) (card8->char (char->card8 char)))) (return nil)))))) (t `(progn (defun char->card8 (char) (declare (type base-char char)) #.(declare-buffun) (the card8 (char-code char))) (defun card8->char (card8) (declare (type card8 card8)) #.(declare-buffun) (the base-char (code-char card8))) )))))) (char-translators)) ;;----------------------------------------------------------------------------- ;; Process Locking ;; ;; Common-Lisp doesn't provide process locking primitives, so we define ;; our own here, based on Zetalisp primitives. Holding-Lock is very ;; similar to with-lock on The TI Explorer, and a little more efficient ;; than with-process-lock on a Symbolics. ;;----------------------------------------------------------------------------- ;;; MAKE-PROCESS-LOCK: Creating a process lock. #-(or LispM excl Minima sbcl (and cmu mp)) (defun make-process-lock (name) (declare (ignore name)) nil) #+excl (defun make-process-lock (name) (mp:make-process-lock :name name)) #+(and LispM (not Genera)) (defun make-process-lock (name) (vector nil name)) #+Genera (defun make-process-lock (name) (process:make-lock name :flavor 'clx-lock)) #+Minima (defun make-process-lock (name) (minima:make-lock name :recursive t)) #+(and cmu mp) (defun make-process-lock (name) (mp:make-lock name)) #+sbcl (defun make-process-lock (name) (sb-thread:make-mutex :name name)) ;;; HOLDING-LOCK: Execute a body of code with a lock held. ;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN ;;; passes its timeout to the holding-lock macro, so any timeout you want to ;;; work for event-listen you should do for holding-lock. ;; If you're not sharing DISPLAY objects within a multi-processing ;; shared-memory environment, this is sufficient #-(or lispm excl lcl3.0 Minima sbcl (and CMU mp) ) (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) (declare (ignore locator display whostate timeout)) `(progn ,@body)) ;;; HOLDING-LOCK for CMU Common Lisp. ;;; ;;; We are not multi-processing, but we use this macro to try to protect ;;; against re-entering request functions. This can happen if an interrupt ;;; occurs and the handler attempts to use X over the same display connection. ;;; This can happen if the GC hooks are used to notify the user over the same ;;; display connection. We inhibit GC notifications since display of them ;;; could cause recursive entry into CLX. ;;; #+(and CMU (not mp)) (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) `(let #+cmu((ext:*gc-verbose* nil) (ext:*gc-inhibit-hook* nil) (ext:*before-gc-hooks* nil) (ext:*after-gc-hooks* nil)) #+sbcl() ,locator ,display ,whostate ,timeout (system:without-interrupts (progn ,@body)))) ;;; HOLDING-LOCK for CMU Common Lisp with multi-processes. ;;; #+(and cmu mp) (defmacro holding-lock ((lock display &optional (whostate "CLX wait") &key timeout) &body body) (declare (ignore display)) `(mp:with-lock-held (,lock ,whostate ,@(and timeout `(:timeout ,timeout))) ,@body)) #+clisp (defmacro holding-lock ((lock display &optional (whostate "CLX wait") &key timeout) &body body) (declare (ignore lock display whostate timeout)) `(progn ,@body)) #+sbcl (defmacro holding-lock ((lock display &optional (whostate "CLX wait") &key timeout) &body body) ;; This macro is used by WITH-DISPLAY, which claims to be callable ;; recursively. So, had better use a recursive lock. ;; ;; FIXME: This is hideously ugly. If WITH-TIMEOUT handled NIL ;; timeouts... (declare (ignore display whostate)) (if timeout `(if ,timeout (handler-case (sb-ext:with-timeout ,timeout (sb-thread:with-recursive-lock (,lock) ,@body)) (sb-ext:timeout () nil)) (sb-thread:with-recursive-lock (,lock) ,@body)) `(sb-thread:with-recursive-lock (,lock) ,@body))) #+Genera (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) (declare (ignore whostate)) `(process:with-lock (,locator :timeout ,timeout) (let ((.debug-io. (buffer-debug-io ,display))) (scl:let-if .debug-io. ((*debug-io* .debug-io.)) ,@body)))) #+(and lispm (not Genera)) (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) (declare (ignore display)) ;; This macro is for use in a multi-process environment. (let ((lock (gensym)) (have-lock (gensym)) (timeo (gensym))) `(let* ((,lock (zl:locf (svref ,locator 0))) (,have-lock (eq (car ,lock) sys:current-process)) (,timeo ,timeout)) (unwind-protect (when (cond (,have-lock) ((#+explorer si:%store-conditional #-explorer sys:store-conditional ,lock nil sys:current-process)) ((null ,timeo) (sys:process-lock ,lock nil ,(or whostate "CLX Lock"))) ((sys:process-wait-with-timeout ,(or whostate "CLX Lock") (round (* ,timeo 60.)) #'(lambda (lock process) (#+explorer si:%store-conditional #-explorer sys:store-conditional lock nil process)) ,lock sys:current-process))) ,@body) (unless ,have-lock (#+explorer si:%store-conditional #-explorer sys:store-conditional ,lock sys:current-process nil)))))) ;; Lucid has a process locking mechanism as well under release 3.0 #+lcl3.0 (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) (declare (ignore display)) (if timeout ;; Hair to support timeout. `(let ((.have-lock. (eq ,locator lcl:*current-process*)) (.timeout. ,timeout)) (unwind-protect (when (cond (.have-lock.) ((conditional-store ,locator nil lcl:*current-process*)) ((null .timeout.) (lcl:process-lock ,locator) t) ((lcl:process-wait-with-timeout ,whostate .timeout. #'(lambda () (conditional-store ,locator nil lcl:*current-process*)))) ;; abort the PROCESS-UNLOCK if actually timing out (t (setf .have-lock. :abort) nil)) ,@body) (unless .have-lock. (lcl:process-unlock ,locator)))) `(lcl:with-process-lock (,locator) ,@body))) #+excl (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) (declare (ignore display)) `(let (.hl-lock. .hl-obtained-lock. .hl-curproc.) (unwind-protect (block .hl-doit. (when mp::*scheduler-stack-group* ; fast test for scheduler running (setq .hl-lock. ,locator .hl-curproc. mp::*current-process*) (when (and .hl-curproc. ; nil if in process-wait fun (not (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.))) ;; Then we need to grab the lock. ,(if timeout `(if (not (mp::process-lock .hl-lock. .hl-curproc. ,whostate ,timeout)) (return-from .hl-doit. nil)) `(mp::process-lock .hl-lock. .hl-curproc. ,@(when whostate `(,whostate)))) ;; There is an apparent race condition here. However, there is ;; no actual race condition -- our implementation of mp:process- ;; lock guarantees that the lock will still be held when it ;; returns, and no interrupt can happen between that and the ;; execution of the next form. -- jdi 2/27/91 (setq .hl-obtained-lock. t))) ,@body) (if (and .hl-obtained-lock. ;; Note -- next form added to allow error handler inside ;; body to unlock the lock prematurely if it knows that ;; the current process cannot possibly continue but will ;; throw out (or is it throw up?). (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.)) (mp::process-unlock .hl-lock. .hl-curproc.))))) #+Minima (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) `(holding-lock-1 #'(lambda () ,@body) ,locator ,display ,@(and whostate `(:whostate ,whostate)) ,@(and timeout `(:timeout ,timeout)))) #+Minima (defun holding-lock-1 (continuation lock display &key (whostate "Lock") timeout) (declare (dynamic-extent continuation)) (declare (ignore display whostate timeout)) (minima:with-lock (lock) (funcall continuation))) ;;; WITHOUT-ABORTS ;;; If you can inhibit asynchronous keyboard aborts inside the body of this ;;; macro, then it is a good idea to do this. This macro is wrapped around ;;; request writing and reply reading to ensure that requests are atomically ;;; written and replies are atomically read from the stream. #-(or Genera excl lcl3.0) (defmacro without-aborts (&body body) `(progn ,@body)) #+Genera (defmacro without-aborts (&body body) `(sys:without-aborts (clx "CLX is in the middle of an operation that should be atomic.") ,@body)) #+excl (defmacro without-aborts (&body body) `(without-interrupts ,@body)) #+lcl3.0 (defmacro without-aborts (&body body) `(lcl:with-interruptions-inhibited ,@body)) ;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value. ;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's ;;; value changes. #-(or lispm excl lcl3.0 Minima (and sb-thread sbcl) (and cmu mp)) (defun process-block (whostate predicate &rest predicate-args) (declare (ignore whostate)) (or (apply predicate predicate-args) (error "Program tried to wait with no scheduler."))) #+Genera (defun process-block (whostate predicate &rest predicate-args) (declare (type function predicate) #+clx-ansi-common-lisp (dynamic-extent predicate) #-clx-ansi-common-lisp (sys:downward-funarg predicate)) (apply #'process:block-process whostate predicate predicate-args)) #+(and lispm (not Genera)) (defun process-block (whostate predicate &rest predicate-args) (declare (type function predicate) #+clx-ansi-common-lisp (dynamic-extent predicate) #-clx-ansi-common-lisp (sys:downward-funarg predicate)) (apply #'global:process-wait whostate predicate predicate-args)) #+excl (defun process-block (whostate predicate &rest predicate-args) (if mp::*scheduler-stack-group* (apply #'mp::process-wait whostate predicate predicate-args) (or (apply predicate predicate-args) (error "Program tried to wait with no scheduler.")))) #+lcl3.0 (defun process-block (whostate predicate &rest predicate-args) (declare (dynamic-extent predicate-args)) (apply #'lcl:process-wait whostate predicate predicate-args)) #+Minima (defun process-block (whostate predicate &rest predicate-args) (declare (type function predicate) (dynamic-extent predicate)) (apply #'minima:process-wait whostate predicate predicate-args)) #+(and cmu mp) (defun process-block (whostate predicate &rest predicate-args) (declare (type function predicate)) (mp:process-wait whostate #'(lambda () (apply predicate predicate-args)))) #+(and sbcl sb-thread) (progn (declaim (inline yield)) (defun yield () (declare (optimize speed (safety 0))) (sb-alien:alien-funcall (sb-alien:extern-alien "sched_yield" (function sb-alien:int))) (values))) #+(and sbcl sb-thread) (defun process-block (whostate predicate &rest predicate-args) (declare (ignore whostate)) (declare (type function predicate)) (loop (when (apply predicate predicate-args) (return)) (yield))) ;;; FIXME: the below implementation for threaded PROCESS-BLOCK using ;;; queues and condition variables might seem better, but in fact it ;;; turns out to make performance extremely suboptimal, at least as ;;; measured by McCLIM on linux 2.4 kernels. -- CSR, 2003-11-10 #+(or) (defvar *process-conditions* (make-hash-table)) #+(or) (defun process-block (whostate predicate &rest predicate-args) (declare (ignore whostate)) (declare (type function predicate)) (let* ((pid (sb-thread:current-thread-id)) (last (gethash pid *process-conditions*)) (lock (or (car last) (sb-thread:make-mutex :name (format nil "lock ~A" pid)))) (queue (or (cdr last) (sb-thread:make-waitqueue :name (format nil "queue ~A" pid))))) (unless last (setf (gethash pid *process-conditions*) (cons lock queue))) (sb-thread:with-mutex (lock) (loop (when (apply predicate predicate-args) (return)) (handler-case (sb-ext:with-timeout .5 (sb-thread:condition-wait queue lock)) (sb-ext:timeout () (format *trace-output* "thread ~A, process-block timed out~%" (sb-thread:current-thread-id) ))))))) ;;; PROCESS-WAKEUP: Check some other process' wait function. (declaim (inline process-wakeup)) #-(or excl Genera Minima (and sbcl sb-thread) (and cmu mp)) (defun process-wakeup (process) (declare (ignore process)) nil) #+excl (defun process-wakeup (process) (let ((curproc mp::*current-process*)) (when (and curproc process) (unless (mp::process-p curproc) (error "~s is not a process" curproc)) (unless (mp::process-p process) (error "~s is not a process" process)) (if (> (mp::process-priority process) (mp::process-priority curproc)) (mp::process-allow-schedule process))))) #+Genera (defun process-wakeup (process) (process:wakeup process)) #+Minima (defun process-wakeup (process) (when process (minima:process-wakeup process))) #+(and cmu mp) (defun process-wakeup (process) (declare (ignore process)) (mp:process-yield)) #+(and sb-thread sbcl) (defun process-wakeup (process) (declare (ignore process)) (yield)) #+(or) (defun process-wakeup (process) (declare (ignore process)) (destructuring-bind (lock . queue) (gethash (sb-thread:current-thread-id) *process-conditions* (cons nil nil)) (declare (ignore lock)) (when queue (sb-thread:condition-notify queue)))) ;;; CURRENT-PROCESS: Return the current process object for input locking and ;;; for calling PROCESS-WAKEUP. (declaim (inline current-process)) ;;; Default return NIL, which is acceptable even if there is a scheduler. #-(or lispm excl lcl3.0 sbcl Minima (and cmu mp)) (defun current-process () nil) #+lispm (defun current-process () sys:current-process) #+excl (defun current-process () (and mp::*scheduler-stack-group* mp::*current-process*)) #+lcl3.0 (defun current-process () lcl:*current-process*) #+Minima (defun current-process () (minima:current-process)) #+(and cmu mp) (defun current-process () mp:*current-process*) #+sbcl (defun current-process () sb-thread:*current-thread*) ;;; WITHOUT-INTERRUPTS -- provide for atomic operations. #-(or lispm excl lcl3.0 Minima cmu sbcl) (defmacro without-interrupts (&body body) `(progn ,@body)) #+(and lispm (not Genera)) (defmacro without-interrupts (&body body) `(sys:without-interrupts ,@body)) #+Genera (defmacro without-interrupts (&body body) `(process:with-no-other-processes ,@body)) #+LCL3.0 (defmacro without-interrupts (&body body) `(lcl:with-scheduling-inhibited ,@body)) #+Minima (defmacro without-interrupts (&body body) `(minima:with-no-other-processes ,@body)) #+cmu (defmacro without-interrupts (&body body) `(system:without-interrupts ,@body)) #+sbcl (defvar *without-interrupts-sic-lock* (sb-thread:make-mutex :name "lock simulating *without-interrupts*")) #+sbcl (defmacro without-interrupts (&body body) `(sb-thread:with-recursive-lock (*without-interrupts-sic-lock*) ,@body)) ;;; CONDITIONAL-STORE: ;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times. ;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD. #-sbcl (defmacro conditional-store (place old-value new-value) `(without-interrupts (cond ((eq ,place ,old-value) (setf ,place ,new-value) t)))) #+sbcl (progn (defvar *conditional-store-lock* (sb-thread:make-mutex :name "conditional store")) (defmacro conditional-store (place old-value new-value) `(sb-thread:with-mutex (*conditional-store-lock*) (cond ((eq ,place ,old-value) (setf ,place ,new-value) t))))) ;;;---------------------------------------------------------------------------- ;;; IO Error Recovery ;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro. ;;; It prevents multiple mindless errors when the network craters. ;;; ;;;---------------------------------------------------------------------------- #-Genera (defmacro wrap-buf-output ((buffer) &body body) ;; Error recovery wrapper `(unless (buffer-dead ,buffer) ,@body)) #+Genera (defmacro wrap-buf-output ((buffer) &body body) ;; Error recovery wrapper `(let ((.buffer. ,buffer)) (unless (buffer-dead .buffer.) (scl:condition-bind (((sys:network-error) #'(lambda (error) (scl:condition-case () (funcall (buffer-close-function .buffer.) .buffer. :abort t) (sys:network-error)) (setf (buffer-dead .buffer.) error) (setf (buffer-output-stream .buffer.) nil) (setf (buffer-input-stream .buffer.) nil) nil))) ,@body)))) #-Genera (defmacro wrap-buf-input ((buffer) &body body) (declare (ignore buffer)) ;; Error recovery wrapper `(progn ,@body)) #+Genera (defmacro wrap-buf-input ((buffer) &body body) ;; Error recovery wrapper `(let ((.buffer. ,buffer)) (scl:condition-bind (((sys:network-error) #'(lambda (error) (scl:condition-case () (funcall (buffer-close-function .buffer.) .buffer. :abort t) (sys:network-error)) (setf (buffer-dead .buffer.) error) (setf (buffer-output-stream .buffer.) nil) (setf (buffer-input-stream .buffer.) nil) nil))) ,@body))) ;;;---------------------------------------------------------------------------- ;;; System dependent IO primitives ;;; Functions for opening, reading writing forcing-output and closing ;;; the stream to the server. ;;;---------------------------------------------------------------------------- ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X ;;; server #-(or explorer Genera lucid kcl ibcl excl Minima CMU sbcl ecl clisp) (defun open-x-stream (host display protocol) host display protocol ;; unused (error "OPEN-X-STREAM not implemented yet.")) #+clisp (defun open-x-stream (host display protocol) (declare (ignore protocol) (type (integer 0) display)) (let ((socket ;; are we dealing with a localhost? (when (or (string= host "") (string= host "unix")) ;; ok, try to connect to a AF_UNIX domain socket (sys::make-socket-stream "" display)))) (if socket socket ;; try to connect by hand (let ((host (host-address host))) (when host ;; Fixme: get a descent ip standard in CLX: a vector! (let ((ip (format nil "~{~D~^.~}" (rest host)))) (socket:socket-connect (+ 6000 display) ip :element-type '(unsigned-byte 8)))))))) ;;; Genera: ;;; TCP and DNA are both layered products, so try to work with either one. #+Genera (when (fboundp 'tcp:add-tcp-port-for-protocol) (tcp:add-tcp-port-for-protocol :x-window-system 6000)) #+Genera (when (fboundp 'dna:add-dna-contact-id-for-protocol) (dna:add-dna-contact-id-for-protocol :x-window-system "X$X0")) #+Genera (net:define-protocol :x-window-system (:x-window-system :byte-stream) (:invoke-with-stream ((stream :characters nil :ascii-translation nil)) stream)) #+Genera (eval-when (compile) (compiler:function-defined 'tcp:open-tcp-stream) (compiler:function-defined 'dna:open-dna-bidirectional-stream)) #+Genera (defun open-x-stream (host display protocol) (let ((host (net:parse-host host))) (if (or protocol (plusp display)) ;; The protocol was specified or the display isn't 0, so we ;; can't use the Generic Network System. If the protocol was ;; specified, then use that protocol, otherwise, blindly use ;; TCP. (ccase protocol ((:tcp nil) (tcp:open-tcp-stream host (+ *x-tcp-port* display) nil :direction :io :characters nil :ascii-translation nil)) ((:dna) (dna:open-dna-bidirectional-stream host (format nil "X$X~D" display) :characters nil :ascii-translation nil))) (let ((neti:*invoke-service-automatic-retry* t)) (net:invoke-service-on-host :x-window-system host))))) #+explorer (defun open-x-stream (host display protocol) (declare (ignore protocol)) (net:open-connection-on-medium (net:parse-host host) ;Host :byte-stream ;Medium "X11" ;Logical contact name :stream-type :character-stream :direction :bidirectional :timeout-after-open nil :remote-port (+ *x-tcp-port* display))) #+explorer (net:define-logical-contact-name "X11" `((:local "X11") (:chaos "X11") (:nsp-stream "X11") (:tcp ,*x-tcp-port*))) #+lucid (defun open-x-stream (host display protocol) protocol ;; unused (let ((fd (connect-to-server host display))) (when (minusp fd) (error "Failed to connect to server: ~A ~D" host display)) (user::make-lisp-stream :input-handle fd :output-handle fd :element-type 'unsigned-byte #-lcl3.0 :stream-type #-lcl3.0 :ephemeral))) #+(or kcl ibcl) (defun open-x-stream (host display protocol) protocol ;; unused (let ((stream (open-socket-stream host display))) (if (streamp stream) stream (error "Cannot connect to server: ~A:~D" host display)))) #+excl ;; ;; Note that since we don't use the CL i/o facilities to do i/o, the display ;; input and output "stream" is really a file descriptor (fixnum). ;; (defun open-x-stream (host display protocol) (declare (ignore protocol));; unused (let ((fd (connect-to-server (string host) display))) (when (minusp fd) (error "Failed to connect to server: ~A ~D" host display)) fd)) #+Minima (defun open-x-stream (host display protocol) (declare (ignore protocol));; unused (minima:open-tcp-stream :foreign-address (apply #'minima:make-ip-address (cdr (host-address host))) :foreign-port (+ *x-tcp-port* display))) #+sbcl (defun open-x-stream (host display protocol) (declare (ignore protocol) (type (integer 0) display)) (socket-make-stream (let ((unix-domain-socket-path (unix-socket-path-from-host host display))) (if unix-domain-socket-path (let ((s (make-instance 'local-socket :type :stream))) (socket-connect s unix-domain-socket-path) s) (let ((host (car (host-ent-addresses (get-host-by-name host))))) (when host (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))) (socket-connect s host (+ 6000 display)) s))))) :element-type '(unsigned-byte 8) :input t :output t :buffering :none)) #+ecl (defun open-x-stream (host display protocol) (declare (ignore protocol) (type (integer 0) display)) (let (socket) (if (or (string= host "") (string= host "unix")) ; AF_UNIX doamin socket (sys::open-unix-socket-stream (format nil "~A~D" +X-unix-socket-path+ display)) (si::open-client-stream host (+ 6000 display))))) ;;; BUFFER-READ-DEFAULT - read data from the X stream #+(or Genera explorer) (defun buffer-read-default (display vector start end timeout) ;; returns non-NIL if EOF encountered ;; Returns :TIMEOUT when timeout exceeded (declare (type display display) (type buffer-bytes vector) (type array-index start end) (type (or null (real 0 *)) timeout)) #.(declare-buffun) (let ((stream (display-input-stream display))) (or (cond ((null stream)) ((funcall stream :listen) nil) ((and timeout (= timeout 0)) :timeout) ((buffer-input-wait-default display timeout))) (multiple-value-bind (ignore eofp) (funcall stream :string-in nil vector start end) eofp)))) #+excl ;; ;; Rewritten 10/89 to not use foreign function interface to do I/O. ;; (defun buffer-read-default (display vector start end timeout) (declare (type display display) (type buffer-bytes vector) (type array-index start end) (type (or null (real 0 *)) timeout)) #.(declare-buffun) (let* ((howmany (- end start)) (fd (display-input-stream display))) (declare (type array-index howmany) (fixnum fd)) (or (cond ((fd-char-avail-p fd) nil) ((and timeout (= timeout 0)) :timeout) ((buffer-input-wait-default display timeout))) (fd-read-bytes fd vector start howmany)))) #+lcl3.0 (defmacro with-underlying-stream ((variable stream display direction) &body body) `(let ((,variable (or (getf (display-plist ,display) ',direction) (setf (getf (display-plist ,display) ',direction) (lucid::underlying-stream ,stream ,(if (eq direction 'input) :input :output)))))) ,@body)) #+lcl3.0 (defun buffer-read-default (display vector start end timeout) ;;Note that LISTEN must still be done on "slow stream" or the I/O system ;;gets confused. But reading should be done from "fast stream" for speed. ;;We used to inhibit scheduling because there were races in Lucid's ;;multitasking system. Empirical evidence suggests they may be gone now. ;;Should you decide you need to inhibit scheduling, do it around the ;;lcl:read-array. (declare (type display display) (type buffer-bytes vector) (type array-index start end) (type (or null (real 0 *)) timeout)) #.(declare-buffun) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (or (cond ((null stream)) ((listen stream) nil) ((and timeout (= timeout 0)) :timeout) ((buffer-input-wait-default display timeout))) (with-underlying-stream (stream stream display input) (eq (lcl:read-array stream vector start end nil :eof) :eof))))) #+Minima (defun buffer-read-default (display vector start end timeout) ;; returns non-NIL if EOF encountered ;; Returns :TIMEOUT when timeout exceeded (declare (type display display) (type buffer-bytes vector) (type array-index start end) (type (or null (real 0 *)) timeout)) #.(declare-buffun) (let ((stream (display-input-stream display))) (or (cond ((null stream)) ((listen stream) nil) ((and timeout (= timeout 0)) :timeout) ((buffer-input-wait-default display timeout))) (eq :eof (minima:read-vector vector stream nil start end))))) ;;; BUFFER-READ-DEFAULT for CMU Common Lisp. ;;; ;;; If timeout is 0, then we call LISTEN to see if there is any input. ;;; Timeout 0 is the only case where READ-INPUT dives into BUFFER-READ without ;;; first calling BUFFER-INPUT-WAIT-DEFAULT. ;;; #+(or CMU sbcl) (defun buffer-read-default (display vector start end timeout) (declare (type display display) (type buffer-bytes vector) (type array-index start end) (type (or null fixnum) timeout)) #.(declare-buffun) (cond ((and (eql timeout 0) (not (listen (display-input-stream display)))) :timeout) (t (#+cmu system:read-n-bytes #+sbcl sb-sys:read-n-bytes (display-input-stream display) vector start (- end start)) nil))) #+(or ecl clisp) (defun buffer-read-default (display vector start end timeout) (declare (type display display) (type buffer-bytes vector) (type array-index start end) (type (or null fixnum) timeout)) #.(declare-buffun) (cond ((and (eql timeout 0) (not (listen (display-input-stream display)))) :timeout) (t (read-sequence vector (display-input-stream display) :start start :end end) nil))) ;;; WARNING: ;;; CLX performance will suffer if your lisp uses read-byte for ;;; receiving all data from the X Window System server. ;;; You are encouraged to write a specialized version of ;;; buffer-read-default that does block transfers. #-(or Genera explorer excl lcl3.0 Minima CMU sbcl ecl clisp) (defun buffer-read-default (display vector start end timeout) (declare (type display display) (type buffer-bytes vector) (type array-index start end) (type (or null (real 0 *)) timeout)) #.(declare-buffun) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (or (cond ((null stream)) ((listen stream) nil) ((and timeout (= timeout 0)) :timeout) ((buffer-input-wait-default display timeout))) (do* ((index start (index1+ index))) ((index>= index end) nil) (declare (type array-index index)) (let ((c (read-byte stream nil nil))) (declare (type (or null card8) c)) (if (null c) (return t) (setf (aref vector index) (the card8 c)))))))) ;;; BUFFER-WRITE-DEFAULT - write data to the X stream #+(or Genera explorer) (defun buffer-write-default (vector display start end) ;; The default buffer write function for use with common-lisp streams (declare (type buffer-bytes vector) (type display display) (type array-index start end)) #.(declare-buffun) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (write-string vector stream :start start :end end)))) #+excl (defun buffer-write-default (vector display start end) (declare (type buffer-bytes vector) (type display display) (type array-index start end)) #.(declare-buffun) (excl::filesys-write-bytes (display-output-stream display) vector start (- end start))) #+lcl3.0 (defun buffer-write-default (vector display start end) ;;We used to inhibit scheduling because there were races in Lucid's ;;multitasking system. Empirical evidence suggests they may be gone now. ;;Should you decide you need to inhibit scheduling, do it around the ;;lcl:write-array. (declare (type display display) (type buffer-bytes vector) (type array-index start end)) #.(declare-buffun) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (with-underlying-stream (stream stream display output) (lcl:write-array stream vector start end))))) #+Minima (defun buffer-write-default (vector display start end) ;; The default buffer write function for use with common-lisp streams (declare (type buffer-bytes vector) (type display display) (type array-index start end)) #.(declare-buffun) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (minima:write-vector vector stream start end)))) #+CMU (defun buffer-write-default (vector display start end) (declare (type buffer-bytes vector) (type display display) (type array-index start end)) #.(declare-buffun) (system:output-raw-bytes (display-output-stream display) vector start end) nil) #+(or sbcl ecl clisp) (defun buffer-write-default (vector display start end) (declare (type buffer-bytes vector) (type display display) (type array-index start end)) #.(declare-buffun) (write-sequence vector (display-output-stream display) :start start :end end) nil) ;;; WARNING: ;;; CLX performance will be severely degraded if your lisp uses ;;; write-byte to send all data to the X Window System server. ;;; You are STRONGLY encouraged to write a specialized version ;;; of buffer-write-default that does block transfers. #-(or Genera explorer excl lcl3.0 Minima CMU sbcl clisp) (defun buffer-write-default (vector display start end) ;; The default buffer write function for use with common-lisp streams (declare (type buffer-bytes vector) (type display display) (type array-index start end)) #.(declare-buffun) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (with-vector (vector buffer-bytes) (do ((index start (index1+ index))) ((index>= index end)) (declare (type array-index index)) (write-byte (aref vector index) stream)))))) ;;; buffer-force-output-default - force output to the X stream #+excl (defun buffer-force-output-default (display) ;; buffer-write-default does the actual writing. (declare (ignore display))) #-(or excl) (defun buffer-force-output-default (display) ;; The default buffer force-output function for use with common-lisp streams (declare (type display display)) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (force-output stream)))) ;;; BUFFER-CLOSE-DEFAULT - close the X stream #+excl (defun buffer-close-default (display &key abort) ;; The default buffer close function for use with common-lisp streams (declare (type display display) (ignore abort)) #.(declare-buffun) (excl::filesys-checking-close (display-output-stream display))) #-(or excl) (defun buffer-close-default (display &key abort) ;; The default buffer close function for use with common-lisp streams (declare (type display display)) #.(declare-buffun) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (close stream :abort abort)))) ;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the ;;; buffer. This is called in read-input between requests, so that a process ;;; waiting for input is abortable when between requests. Should return ;;; :TIMEOUT if it times out, NIL otherwise. ;;; The default implementation ;; Poll for input every *buffer-read-polling-time* SECONDS. #-(or Genera explorer excl lcl3.0 CMU sbcl) (defparameter *buffer-read-polling-time* 0.5) #-(or Genera explorer excl lcl3.0 CMU sbcl clisp) (defun buffer-input-wait-default (display timeout) (declare (type display display) (type (or null (real 0 *)) timeout)) (declare (clx-values timeout)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (cond ((null stream)) ((listen stream) nil) ((and timeout (= timeout 0)) :timeout) ((not (null timeout)) (multiple-value-bind (npoll fraction) (truncate timeout *buffer-read-polling-time*) (dotimes (i npoll) ; Sleep for a time, then listen again (sleep *buffer-read-polling-time*) (when (listen stream) (return-from buffer-input-wait-default nil))) (when (plusp fraction) (sleep fraction) ; Sleep a fraction of a second (when (listen stream) ; and listen one last time (return-from buffer-input-wait-default nil))) :timeout))))) #+(or CMU sbcl clisp) (defun buffer-input-wait-default (display timeout) (declare (type display display) (type (or null number) timeout)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (cond ((null stream)) ((listen stream) nil) ((eql timeout 0) :timeout) (t (if #+sbcl (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream) :input timeout) #+mp (mp:process-wait-until-fd-usable (system:fd-stream-fd stream) :input timeout) #+clisp (multiple-value-bind (sec usec) (floor (or timeout 0)) (ext:socket-status stream (and timeout sec) (round usec 1d-6))) #-(or sbcl mp clisp) (system:wait-until-fd-usable (system:fd-stream-fd stream) :input timeout) nil :timeout))))) #+Genera (defun buffer-input-wait-default (display timeout) (declare (type display display) (type (or null (real 0 *)) timeout)) (declare (clx-values timeout)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (cond ((null stream)) ((scl:send stream :listen) nil) ((and timeout (= timeout 0)) :timeout) ((null timeout) (si:stream-input-block stream "CLX Input")) (t (scl:condition-bind ((neti:protocol-timeout #'(lambda (error) (when (eq stream (scl:send error :stream)) (return-from buffer-input-wait-default :timeout))))) (neti:with-stream-timeout (stream :input timeout) (si:stream-input-block stream "CLX Input"))))) nil)) #+explorer (defun buffer-input-wait-default (display timeout) (declare (type display display) (type (or null (real 0 *)) timeout)) (declare (clx-values timeout)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (cond ((null stream)) ((zl:send stream :listen) nil) ((and timeout (= timeout 0)) :timeout) ((null timeout) (si:process-wait "CLX Input" stream :listen)) (t (unless (si:process-wait-with-timeout "CLX Input" (round (* timeout 60.)) stream :listen) (return-from buffer-input-wait-default :timeout)))) nil)) #+excl ;; ;; This is used so an 'eq' test may be used to find out whether or not we can ;; safely throw this process out of the CLX read loop. ;; (defparameter *read-whostate* "waiting for input from X server") ;; ;; Note that this function returns nil on error if the scheduler is running, ;; t on error if not. This is ok since buffer-read will detect the error. ;; #+excl (defun buffer-input-wait-default (display timeout) (declare (type display display) (type (or null (real 0 *)) timeout)) (declare (clx-values timeout)) (let ((fd (display-input-stream display))) (declare (fixnum fd)) (when (>= fd 0) (cond ((fd-char-avail-p fd) nil) ;; Otherwise no bytes were available on the socket ((and timeout (= timeout 0)) ;; If there aren't enough and timeout == 0, timeout. :timeout) ;; If the scheduler is running let it do timeouts. (mp::*scheduler-stack-group* #+allegro (if (not (mp:wait-for-input-available fd :whostate *read-whostate* :wait-function #'fd-char-avail-p :timeout timeout)) (return-from buffer-input-wait-default :timeout)) #-allegro (mp::wait-for-input-available fd :whostate *read-whostate* :wait-function #'fd-char-avail-p)) ;; Otherwise we have to handle timeouts by hand, and call select() ;; to block until input is available. Note we don't really handle ;; the interaction of interrupts and (numberp timeout) here. XX (t (let ((res 0)) (declare (fixnum res)) (with-interrupt-checking-on (loop (setq res (fd-wait-for-input fd (if (null timeout) 0 (truncate timeout)))) (cond ((plusp res) ; success (return nil)) ((eq res 0) ; timeout (return :timeout)) ((eq res -1) ; error (return t)) ;; Otherwise we got an interrupt -- go around again. ))))))))) #+lcl3.0 (defun buffer-input-wait-default (display timeout) (declare (type display display) (type (or null (real 0 *)) timeout) (clx-values timeout)) #.(declare-buffun) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (cond ((null stream)) ((listen stream) nil) ((and timeout (= timeout 0)) :timeout) ((with-underlying-stream (stream stream display input) (lucid::waiting-for-input-from-stream stream (lucid::with-io-unlocked (if (null timeout) (lcl:process-wait "CLX Input" #'listen stream) (lcl:process-wait-with-timeout "CLX Input" timeout #'listen stream))))) nil) (:timeout)))) ;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the ;;; buffer. This should never block, so it can be called from the scheduler. ;;; The default implementation is to just use listen. #-(or excl) (defun buffer-listen-default (display) (declare (type display display)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (if (null stream) t (listen stream)))) #+excl (defun buffer-listen-default (display) (declare (type display display)) (let ((fd (display-input-stream display))) (declare (type fixnum fd)) (if (= fd -1) t (fd-char-avail-p fd)))) ;;;---------------------------------------------------------------------------- ;;; System dependent speed hacks ;;;---------------------------------------------------------------------------- ;; ;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature. ;; If your lisp doesn't have stack-lists, and you're worried about ;; consing garbage, you may want to re-write this to allocate and ;; initialize lists from a resource. ;; #-lispm (defmacro with-stack-list ((var &rest elements) &body body) ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body) ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body) ;; except that the list produced by MAPCAR resides on the stack and ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list ,@elements))) (declare (type cons ,var) #+clx-ansi-common-lisp (dynamic-extent ,var)) ,@body)) #-lispm (defmacro with-stack-list* ((var &rest elements) &body body) ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body) ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body) ;; except that the list produced by MAPCAR resides on the stack and ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list* ,@elements))) (declare (type cons ,var) #+clx-ansi-common-lisp (dynamic-extent ,var)) ,@body)) (declaim (inline buffer-replace)) #+lispm (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) (declare (type vector buf1 buf2) (type array-index start1 end1 start2)) (sys:copy-array-portion buf2 start2 (length buf2) buf1 start1 end1)) #+excl (defun buffer-replace (target-sequence source-sequence target-start target-end &optional (source-start 0)) (declare (type buffer-bytes target-sequence source-sequence) (type array-index target-start target-end source-start) (optimize (speed 3) (safety 0))) (let ((source-end (length source-sequence))) (declare (type array-index source-end)) (excl:if* (and (eq target-sequence source-sequence) (> target-start source-start)) then (let ((nelts (min (- target-end target-start) (- source-end source-start)))) (do ((target-index (+ target-start nelts -1) (1- target-index)) (source-index (+ source-start nelts -1) (1- source-index))) ((= target-index (1- target-start)) target-sequence) (declare (type array-index target-index source-index)) (setf (aref target-sequence target-index) (aref source-sequence source-index)))) else (do ((target-index target-start (1+ target-index)) (source-index source-start (1+ source-index))) ((or (= target-index target-end) (= source-index source-end)) target-sequence) (declare (type array-index target-index source-index)) (setf (aref target-sequence target-index) (aref source-sequence source-index)))))) #+cmu (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) (declare (type buffer-bytes buf1 buf2) (type array-index start1 end1 start2)) #.(declare-buffun) (kernel:bit-bash-copy buf2 (+ (* start2 #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits)) buf1 (+ (* start1 #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits)) (* (- end1 start1) #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits))) #+lucid ;;;The compiler is *supposed* to optimize calls to replace, but in actual ;;;fact it does not. (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) (declare (type buffer-bytes buf1 buf2) (type array-index start1 end1 start2)) #.(declare-buffun) (let ((end2 (lucid::%simple-8bit-vector-length buf2))) (declare (type array-index end2)) (lucid::simple-8bit-vector-replace-internal buf1 buf2 start1 end1 start2 end2))) #+(and clx-overlapping-arrays (not (or lispm excl))) (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) (declare (type vector buf1 buf2) (type array-index start1 end1 start2)) (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) #-(or lispm lucid excl CMU clx-overlapping-arrays) (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) (declare (type buffer-bytes buf1 buf2) (type array-index start1 end1 start2)) (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) #+ti (defun with-location-bindings (sys:"e bindings &rest body) (do ((bindings bindings (cdr bindings))) ((null bindings) (sys:eval-body-as-progn body)) (sys:bind (sys:*eval `(sys:locf ,(caar bindings))) (sys:*eval (cadar bindings))))) #+ti (compiler:defoptimizer with-location-bindings with-l-b-compiler nil (form) (let ((bindings (cadr form)) (body (cddr form))) `(let () ,@(loop for (accessor value) in bindings collect `(si:bind (si:locf ,accessor) ,value)) ,@body))) #+ti (defun (:property with-location-bindings compiler::cw-handler) (exp) (let* ((bindlist (mapcar #'compiler::cw-clause (second exp))) (body (compiler::cw-clause (cddr exp)))) (and compiler::cw-return-expansion-flag (list* (first exp) bindlist body)))) #+(and lispm (not ti)) (defmacro with-location-bindings (bindings &body body) `(sys:letf* ,bindings ,@body)) #+lispm (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) &body body) ;; don't use svref on LHS because Symbolics didn't define locf for it (let* ((local-state (gensym)) (bindings `(((aref ,local-state ,ts-index) 0)))) ; will become zero anyway (dolist (index indexes) (push `((aref ,local-state ,index) (svref ,saved-state ,index)) bindings)) `(let ((,local-state (gcontext-local-state ,gc))) (declare (type gcontext-state ,local-state)) (unwind-protect (with-location-bindings ,bindings ,@body) (setf (svref ,local-state ,ts-index) 0) (when ,temp-gc (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) (deallocate-gcontext-state ,saved-state))))) #-lispm (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) &body body) (let ((local-state (gensym)) (resets nil)) (dolist (index indexes) (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index)) resets)) `(unwind-protect (progn ,@body) (let ((,local-state (gcontext-local-state ,gc))) (declare (type gcontext-state ,local-state)) ,@resets (setf (svref ,local-state ,ts-index) 0)) (when ,temp-gc (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) (deallocate-gcontext-state ,saved-state)))) ;;;---------------------------------------------------------------------------- ;;; How much error detection should CLX do? ;;; Several levels are possible: ;;; ;;; 1. Do the equivalent of check-type on every argument. ;;; ;;; 2. Simply report TYPE-ERROR. This eliminates overhead of all the format ;;; strings generated by check-type. ;;; ;;; 3. Do error checking only on arguments that are likely to have errors ;;; (like keyword names) ;;; ;;; 4. Do error checking only where not doing so may dammage the envirnment ;;; on a non-tagged machine (i.e. when storing into a structure that has ;;; been passed in) ;;; ;;; 5. No extra error detection code. On lispm's, ASET may barf trying to ;;; store a non-integer into a number array. ;;; ;;; How extensive should the error checking be? For example, if the server ;;; expects a CARD16, is is sufficient for CLX to check for integer, or ;;; should it also check for non-negative and less than 65536? ;;;---------------------------------------------------------------------------- ;; The +TYPE-CHECK?+ constant controls how much error checking is done. ;; Possible values are: ;; NIL - Don't do any error checking ;; t - Do the equivalent of checktype on every argument ;; :minimal - Do error checking only where errors are likely ;;; This controls macro expansion, and isn't changable at run-time You will ;;; probably want to set this to nil if you want good performance at ;;; production time. (defconstant +type-check?+ #+(or Genera Minima CMU sbcl) nil #-(or Genera Minima CMU sbcl) t) ;; TYPE? is used to allow the code to do error checking at a different level from ;; the declarations. It also does some optimizations for systems that don't have ;; good compiler support for TYPEP. The definitions for CARD32, CARD16, INT16, etc. ;; include range checks. You can modify TYPE? to do less extensive checking ;; for these types if you desire. ;; ;; ### This comment is a lie! TYPE? is really also used for run-time type ;; dispatching, not just type checking. -- Ram. (defmacro type? (object type) #+(or cmu sbcl clisp) `(typep ,object ,type) #-(or cmu sbcl clisp) (if (not (constantp type)) `(typep ,object ,type) (progn (setq type (eval type)) #+(or Genera explorer Minima) (if +type-check?+ `(locally (declare (optimize safety)) (typep ,object ',type)) `(typep ,object ',type)) #-(or Genera explorer Minima) (let ((predicate (assoc type '((drawable drawable-p) (window window-p) (pixmap pixmap-p) (cursor cursor-p) (font font-p) (gcontext gcontext-p) (colormap colormap-p) (null null) (integer integerp))))) (cond (predicate `(,(second predicate) ,object)) ((eq type 'generalized-boolean) 't) ; Everything is a generalized-boolean. (+type-check?+ `(locally (declare (optimize safety)) (typep ,object ',type))) (t `(typep ,object ',type))))))) ;; X-TYPE-ERROR is the function called for type errors. ;; If you want lots of checking, but are concerned about code size, ;; this can be made into a macro that ignores some parameters. (defun x-type-error (object type &optional error-string) (x-error 'x-type-error :datum object :expected-type type :type-string error-string)) ;;----------------------------------------------------------------------------- ;; Error handlers ;; Hack up KMP error signaling using zetalisp until the real thing comes ;; along ;;----------------------------------------------------------------------------- (defun default-error-handler (display error-key &rest key-vals &key asynchronous &allow-other-keys) (declare (type generalized-boolean asynchronous) (dynamic-extent key-vals)) ;; The default display-error-handler. ;; It signals the conditions listed in the DISPLAY file. (if asynchronous (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals) (apply #'x-error error-key :display display :error-key error-key key-vals))) #+(and lispm (not Genera) (not clx-ansi-common-lisp)) (defun x-error (condition &rest keyargs) (apply #'sys:signal condition keyargs)) #+(and lispm (not Genera) (not clx-ansi-common-lisp)) (defun x-cerror (proceed-format-string condition &rest keyargs) (sys:signal (apply #'zl:make-condition condition keyargs) :proceed-types proceed-format-string)) #+(and Genera (not clx-ansi-common-lisp)) (defun x-error (condition &rest keyargs) (declare (dbg:error-reporter)) (apply #'sys:signal condition keyargs)) #+(and Genera (not clx-ansi-common-lisp)) (defun x-cerror (proceed-format-string condition &rest keyargs) (declare (dbg:error-reporter)) (apply #'sys:signal condition :continue-format-string proceed-format-string keyargs)) #+(or clx-ansi-common-lisp excl lcl3.0 clisp (and CMU mp)) (defun x-error (condition &rest keyargs) (declare (dynamic-extent keyargs)) (apply #'error condition keyargs)) #+(or clx-ansi-common-lisp excl lcl3.0 CMU clisp) (defun x-cerror (proceed-format-string condition &rest keyargs) (declare (dynamic-extent keyargs)) (apply #'cerror proceed-format-string condition keyargs)) ;;; X-ERROR for CMU Common Lisp ;;; ;;; We detect a couple condition types for which we disable event handling in ;;; our system. This prevents going into the debugger or returning to a ;;; command prompt with CLX repeatedly seeing the same condition. This occurs ;;; because CMU Common Lisp provides for all events (that is, X, input on file ;;; descriptors, Mach messages, etc.) to come through one routine anyone can ;;; use to wait for input. ;;; #+(and CMU (not mp)) (defun x-error (condition &rest keyargs) (let ((condx (apply #'make-condition condition keyargs))) (when (eq condition 'closed-display) (let ((disp (closed-display-display condx))) (warn "Disabled event handling on ~S." disp) (ext::disable-clx-event-handling disp))) (error condx))) #-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl clisp) (defun x-error (condition &rest keyargs) (error "X-Error: ~a" (princ-to-string (apply #'make-condition condition keyargs)))) #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) (defun x-cerror (proceed-format-string condition &rest keyargs) (cerror proceed-format-string "X-Error: ~a" (princ-to-string (apply #'make-condition condition keyargs)))) ;; version 15 of Pitman error handling defines the syntax for define-condition to be: ;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*] ;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string) ;; or (:report exp) #+lcl3.0 (defmacro define-condition (name parent-types &optional slots &rest args) `(lcl:define-condition ,name (,(first parent-types)) ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) slots) ,@args)) #+(and excl (not clx-ansi-common-lisp)) (defmacro define-condition (name parent-types &optional slots &rest args) `(excl::define-condition ,name (,(first parent-types)) ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) slots) ,@args)) #+(and CMU (not clx-ansi-common-lisp)) (defmacro define-condition (name parent-types &optional slots &rest args) `(common-lisp:define-condition ,name (,(first parent-types)) ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) slots) ,@args)) #+(and lispm (not clx-ansi-common-lisp)) (defmacro define-condition (name parent-types &body options) (let ((slot-names (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) (pop options))) (documentation nil) (conc-name (concatenate 'string (string name) "-")) (reporter nil)) (dolist (item options) (ecase (first item) (:documentation (setq documentation (second item))) (:conc-name (setq conc-name (string (second item)))) (:report (setq reporter (second item))))) `(within-definition (,name define-condition) (zl:defflavor ,name ,slot-names ,parent-types :initable-instance-variables #-Genera (:accessor-prefix ,conc-name) #+Genera (:conc-name ,conc-name) #-Genera (:outside-accessible-instance-variables ,@slot-names) #+Genera (:readable-instance-variables ,@slot-names)) ,(when reporter ;; when no reporter, parent's is inherited `(zl:defmethod #-Genera (,name :report) #+Genera (dbg:report ,name) (stream) ,(if (stringp reporter) `(write-string ,reporter stream) `(,reporter global:self stream)) global:self)) (zl:compile-flavor-methods ,name) ,(when documentation `(setf (documentation name 'type) ,documentation)) ',name))) #+(and lispm (not Genera) (not clx-ansi-common-lisp)) (zl:defflavor x-error () (global:error)) #+(and Genera (not clx-ansi-common-lisp)) (scl:defflavor x-error ((dbg:proceed-types '(:continue)) ; continue-format-string) (sys:error) (:initable-instance-variables continue-format-string)) #+(and Genera (not clx-ansi-common-lisp)) (scl:defmethod (scl:make-instance x-error) (&rest ignore) (when (not (sys:variable-boundp continue-format-string)) (setf dbg:proceed-types (remove :continue dbg:proceed-types)))) #+(and Genera (not clx-ansi-common-lisp)) (scl:defmethod (dbg:proceed x-error :continue) () :continue) #+(and Genera (not clx-ansi-common-lisp)) (sys:defmethod (dbg:document-proceed-type x-error :continue) (stream) (format stream continue-format-string)) #+(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) (define-condition x-error (error) ()) #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl) (defstruct x-error report-function) #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl) (defmacro define-condition (name parent-types &body options) ;; Define a structure that when printed displays an error message (flet ((reporter-for-condition (name) (xintern "." name '-reporter.))) (let ((slot-names (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) (pop options))) (documentation nil) (conc-name (concatenate 'string (string name) "-")) (reporter nil) (condition (gensym)) (stream (gensym)) (report-function (reporter-for-condition name))) (dolist (item options) (ecase (first item) (:documentation (setq documentation (second item))) (:conc-name (setq conc-name (string (second item)))) (:report (setq reporter (second item))))) (unless reporter (setq report-function (reporter-for-condition (first parent-types)))) `(within-definition (,name define-condition) (defstruct (,name (:conc-name ,(intern conc-name)) (:print-function condition-print) (:include ,(first parent-types) (report-function ',report-function))) ,@slot-names) ,(when documentation `(setf (documentation name 'type) ,documentation)) ,(when reporter `(defun ,report-function (,condition ,stream) ,(if (stringp reporter) `(write-string ,reporter ,stream) `(,reporter ,condition ,stream)) ,condition)) ',name)))) #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) (defun condition-print (condition stream depth) (declare (type x-error condition) (type stream stream) (ignore depth)) (if *print-escape* (print-unreadable-object (condition stream :type t)) (funcall (x-error-report-function condition) condition stream)) condition) #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) (defun make-condition (type &rest slot-initializations) (declare (dynamic-extent slot-initializations)) (let ((make-function (intern (concatenate 'string (string 'make-) (string type)) (symbol-package type)))) (apply make-function slot-initializations))) #-(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) (define-condition type-error (x-error) ((datum :reader type-error-datum :initarg :datum) (expected-type :reader type-error-expected-type :initarg :expected-type)) (:report (lambda (condition stream) (format stream "~s isn't a ~a" (type-error-datum condition) (type-error-expected-type condition))))) ;;----------------------------------------------------------------------------- ;; HOST hacking ;;----------------------------------------------------------------------------- #-(or explorer Genera Minima Allegro CMU sbcl ecl clisp) (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) host family (error "HOST-ADDRESS not implemented yet.")) #+clisp (defun host-address (host &optional (family :internet)) "Return a list whose car is the family keyword (:internet :DECnet :Chaos) and cdr is a list of network address bytes." (declare (type stringable host) (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (labels ((no-host-error () (error "Unknown host ~S" host)) (no-address-error () (error "Host ~S has no ~S address" host family))) (let ((hostent (posix::resolve-host-ipaddr (string host)))) (when (not (posix::hostent-addr-list hostent)) (no-host-error)) (ecase family ((:internet nil 0) (unless (= (posix::hostent-addrtype hostent) 2) (no-address-error)) (let ((addr (first (posix::hostent-addr-list hostent)))) (etypecase addr (integer (list :internet (ldb (byte 8 24) addr) (ldb (byte 8 16) addr) (ldb (byte 8 8) addr) (ldb (byte 8 0) addr))) (string (let ((parts (read-from-string (nsubstitute #\Space #\. (ext:string-concat "(" addr ")"))))) (check-type parts (cons (unsigned-byte 8) (cons (unsigned-byte 8) (cons (unsigned-byte 8) (cons (unsigned-byte 8) NULL))))) (cons :internet parts)))))))))) #+explorer (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (ecase family ((:internet nil 0) (let ((addr (ip:get-ip-address host))) (unless addr (error "~s isn't an internet host name" host)) (list :internet (ldb (byte 8 24) addr) (ldb (byte 8 16) addr) (ldb (byte 8 8) addr) (ldb (byte 8 0) addr)))) ((:chaos 2) (let ((addr (first (chaos:chaos-addresses host)))) (unless addr (error "~s isn't a chaos host name" host)) (list :chaos (ldb (byte 8 0) addr) (ldb (byte 8 8) addr)))))) #+Genera (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (setf host (string host)) (let ((net-type (ecase family ((:internet nil 0) :internet) ((:DECnet 1) :dna) ((:chaos 2) :chaos)))) (dolist (addr (sys:send (net:parse-host host) :network-addresses) (error "~S isn't a valid ~(~A~) host name" host family)) (let ((network (car addr)) (address (cadr addr))) (when (sys:send network :network-typep net-type) (return (ecase family ((:internet nil 0) (multiple-value-bind (a b c d) (tcp:explode-internet-address address) (list :internet a b c d))) ((:DECnet 1) (list :DECnet (ldb (byte 8 0) address) (ldb (byte 8 8) address))) ((:chaos 2) (list :chaos (ldb (byte 8 0) address) (ldb (byte 8 8) address)))))))))) #+Minima (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (etypecase family ((:internet nil 0) (list* :internet (multiple-value-list (minima:ip-address-components (minima:parse-ip-address (string host)))))))) #+Allegro (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (labels ((no-host-error () (error "Unknown host ~S" host)) (no-address-error () (error "Host ~S has no ~S address" host family))) (let ((hostent 0)) (unwind-protect (progn (setf hostent (ipc::gethostbyname (string host))) (when (zerop hostent) (no-host-error)) (ecase family ((:internet nil 0) (unless (= (ipc::hostent-addrtype hostent) 2) (no-address-error)) (assert (= (ipc::hostent-length hostent) 4)) (let ((addr (ipc::hostent-addr hostent))) (when (or (member comp::.target. '(:hp :sgi4d :sony :dec3100) :test #'eq) (probe-file "/lib/ld.so")) ;; BSD 4.3 based systems require an extra indirection (setq addr (si:memref-int addr 0 0 :unsigned-long))) (list :internet (si:memref-int addr 0 0 :unsigned-byte) (si:memref-int addr 1 0 :unsigned-byte) (si:memref-int addr 2 0 :unsigned-byte) (si:memref-int addr 3 0 :unsigned-byte)))))) (ff:free-cstruct hostent))))) ;#+sbcl ;(require :sockets) #+CMU (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (labels ((no-host-error () (error "Unknown host ~S" host)) (no-address-error () (error "Host ~S has no ~S address" host family))) (let ((hostent #+rwi-sockets(ext:lookup-host-entry (string host)) #+mna-sockets(net.sbcl.sockets:look-up-host-entry (string host)) #+db-sockets(sockets:get-host-by-name (string host)))) (when (not hostent) (no-host-error)) (ecase family ((:internet nil 0) #+rwi-sockets(unless (= (ext::host-entry-addr-type hostent) 2) (no-address-error)) #+mna-sockets(unless (= (net.sbcl.sockets::host-entry-addr-type hostent) 2) (no-address-error)) ;; the following form is for use with SBCL and Daniel ;; Barlow's socket package #+db-sockets(unless (sockets:host-ent-address hostent) (no-address-error)) (append (list :internet) #+rwi-sockets (let ((addr (first (ext::host-entry-addr-list hostent)))) (list (ldb (byte 8 24) addr) (ldb (byte 8 16) addr) (ldb (byte 8 8) addr) (ldb (byte 8 0) addr))) #+mna-sockets (let ((addr (first (net.sbcl.sockets::host-entry-addr-list hostent)))) (list (ldb (byte 8 24) addr) (ldb (byte 8 16) addr) (ldb (byte 8 8) addr) (ldb (byte 8 0) addr))) ;; the following form is for use with SBCL and Daniel ;; Barlow's socket package #+db-sockets(coerce (sockets:host-ent-address hostent) 'list))))))) #+sbcl (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (let ((hostent (get-host-by-name (string host)))) (ecase family ((:internet nil 0) (cons :internet (coerce (host-ent-address hostent) 'list)))))) #+ecl (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (labels ((no-host-error () (error "Unknown host ~S" host))) (let ((addr (first (nth-value 3 (si::lookup-host-entry (string host)))))) (unless addr (no-host-error)) (list :internet (ldb (byte 8 24) addr) (ldb (byte 8 16) addr) (ldb (byte 8 8) addr) (ldb (byte 8 0) addr))))) #+explorer ;; This isn't required, but it helps make sense of the results from access-hosts (defun get-host (host-object) ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type list host-object)) (declare (clx-values string family)) (let* ((family (first host-object)) (address (ecase family (:internet (dpb (second host-object) (byte 8 24) (dpb (third host-object) (byte 8 16) (dpb (fourth host-object) (byte 8 8) (fifth host-object))))) (:chaos (dpb (third host-object) (byte 8 8) (second host-object)))))) (when (eq family :internet) (setq family :ip)) (let ((host (si:get-host-from-address address family))) (values (and host (funcall host :name)) family)))) ;;; This isn't required, but it helps make sense of the results from access-hosts #+Genera (defun get-host (host-object) ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type list host-object)) (declare (clx-values string family)) (let ((family (first host-object))) (values (sys:send (net:get-host-from-address (ecase family (:internet (apply #'tcp:build-internet-address (rest host-object))) ((:chaos :DECnet) (dpb (third host-object) (byte 8 8) (second host-object)))) (net:local-network-of-type (if (eq family :DECnet) :DNA family))) :name) family))) ;;; This isn't required, but it helps make sense of the results from access-hosts #+Minima (defun get-host (host-object) ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type list host-object)) (declare (clx-values string family)) (let ((family (first host-object))) (values (ecase family (:internet (minima:ip-address-string (apply #'minima:make-ip-address (rest host-object))))) family))) ;;----------------------------------------------------------------------------- ;; Whether to use closures for requests or not. ;;----------------------------------------------------------------------------- ;;; If this macro expands to non-NIL, then request and locking code is ;;; compiled in a much more compact format, as the common code is shared, and ;;; the specific code is built into a closure that is funcalled by the shared ;;; code. If your compiler makes efficient use of closures then you probably ;;; want to make this expand to T, as it makes the code more compact. (defmacro use-closures () #+(or lispm Minima) t #-(or lispm Minima) nil) #+(or Genera Minima) (defun clx-macroexpand (form env) (declare (ignore env)) form) #-(or Genera Minima) (defun clx-macroexpand (form env) (macroexpand form env)) ;;----------------------------------------------------------------------------- ;; Resource stuff ;;----------------------------------------------------------------------------- ;;; Utilities (defun getenv (name) #+excl (sys:getenv name) #+lcl3.0 (lcl:environment-variable name) #+CMU (cdr (assoc name ext:*environment-list* :test #'string=)) #+sbcl (sb-ext:posix-getenv name) #+ecl (si:getenv name) #+clisp (ext:getenv name) #-(or sbcl excl lcl3.0 CMU ecl clisp) (progn name nil)) (defun get-host-name () "Return the same hostname as gethostname(3) would" ;; machine-instance probably works on a lot of lisps, but clisp is not ;; one of them #+(or cmu sbcl) (machine-instance) ;; resources-pathname was using short-site-name for this purpose #+excl (short-site-name) #+ecl (si:getenv "HOST") #+clisp (let ((s (machine-instance))) (subseq s 0 (position #\Space s))) #-(or excl cmu sbcl ecl clisp) (error "get-host-name not implemented")) (defun homedir-file-pathname (name) (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal) (merge-pathnames (user-homedir-pathname) (pathname name)))) ;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if ;;; a resource manager isn't running. (defun default-resources-pathname () (homedir-file-pathname ".Xdefaults")) ;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the ;;; defaults have been loaded. (defun resources-pathname () (or (let ((string (getenv "XENVIRONMENT"))) (and string (pathname string))) (homedir-file-pathname (concatenate 'string ".Xdefaults-" (get-host-name))))) ;;; AUTHORITY-PATHNAME - The pathname of the authority file. (defun authority-pathname () (or (let ((xauthority (getenv "XAUTHORITY"))) (and xauthority (pathname xauthority))) (homedir-file-pathname ".Xauthority"))) ;;; this particular defaulting behaviour is typical to most Unices, I think #+unix (defun get-default-display (&optional display-name) "Parse the argument DISPLAY-NAME, or the environment variable $DISPLAY if it is NIL. Display names have the format [protocol/] [hostname] : [:] displaynumber [.screennumber] There are two special cases in parsing, to match that done in the Xlib C language bindings - If the hostname is ``unix'' or the empty string, any supplied protocol is ignored and a connection is made using the :local transport. - If a double colon separates hostname from displaynumber, the protocol is assumed to be decnet. Returns a list of (host display-number screen protocol)." (let* ((name (or display-name (getenv "DISPLAY") (error "DISPLAY environment variable is not set"))) (slash-i (or (position #\/ name) -1)) (colon-i (position #\: name :start (1+ slash-i))) (decnet-colon-p (eql (elt name (1+ colon-i)) #\:)) (host (subseq name (1+ slash-i) colon-i)) (dot-i (and colon-i (position #\. name :start colon-i))) (display (when colon-i (parse-integer name :start (if decnet-colon-p (+ colon-i 2) (1+ colon-i)) :end dot-i))) (screen (when dot-i (parse-integer name :start (1+ dot-i)))) (protocol (cond ((or (string= host "") (string-equal host "unix")) :local) (decnet-colon-p :decnet) ((> slash-i -1) (intern (string-upcase (subseq name 0 slash-i)) :keyword)) (t :internet)))) (list host (or display 0) (or screen 0) protocol))) ;;----------------------------------------------------------------------------- ;; GC stuff ;;----------------------------------------------------------------------------- (defun gc-cleanup () (declare (special *event-free-list* *pending-command-free-list* *reply-buffer-free-lists* *gcontext-local-state-cache* *temp-gcontext-cache*)) (setq *event-free-list* nil) (setq *pending-command-free-list* nil) (when (boundp '*reply-buffer-free-lists*) (fill *reply-buffer-free-lists* nil)) (setq *gcontext-local-state-cache* nil) (setq *temp-gcontext-cache* nil) nil) #+Genera (si:define-gc-cleanup clx-cleanup ("CLX Cleanup") (gc-cleanup)) ;;----------------------------------------------------------------------------- ;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND) ;;----------------------------------------------------------------------------- #-(or clx-ansi-common-lisp Genera CMU sbcl) (defun with-standard-io-syntax-function (function) (declare #+lispm (sys:downward-funarg function)) (let ((*package* (find-package :user)) (*print-array* t) (*print-base* 10) (*print-case* :upcase) (*print-circle* nil) (*print-escape* t) (*print-gensym* t) (*print-length* nil) (*print-level* nil) (*print-pretty* nil) (*print-radix* nil) (*read-base* 10) (*read-default-float-format* 'single-float) (*read-suppress* nil) #+ticl (ticl:*print-structure* t) #+lucid (lucid::*print-structure* t)) (funcall function))) #-(or clx-ansi-common-lisp Genera CMU sbcl) (defmacro with-standard-io-syntax (&body body) `(flet ((.with-standard-io-syntax-body. () ,@body)) (with-standard-io-syntax-function #'.with-standard-io-syntax-body.))) ;;----------------------------------------------------------------------------- ;; DEFAULT-KEYSYM-TRANSLATE ;;----------------------------------------------------------------------------- ;;; If object is a character, char-bits are set from state. ;;; ;;; [the following isn't implemented (should it be?)] ;;; If object is a list, it is an alist with entries: ;;; (base-char [modifiers] [mask-modifiers]) ;;; When MODIFIERS are specified, this character translation ;;; will only take effect when the specified modifiers are pressed. ;;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore. ;;; When MASK-MODIFIERS is missing, all other modifiers are ignored. ;;; In ambiguous cases, the most specific translation is used. #-(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl) (defun default-keysym-translate (display state object) (declare (type display display) (type card16 state) (type t object) (clx-values t) (special left-meta-keysym right-meta-keysym left-super-keysym right-super-keysym left-hyper-keysym right-hyper-keysym)) (when (characterp object) (when (logbitp (position :control +state-mask-vector+) state) (setf (char-bit object :control) 1)) (when (or (state-keysymp display state left-meta-keysym) (state-keysymp display state right-meta-keysym)) (setf (char-bit object :meta) 1)) (when (or (state-keysymp display state left-super-keysym) (state-keysymp display state right-super-keysym)) (setf (char-bit object :super) 1)) (when (or (state-keysymp display state left-hyper-keysym) (state-keysymp display state right-hyper-keysym)) (setf (char-bit object :hyper) 1))) object) #+(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl clisp) (defun default-keysym-translate (display state object) (declare (type display display) (type card16 state) (type t object) (ignore display state) (clx-values t)) object) ;;----------------------------------------------------------------------------- ;; Image stuff ;;----------------------------------------------------------------------------- ;;; Types (deftype pixarray-1-element-type () 'bit) (deftype pixarray-4-element-type () '(unsigned-byte 4)) (deftype pixarray-8-element-type () '(unsigned-byte 8)) (deftype pixarray-16-element-type () '(unsigned-byte 16)) (deftype pixarray-24-element-type () '(unsigned-byte 24)) (deftype pixarray-32-element-type () #-(or Genera Minima) '(unsigned-byte 32) #+(or Genera Minima) 'fixnum) (deftype pixarray-1 () '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-1-element-type (* *))) (deftype pixarray-4 () '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-4-element-type (* *))) (deftype pixarray-8 () '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-8-element-type (* *))) (deftype pixarray-16 () '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-16-element-type (* *))) (deftype pixarray-24 () '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-24-element-type (* *))) (deftype pixarray-32 () '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-32-element-type (* *))) (deftype pixarray () '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32)) (deftype bitmap () 'pixarray-1) ;;; WITH-UNDERLYING-SIMPLE-VECTOR #+Genera (defmacro with-underlying-simple-vector ((variable element-type pixarray) &body body) (let ((bits-per-element (sys:array-bits-per-element (symbol-value (sys:type-array-element-type element-type))))) `(scl:stack-let ((,variable (make-array (index-ceiling (index* (array-total-size ,pixarray) (sys:array-element-size ,pixarray)) ,bits-per-element) :element-type ',element-type :displaced-to ,pixarray))) (declare (type (vector ,element-type) ,variable)) ,@body))) #+lcl3.0 (defmacro with-underlying-simple-vector ((variable element-type pixarray) &body body) `(let ((,variable (sys:underlying-simple-vector ,pixarray))) (declare (type (simple-array ,element-type (*)) ,variable)) ,@body)) #+excl (defmacro with-underlying-simple-vector ((variable element-type pixarray) &body body) `(let ((,variable (cdr (excl::ah_data ,pixarray)))) (declare (type (simple-array ,element-type (*)) ,variable)) ,@body)) #+(or CMU sbcl) ;;; We do *NOT* support viewing an array as having a different element type. ;;; Element-type is ignored. ;;; (defmacro with-underlying-simple-vector ((variable element-type pixarray) &body body) (declare (ignore element-type)) `(#+cmu kernel::with-array-data #+sbcl sb-kernel:with-array-data ((,variable ,pixarray) (start) (end)) (declare (ignore start end)) ,@body)) ;;; These are used to read and write pixels from and to CARD8s. ;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s. (defmacro read-image-load-byte (size position integer) (unless +image-bit-lsb-first-p+ (setq position (- 7 position))) `(the (unsigned-byte ,size) (#-Genera ldb #+Genera sys:%logldb (byte ,size ,position) (the card8 ,integer)))) ;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from ;;; the appropriate number of CARD8s. (defmacro read-image-assemble-bytes (&rest bytes) (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes))) (let ((it (first bytes)) (count 0)) (dolist (byte (rest bytes)) (setq it `(#-Genera dpb #+Genera sys:%logdpb (the card8 ,byte) (byte 8 ,(incf count 8)) (the (unsigned-byte ,count) ,it)))) #-Genera `(the (unsigned-byte ,(* (length bytes) 8)) ,it) #+Genera it)) ;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit ;;; pixel. (defmacro write-image-load-byte (position integer integer-size) integer-size (unless +image-byte-lsb-first-p+ (setq position (- integer-size 8 position))) `(the card8 (#-Genera ldb #+Genera sys:%logldb (byte 8 ,position) #-Genera (the (unsigned-byte ,integer-size) ,integer) #+Genera ,integer ))) ;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit ;;; pixels. (defmacro write-image-assemble-bytes (&rest bytes) (unless +image-bit-lsb-first-p+ (setq bytes (reverse bytes))) (let ((size (floor 8 (length bytes))) (it (first bytes)) (count 0)) (dolist (byte (rest bytes)) (setq it `(#-Genera dpb #+Genera sys:%logdpb (the (unsigned-byte ,size) ,byte) (byte ,size ,(incf count size)) (the (unsigned-byte ,count) ,it)))) `(the card8 ,it))) #+(or Genera lcl3.0 excl) (defvar *computed-image-byte-lsb-first-p* +image-byte-lsb-first-p+) #+(or Genera lcl3.0 excl) (defvar *computed-image-bit-lsb-first-p* +image-bit-lsb-first-p+) ;;; The following table gives the bit ordering within bytes (when accessed ;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to ;;; 31, where bit 0 should be leftmost on the display. For a given byte ;;; labelled A-B, A is for the most significant bit of the byte, and B is ;;; for the least significant bit. ;;; ;;; legend: ;;; 1 scanline-unit = 8 ;;; 2 scanline-unit = 16 ;;; 4 scanline-unit = 32 ;;; M byte-order = MostSignificant ;;; L byte-order = LeastSignificant ;;; m bit-order = MostSignificant ;;; l bit-order = LeastSignificant ;;; ;;; ;;; format ordering ;;; ;;; 1Mm 00-07 08-15 16-23 24-31 ;;; 2Mm 00-07 08-15 16-23 24-31 ;;; 4Mm 00-07 08-15 16-23 24-31 ;;; 1Ml 07-00 15-08 23-16 31-24 ;;; 2Ml 15-08 07-00 31-24 23-16 ;;; 4Ml 31-24 23-16 15-08 07-00 ;;; 1Lm 00-07 08-15 16-23 24-31 ;;; 2Lm 08-15 00-07 24-31 16-23 ;;; 4Lm 24-31 16-23 08-15 00-07 ;;; 1Ll 07-00 15-08 23-16 31-24 ;;; 2Ll 07-00 15-08 23-16 31-24 ;;; 4Ll 07-00 15-08 23-16 31-24 #+(or Genera lcl3.0 excl) (defconstant *image-bit-ordering-table* '(((1 (00 07) (08 15) (16 23) (24 31)) (nil nil)) ((2 (00 07) (08 15) (16 23) (24 31)) (nil nil)) ((4 (00 07) (08 15) (16 23) (24 31)) (nil nil)) ((1 (07 00) (15 08) (23 16) (31 24)) (nil t)) ((2 (15 08) (07 00) (31 24) (23 16)) (nil t)) ((4 (31 24) (23 16) (15 08) (07 00)) (nil t)) ((1 (00 07) (08 15) (16 23) (24 31)) (t nil)) ((2 (08 15) (00 07) (24 31) (16 23)) (t nil)) ((4 (24 31) (16 23) (08 15) (00 07)) (t nil)) ((1 (07 00) (15 08) (23 16) (31 24)) (t t)) ((2 (07 00) (15 08) (23 16) (31 24)) (t t)) ((4 (07 00) (15 08) (23 16) (31 24)) (t t)))) #+(or Genera lcl3.0 excl) (defun compute-image-byte-and-bit-ordering () (declare (clx-values image-byte-lsb-first-p image-bit-lsb-first-p)) ;; First compute the ordering (let ((ordering nil) (a (make-array '(1 32) :element-type 'bit :initial-element 0))) (dotimes (i 4) (push (flet ((bitpos (a i n) (declare (optimize (speed 3) (safety 0) (space 0))) (declare (type (simple-array bit (* *)) a) (type fixnum i n)) (with-underlying-simple-vector (v (unsigned-byte 8) a) (prog2 (setf (aref v i) n) (dotimes (i 32) (unless (zerop (aref a 0 i)) (return i))) (setf (aref v i) 0))))) (list (bitpos a i #b10000000) (bitpos a i #b00000001))) ordering)) (setq ordering (cons (floor +image-unit+ 8) (nreverse ordering))) ;; Now from the ordering, compute byte-lsb-first-p and bit-lsb-first-p (let ((byte-and-bit-ordering (second (assoc ordering *image-bit-ordering-table* :test #'equal)))) (unless byte-and-bit-ordering (error "Couldn't determine image byte and bit ordering~@ measured image ordering = ~A" ordering)) (values-list byte-and-bit-ordering)))) #+(or Genera lcl3.0 excl) (multiple-value-setq (*computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) (compute-image-byte-and-bit-ordering)) ;;; If you can write fast routines that can read and write pixarrays out of a ;;; buffer-bytes, do it! It makes the image code a lot faster. The ;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines ;;; return T if they can do it, NIL if they can't. ;;; FIXME: though we have some #+sbcl -conditionalized routines in ;;; here, they would appear not to work, and so are commented out in ;;; the the FAST-xxx-PIXARRAY routines themseleves. Investigate ;;; whether the unoptimized routines are often used, and also whether ;;; speeding them up while maintaining correctness is possible. ;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s #+(or lcl3.0 excl) (defun fast-read-pixarray-1 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-1 array) (type card16 x y width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-1-element-type array) (do* ((start (index+ index (index* y padded-bytes-per-line) (index-ceiling x 8)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y)) (left-bits (the array-index (mod (the fixnum (- x)) 8))) (right-bits (index-mod (index- width left-bits) 8)) (middle-bits (the fixnum (- (the fixnum (- width left-bits)) right-bits))) (middle-bytes (index-floor middle-bits 8))) ((index>= y height)) (declare (type array-index start y left-bits right-bits middle-bytes) (fixnum middle-bits)) (cond ((< middle-bits 0) (let ((byte (aref buffer-bbuf (index1- start))) (x (array-row-major-index array y left-bits))) (declare (type card8 byte) (type array-index x)) (when (index> right-bits 6) (setf (aref vector (index- x 1)) (read-image-load-byte 1 7 byte))) (when (and (index> left-bits 1) (index> right-bits 5)) (setf (aref vector (index- x 2)) (read-image-load-byte 1 6 byte))) (when (and (index> left-bits 2) (index> right-bits 4)) (setf (aref vector (index- x 3)) (read-image-load-byte 1 5 byte))) (when (and (index> left-bits 3) (index> right-bits 3)) (setf (aref vector (index- x 4)) (read-image-load-byte 1 4 byte))) (when (and (index> left-bits 4) (index> right-bits 2)) (setf (aref vector (index- x 5)) (read-image-load-byte 1 3 byte))) (when (and (index> left-bits 5) (index> right-bits 1)) (setf (aref vector (index- x 6)) (read-image-load-byte 1 2 byte))) (when (index> left-bits 6) (setf (aref vector (index- x 7)) (read-image-load-byte 1 1 byte))))) (t (unless (index-zerop left-bits) (let ((byte (aref buffer-bbuf (index1- start))) (x (array-row-major-index array y left-bits))) (declare (type card8 byte) (type array-index x)) (setf (aref vector (index- x 1)) (read-image-load-byte 1 7 byte)) (when (index> left-bits 1) (setf (aref vector (index- x 2)) (read-image-load-byte 1 6 byte)) (when (index> left-bits 2) (setf (aref vector (index- x 3)) (read-image-load-byte 1 5 byte)) (when (index> left-bits 3) (setf (aref vector (index- x 4)) (read-image-load-byte 1 4 byte)) (when (index> left-bits 4) (setf (aref vector (index- x 5)) (read-image-load-byte 1 3 byte)) (when (index> left-bits 5) (setf (aref vector (index- x 6)) (read-image-load-byte 1 2 byte)) (when (index> left-bits 6) (setf (aref vector (index- x 7)) (read-image-load-byte 1 1 byte)) )))))))) (do* ((end (index+ start middle-bytes)) (i start (index1+ i)) (x (array-row-major-index array y left-bits) (index+ x 8))) ((index>= i end) (unless (index-zerop right-bits) (let ((byte (aref buffer-bbuf end)) (x (array-row-major-index array y (index+ left-bits middle-bits)))) (declare (type card8 byte) (type array-index x)) (setf (aref vector (index+ x 0)) (read-image-load-byte 1 0 byte)) (when (index> right-bits 1) (setf (aref vector (index+ x 1)) (read-image-load-byte 1 1 byte)) (when (index> right-bits 2) (setf (aref vector (index+ x 2)) (read-image-load-byte 1 2 byte)) (when (index> right-bits 3) (setf (aref vector (index+ x 3)) (read-image-load-byte 1 3 byte)) (when (index> right-bits 4) (setf (aref vector (index+ x 4)) (read-image-load-byte 1 4 byte)) (when (index> right-bits 5) (setf (aref vector (index+ x 5)) (read-image-load-byte 1 5 byte)) (when (index> right-bits 6) (setf (aref vector (index+ x 6)) (read-image-load-byte 1 6 byte)) ))))))))) (declare (type array-index end i x)) (let ((byte (aref buffer-bbuf i))) (declare (type card8 byte)) (setf (aref vector (index+ x 0)) (read-image-load-byte 1 0 byte)) (setf (aref vector (index+ x 1)) (read-image-load-byte 1 1 byte)) (setf (aref vector (index+ x 2)) (read-image-load-byte 1 2 byte)) (setf (aref vector (index+ x 3)) (read-image-load-byte 1 3 byte)) (setf (aref vector (index+ x 4)) (read-image-load-byte 1 4 byte)) (setf (aref vector (index+ x 5)) (read-image-load-byte 1 5 byte)) (setf (aref vector (index+ x 6)) (read-image-load-byte 1 6 byte)) (setf (aref vector (index+ x 7)) (read-image-load-byte 1 7 byte)))) ))))) t) #+(or lcl3.0 excl) (defun fast-read-pixarray-4 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-4 array) (type card16 x y width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-4-element-type array) (do* ((start (index+ index (index* y padded-bytes-per-line) (index-ceiling x 2)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y)) (left-nibbles (the array-index (mod (the fixnum (- (the fixnum x))) 2))) (right-nibbles (index-mod (index- width left-nibbles) 2)) (middle-nibbles (index- width left-nibbles right-nibbles)) (middle-bytes (index-floor middle-nibbles 2))) ((index>= y height)) (declare (type array-index start y left-nibbles right-nibbles middle-nibbles middle-bytes)) (unless (index-zerop left-nibbles) (setf (aref array y 0) (read-image-load-byte 4 4 (aref buffer-bbuf (index1- start))))) (do* ((end (index+ start middle-bytes)) (i start (index1+ i)) (x (array-row-major-index array y left-nibbles) (index+ x 2))) ((index>= i end) (unless (index-zerop right-nibbles) (setf (aref array y (index+ left-nibbles middle-nibbles)) (read-image-load-byte 4 0 (aref buffer-bbuf end))))) (declare (type array-index end i x)) (let ((byte (aref buffer-bbuf i))) (declare (type card8 byte)) (setf (aref vector (index+ x 0)) (read-image-load-byte 4 0 byte)) (setf (aref vector (index+ x 1)) (read-image-load-byte 4 4 byte)))) ))) t) #+(or Genera lcl3.0 excl CMU sbcl) (defun fast-read-pixarray-24 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-24 array) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-24-element-type array) (do* ((start (index+ index (index* y padded-bytes-per-line) (index* x 3)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y))) ((index>= y height)) (declare (type array-index start y)) (do* ((end (index+ start (index* width 3))) (i start (index+ i 3)) (x (array-row-major-index array y 0) (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (setf (aref vector x) (read-image-assemble-bytes (aref buffer-bbuf (index+ i 0)) (aref buffer-bbuf (index+ i 1)) (aref buffer-bbuf (index+ i 2)))))))) t) #+lispm (defun fast-read-pixarray-using-bitblt (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel) (#+Genera sys:stack-let* #-Genera let* ((dimensions (list (+ y height) (floor (* padded-bytes-per-line 8) bits-per-pixel))) (a (make-array dimensions :element-type (array-element-type pixarray) :displaced-to bbuf :displaced-index-offset (floor (* boffset 8) bits-per-pixel)))) (sys:bitblt boole-1 width height a x y pixarray 0 0)) t) #+(or CMU sbcl) (defun pixarray-element-size (pixarray) (let ((eltype (array-element-type pixarray))) (cond ((eq eltype 'bit) 1) ((and (consp eltype) (eq (first eltype) 'unsigned-byte)) (second eltype)) (t (error "Invalid pixarray: ~S." pixarray))))) #+CMU ;;; COPY-BIT-RECT -- Internal ;;; ;;; This is the classic BITBLT operation, copying a rectangular subarray ;;; from one array to another (but source and destination must not overlap.) ;;; Widths are specified in bits. Neither array can have a non-zero ;;; displacement. We allow extra random bit-offset to be thrown into the X. ;;; (defun copy-bit-rect (source source-width sx sy dest dest-width dx dy height width) (declare (type array-index source-width sx sy dest-width dx dy height width)) #.(declare-buffun) (kernel::with-array-data ((sdata source) (sstart) (send)) (declare (ignore send)) (kernel::with-array-data ((ddata dest) (dstart) (dend)) (declare (ignore dend)) (assert (and (zerop sstart) (zerop dstart))) (do ((src-idx (index+ (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits) sx (index* sy source-width)) (index+ src-idx source-width)) (dest-idx (index+ (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits) dx (index* dy dest-width)) (index+ dest-idx dest-width)) (count height (1- count))) ((zerop count)) (declare (type array-index src-idx dest-idx count)) (kernel:bit-bash-copy sdata src-idx ddata dest-idx width))))) #+sbcl (defun copy-bit-rect (source source-width sx sy dest dest-width dx dy height width) (declare (type array-index source-width sx sy dest-width dx dy height width)) #.(declare-buffun) (sb-kernel:with-array-data ((sdata source) (sstart) (send)) (declare (ignore send)) (sb-kernel:with-array-data ((ddata dest) (dstart) (dend)) (declare (ignore dend)) (assert (and (zerop sstart) (zerop dstart))) (do ((src-idx (index+ (* sb-vm:vector-data-offset sb-vm:n-word-bits) sx (index* sy source-width)) (index+ src-idx source-width)) (dest-idx (index+ (* sb-vm:vector-data-offset sb-vm:n-word-bits) dx (index* dy dest-width)) (index+ dest-idx dest-width)) (count height (1- count))) ((zerop count)) (declare (type array-index src-idx dest-idx count)) (sb-kernel:ub1-bash-copy sdata src-idx ddata dest-idx width))))) #+(or CMU sbcl) (defun fast-read-pixarray-using-bitblt (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel) (declare (type (array * 2) pixarray)) #.(declare-buffun) (copy-bit-rect bbuf (index* padded-bytes-per-line #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) (index* boffset #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) 0 pixarray (index* (array-dimension pixarray 1) bits-per-pixel) x y height (index* width bits-per-pixel)) t) #+(or Genera lcl3.0 excl) (defun fast-read-pixarray-with-swap (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type array-index boffset padded-bytes-per-line) (type pixarray pixarray) (type card16 x y width height) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (unless (index= bits-per-pixel 24) (let ((pixarray-padded-bits-per-line (if (index= height 1) 0 (index* (index- (array-row-major-index pixarray 1 0) (array-row-major-index pixarray 0 0)) bits-per-pixel))) (x-bits (index* x bits-per-pixel))) (declare (type array-index pixarray-padded-bits-per-line x-bits)) (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) (index-zerop (index-mod x-bits 8))) (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) (index-zerop (index-mod x-bits +image-unit+)))) (multiple-value-bind (image-swap-function image-swap-lsb-first-p) (image-swap-function bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p +image-unit+ *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) (declare (type symbol image-swap-function) (type generalized-boolean image-swap-lsb-first-p)) (with-underlying-simple-vector (dst card8 pixarray) (funcall (symbol-function image-swap-function) bbuf dst (index+ boffset (index* y padded-bytes-per-line) (index-floor x-bits 8)) 0 (index-ceiling (index* width bits-per-pixel) 8) padded-bytes-per-line (index-floor pixarray-padded-bits-per-line 8) height image-swap-lsb-first-p))) t)))) (defun fast-read-pixarray (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type array-index boffset padded-bytes-per-line) (type pixarray pixarray) (type card16 x y width height) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (progn bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (or #+(or Genera lcl3.0 excl) (fast-read-pixarray-with-swap bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (let ((function (or #+lispm (and (= (sys:array-element-size pixarray) bits-per-pixel) (zerop (index-mod padded-bytes-per-line 4)) (zerop (index-mod (* #+Genera (sys:array-row-span pixarray) #-Genera (array-dimension pixarray 1) bits-per-pixel) 32)) #'fast-read-pixarray-using-bitblt) #+(or CMU) (and (index= (pixarray-element-size pixarray) bits-per-pixel) #'fast-read-pixarray-using-bitblt) #+(or lcl3.0 excl) (and (index= bits-per-pixel 1) #'fast-read-pixarray-1) #+(or lcl3.0 excl) (and (index= bits-per-pixel 4) #'fast-read-pixarray-4) #+(or Genera lcl3.0 excl CMU) (and (index= bits-per-pixel 24) #'fast-read-pixarray-24)))) (when function (read-pixarray-internal bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel function unit byte-lsb-first-p bit-lsb-first-p +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+))))) ;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s #+(or lcl3.0 excl) (defun fast-write-pixarray-1 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-1 array) (type card16 x y width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-1-element-type array) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (right-bits (index-mod width 8)) (middle-bits (index- width right-bits)) (middle-bytes (index-ceiling middle-bits 8)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index h y right-bits middle-bits middle-bytes start)) (do* ((end (index+ start middle-bytes)) (i start (index1+ i)) (start-x x) (x (array-row-major-index array y start-x) (index+ x 8))) ((index>= i end) (unless (index-zerop right-bits) (let ((x (array-row-major-index array y (index+ start-x middle-bits)))) (declare (type array-index x)) (setf (aref buffer-bbuf end) (write-image-assemble-bytes (aref vector (index+ x 0)) (if (index> right-bits 1) (aref vector (index+ x 1)) 0) (if (index> right-bits 2) (aref vector (index+ x 2)) 0) (if (index> right-bits 3) (aref vector (index+ x 3)) 0) (if (index> right-bits 4) (aref vector (index+ x 4)) 0) (if (index> right-bits 5) (aref vector (index+ x 5)) 0) (if (index> right-bits 6) (aref vector (index+ x 6)) 0) 0))))) (declare (type array-index end i start-x x)) (setf (aref buffer-bbuf i) (write-image-assemble-bytes (aref vector (index+ x 0)) (aref vector (index+ x 1)) (aref vector (index+ x 2)) (aref vector (index+ x 3)) (aref vector (index+ x 4)) (aref vector (index+ x 5)) (aref vector (index+ x 6)) (aref vector (index+ x 7)))))))) t) #+(or lcl3.0 excl) (defun fast-write-pixarray-4 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-4 array) (type int16 x y) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-4-element-type array) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (right-nibbles (index-mod width 2)) (middle-nibbles (index- width right-nibbles)) (middle-bytes (index-ceiling middle-nibbles 2)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index h y right-nibbles middle-nibbles middle-bytes start)) (do* ((end (index+ start middle-bytes)) (i start (index1+ i)) (start-x x) (x (array-row-major-index array y start-x) (index+ x 2))) ((index>= i end) (unless (index-zerop right-nibbles) (setf (aref buffer-bbuf end) (write-image-assemble-bytes (aref array y (index+ start-x middle-nibbles)) 0)))) (declare (type array-index end i start-x x)) (setf (aref buffer-bbuf i) (write-image-assemble-bytes (aref vector (index+ x 0)) (aref vector (index+ x 1)))))))) t) #+(or Genera lcl3.0 excl CMU sbcl) (defun fast-write-pixarray-24 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-24 array) (type int16 x y) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-24-element-type array) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index y start)) (do* ((end (index+ start (index* width 3))) (i start (index+ i 3)) (x (array-row-major-index array y x) (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (let ((pixel (aref vector x))) (declare (type pixarray-24-element-type pixel)) (setf (aref buffer-bbuf (index+ i 0)) (write-image-load-byte 0 pixel 24)) (setf (aref buffer-bbuf (index+ i 1)) (write-image-load-byte 8 pixel 24)) (setf (aref buffer-bbuf (index+ i 2)) (write-image-load-byte 16 pixel 24))))))) t) #+lispm (defun fast-write-pixarray-using-bitblt (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel) (#+Genera sys:stack-let* #-Genera let* ((dimensions (list (+ y height) (floor (* padded-bytes-per-line 8) bits-per-pixel))) (a (make-array dimensions :element-type (array-element-type pixarray) :displaced-to bbuf :displaced-index-offset (floor (* boffset 8) bits-per-pixel)))) (sys:bitblt boole-1 width height pixarray x y a 0 0)) t) #+(or CMU sbcl) (defun fast-write-pixarray-using-bitblt (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel) #.(declare-buffun) (copy-bit-rect pixarray (index* (array-dimension pixarray 1) bits-per-pixel) x y bbuf (index* padded-bytes-per-line #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) (index* boffset #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) 0 height (index* width bits-per-pixel)) t) #+(or Genera lcl3.0 excl) (defun fast-write-pixarray-with-swap (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type pixarray pixarray) (type card16 x y width height) (type array-index boffset padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (unless (index= bits-per-pixel 24) (let ((pixarray-padded-bits-per-line (if (index= height 1) 0 (index* (index- (array-row-major-index pixarray 1 0) (array-row-major-index pixarray 0 0)) bits-per-pixel))) (pixarray-start-bit-offset (index* (array-row-major-index pixarray y x) bits-per-pixel))) (declare (type array-index pixarray-padded-bits-per-line pixarray-start-bit-offset)) (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) (index-zerop (index-mod pixarray-start-bit-offset 8))) (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) (multiple-value-bind (image-swap-function image-swap-lsb-first-p) (image-swap-function bits-per-pixel +image-unit+ *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p* unit byte-lsb-first-p bit-lsb-first-p) (declare (type symbol image-swap-function) (type generalized-boolean image-swap-lsb-first-p)) (with-underlying-simple-vector (src card8 pixarray) (funcall (symbol-function image-swap-function) src bbuf (index-floor pixarray-start-bit-offset 8) boffset (index-ceiling (index* width bits-per-pixel) 8) (index-floor pixarray-padded-bits-per-line 8) padded-bytes-per-line height image-swap-lsb-first-p)) t))))) (defun fast-write-pixarray (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type pixarray pixarray) (type card16 x y width height) (type array-index boffset padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (progn bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (or #+(or Genera lcl3.0 excl) (fast-write-pixarray-with-swap bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (let ((function (or #+lispm (and (= (sys:array-element-size pixarray) bits-per-pixel) (zerop (index-mod padded-bytes-per-line 4)) (zerop (index-mod (* #+Genera (sys:array-row-span pixarray) #-Genera (array-dimension pixarray 1) bits-per-pixel) 32)) #'fast-write-pixarray-using-bitblt) #+(or CMU) (and (index= (pixarray-element-size pixarray) bits-per-pixel) #'fast-write-pixarray-using-bitblt) #+(or lcl3.0 excl) (and (index= bits-per-pixel 1) #'fast-write-pixarray-1) #+(or lcl3.0 excl) (and (index= bits-per-pixel 4) #'fast-write-pixarray-4) #+(or Genera lcl3.0 excl CMU) (and (index= bits-per-pixel 24) #'fast-write-pixarray-24)))) (when function (write-pixarray-internal bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel function +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+ unit byte-lsb-first-p bit-lsb-first-p))))) ;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another (defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel) (declare (type pixarray pixarray copy) (type card16 x y width height) (type (member 1 4 8 16 24 32) bits-per-pixel)) (progn pixarray copy x y width height bits-per-pixel nil) (or #+(or lispm CMU) (let* ((pixarray-padded-pixels-per-line #+Genera (sys:array-row-span pixarray) #-Genera (array-dimension pixarray 1)) (pixarray-padded-bits-per-line (* pixarray-padded-pixels-per-line bits-per-pixel)) (copy-padded-pixels-per-line #+Genera (sys:array-row-span copy) #-Genera (array-dimension copy 1)) (copy-padded-bits-per-line (* copy-padded-pixels-per-line bits-per-pixel))) #-(or CMU) (when (and (= (sys:array-element-size pixarray) bits-per-pixel) (zerop (index-mod pixarray-padded-bits-per-line 32)) (zerop (index-mod copy-padded-bits-per-line 32))) (sys:bitblt boole-1 width height pixarray x y copy 0 0) t) #+(or CMU) (when (index= (pixarray-element-size pixarray) (pixarray-element-size copy) bits-per-pixel) (copy-bit-rect pixarray pixarray-padded-bits-per-line x y copy copy-padded-bits-per-line 0 0 height (index* width bits-per-pixel)) t)) #+(or lcl3.0 excl) (unless (index= bits-per-pixel 24) (let ((pixarray-padded-bits-per-line (if (index= height 1) 0 (index* (index- (array-row-major-index pixarray 1 0) (array-row-major-index pixarray 0 0)) bits-per-pixel))) (copy-padded-bits-per-line (if (index= height 1) 0 (index* (index- (array-row-major-index copy 1 0) (array-row-major-index copy 0 0)) bits-per-pixel))) (pixarray-start-bit-offset (index* (array-row-major-index pixarray y x) bits-per-pixel))) (declare (type array-index pixarray-padded-bits-per-line copy-padded-bits-per-line pixarray-start-bit-offset)) (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) (index-zerop (index-mod copy-padded-bits-per-line 8)) (index-zerop (index-mod pixarray-start-bit-offset 8))) (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) (index-zerop (index-mod copy-padded-bits-per-line +image-unit+)) (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) (with-underlying-simple-vector (src card8 pixarray) (with-underlying-simple-vector (dst card8 copy) (image-noswap src dst (index-floor pixarray-start-bit-offset 8) 0 (index-ceiling (index* width bits-per-pixel) 8) (index-floor pixarray-padded-bits-per-line 8) (index-floor copy-padded-bits-per-line 8) height nil))) t))) #+(or lcl3.0 excl) (macrolet ((copy (type element-type) `(let ((pixarray pixarray) (copy copy)) (declare (type ,type pixarray copy)) #.(declare-buffun) (with-underlying-simple-vector (src ,element-type pixarray) (with-underlying-simple-vector (dst ,element-type copy) (do* ((dst-y 0 (index1+ dst-y)) (src-y y (index1+ src-y))) ((index>= dst-y height)) (declare (type card16 dst-y src-y)) (do* ((dst-idx (array-row-major-index copy dst-y 0) (index1+ dst-idx)) (dst-end (index+ dst-idx width)) (src-idx (array-row-major-index pixarray src-y x) (index1+ src-idx))) ((index>= dst-idx dst-end)) (declare (type array-index dst-idx src-idx dst-end)) (setf (aref dst dst-idx) (the ,element-type (aref src src-idx)))))))))) (ecase bits-per-pixel (1 (copy pixarray-1 pixarray-1-element-type)) (4 (copy pixarray-4 pixarray-4-element-type)) (8 (copy pixarray-8 pixarray-8-element-type)) (16 (copy pixarray-16 pixarray-16-element-type)) (24 (copy pixarray-24 pixarray-24-element-type)) (32 (copy pixarray-32 pixarray-32-element-type))) t))) cl-clx-sbcl-0.7.4.20160323.orig/README-R50000644000175000017500000000355712715665271014777 0ustar pdmpdm Original CLX README, retained for historical information --- These files contain beta code, but they have been tested to some extent under Symbolics, TI, Lucid and Franz. The files have been given .l suffixes to keep them within 12 characters, to keep SysV sites happy. Please rename them with more appropriate suffixes for your system. For Franz systems, see exclREADME. For Symbolics systems, first rename all the .l files to .lisp. Then edit your sys.translations file so that sys:x11;clx; points to this directory and put a clx.system file in your sys:site;directory that has the form (si:set-system-source-file "clx" "sys:x11;clx;defsystem.lisp") in it. After that CLX can be compiled with the "Compile System CLX" command and loaded with the "Load System CLX" command. For TI systems, rename all the .l files to .lisp, and make a clx.translations file in your sys:site; directory pointing to this directory and a sys:site;clx.system file like the one described for symbolics systems above, but with the defsystem file being in the clx:clx; directory. Then CLX can be compiled with (make-system "CLX" :compile :noconfirm) and loaded with (make-system "CLX" :noconfirm). For Lucid systems, you should rename all the .l files to .lisp too (This might not be possible on SysV systems). After loading the defsystem.l file, CLX can be compiled with the (compile-clx) function and loaded with the (load-clx) form. The ms-patch.uu file is a patch to Lucid version 2 systems. You probably don't need it, as you are probably running Lucid version 3 or later, but if you are still using Lucid version 2, you need this patch. You'll need to uudecode it to produce the binary. For kcl systems, after loading the defsystem.l file, CLX can be compiled with the (compile-clx) function and loaded with the (load-clx) form. For more information, see defsystem.l and provide.l. cl-clx-sbcl-0.7.4.20160323.orig/depdefs.lisp0000644000175000017500000005640712715665272016141 0ustar pdmpdm;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;; This file contains some of the system dependent code for CLX ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (in-package :xlib) ;;;------------------------------------------------------------------------- ;;; Declarations ;;;------------------------------------------------------------------------- ;;; fix a bug in kcl's RATIONAL... ;;; redefine both the function and the type. #+(or kcl ibcl) (progn (defun rational (x) (if (rationalp x) x (lisp:rational x))) (deftype rational (&optional l u) `(lisp:rational ,l ,u))) ;;; DECLAIM #-clx-ansi-common-lisp (defmacro declaim (&rest decl-specs) (if (cdr decl-specs) `(progn ,@(mapcar #'(lambda (decl-spec) `(proclaim ',decl-spec)) decl-specs)) `(proclaim ',(car decl-specs)))) ;;; CLX-VALUES value1 value2 ... -- Documents the values returned by the function. #-Genera (declaim (declaration clx-values)) #+Genera (setf (get 'clx-values 'si:declaration-alias) 'scl:values) ;;; ARGLIST arg1 arg2 ... -- Documents the arglist of the function. Overrides ;;; the documentation that might get generated by the real arglist of the ;;; function. #-(or lispm lcl3.0) (declaim (declaration arglist)) ;;; DYNAMIC-EXTENT var -- Tells the compiler that the rest arg var has ;;; dynamic extent and therefore can be kept on the stack and not copied to ;;; the heap, even though the value is passed out of the function. #-(or clx-ansi-common-lisp lcl3.0) (declaim (declaration dynamic-extent)) ;;; IGNORABLE var -- Tells the compiler that the variable might or might not be used. #-clx-ansi-common-lisp (declaim (declaration ignorable)) ;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to ;;; indent calls to the function or macro containing the declaration. #-genera (declaim (declaration indentation)) ;;;------------------------------------------------------------------------- ;;; Declaration macros ;;;------------------------------------------------------------------------- ;;; WITH-VECTOR (variable type) &body body --- ensures the variable is a local ;;; and then does a type declaration and array register declaration (defmacro with-vector ((var type) &body body) `(let ((,var ,var)) (declare (type ,type ,var)) ,@body)) ;;; WITHIN-DEFINITION (name type) &body body --- Includes definitions for ;;; Meta-. #+lispm (defmacro within-definition ((name type) &body body) `(zl:local-declare ((sys:function-parent ,name ,type)) (sys:record-source-file-name ',name ',type) ,@body)) #-lispm (defmacro within-definition ((name type) &body body) (declare (ignore name type)) `(progn ,@body)) ;;;------------------------------------------------------------------------- ;;; CLX can maintain a mapping from X server ID's to local data types. If ;;; one takes the view that CLX objects will be instance variables of ;;; objects at the next higher level, then PROCESS-EVENT will typically map ;;; from resource-id to higher-level object. In that case, the lower-level ;;; CLX mapping will almost never be used (except in rare cases like ;;; query-tree), and only serve to consume space (which is difficult to ;;; GC), in which case always-consing versions of the make-s will ;;; be better. Even when maps are maintained, it isn't clear they are ;;; useful for much beyond xatoms and windows (since almost nothing else ;;; ever comes back in events). ;;;-------------------------------------------------------------------------- (defconstant +clx-cached-types+ '(drawable window pixmap ;; gcontext cursor colormap font)) (defmacro resource-id-map-test () #+excl '#'equal #-excl '#'eql) ; (eq fixnum fixnum) is not guaranteed. (defmacro atom-cache-map-test () #+excl '#'equal #-excl '#'eq) (defmacro keysym->character-map-test () #+excl '#'equal #-excl '#'eql) ;;; You must define this to match the real byte order. It is used by ;;; overlapping array and image code. #+(or lispm vax (and (not sbcl) little-endian) Minima) (eval-when (eval compile load) (pushnew :clx-little-endian *features*)) #+lcl3.0 (eval-when (compile eval load) (ecase lucid::machine-endian (:big nil) (:little (pushnew :clx-little-endian *features*)))) #+cmu (eval-when (compile eval load) (ecase #.(c:backend-byte-order c:*backend*) (:big-endian) (:little-endian (pushnew :clx-little-endian *features*)))) #+sbcl (eval-when (:compile-toplevel :load-toplevel :execute) ;; FIXME: Ideally, we shouldn't end up with the internal ;; :CLX-LITTLE-ENDIAN decorating user-visible *FEATURES* lists. ;; This probably wants to be split up into :compile-toplevel ;; :execute and :load-toplevel clauses, so that loading the compiled ;; code doesn't push the feature. (ecase sb-c:*backend-byte-order* (:big-endian) (:little-endian (pushnew :clx-little-endian *features*)))) ;;; Steele's Common-Lisp states: "It is an error if the array specified ;;; as the :displaced-to argument does not have the same :element-type ;;; as the array being created" If this is the case on your lisp, then ;;; leave the overlapping-arrays feature turned off. Lisp machines ;;; (Symbolics TI and LMI) don't have this restriction, and allow arrays ;;; with different element types to overlap. CLX will take advantage of ;;; this to do fast array packing/unpacking when the overlapping-arrays ;;; feature is enabled. #+clisp (eval-when (:compile-toplevel :load-toplevel :execute) (unless system::*big-endian* (pushnew :clx-little-endian *features*))) #+(and clx-little-endian lispm) (eval-when (eval compile load) (pushnew :clx-overlapping-arrays *features*)) #+(and clx-overlapping-arrays genera) (progn (deftype overlap16 () '(unsigned-byte 16)) (deftype overlap32 () '(signed-byte 32)) ) #+(and clx-overlapping-arrays (or explorer lambda cadr)) (progn (deftype overlap16 () '(unsigned-byte 16)) (deftype overlap32 () '(unsigned-byte 32)) ) (deftype buffer-bytes () `(simple-array (unsigned-byte 8) (*))) #+clx-overlapping-arrays (progn (deftype buffer-words () `(vector overlap16)) (deftype buffer-longs () `(vector overlap32)) ) ;;; This defines a type which is a subtype of the integers. ;;; This type is used to describe all variables that can be array indices. ;;; It is here because it is used below. ;;; This is inclusive because start/end can be 1 past the end. (deftype array-index () `(integer 0 ,array-dimension-limit)) ;; this is the best place to define these? #-Genera (progn (defun make-index-typed (form) (if (constantp form) form `(the array-index ,form))) (defun make-index-op (operator args) `(the array-index (values ,(case (length args) (0 `(,operator)) (1 `(,operator ,(make-index-typed (first args)))) (2 `(,operator ,(make-index-typed (first args)) ,(make-index-typed (second args)))) (otherwise `(,operator ,(make-index-op operator (subseq args 0 (1- (length args)))) ,(make-index-typed (first (last args))))))))) (defmacro index+ (&rest numbers) (make-index-op '+ numbers)) (defmacro index-logand (&rest numbers) (make-index-op 'logand numbers)) (defmacro index-logior (&rest numbers) (make-index-op 'logior numbers)) (defmacro index- (&rest numbers) (make-index-op '- numbers)) (defmacro index* (&rest numbers) (make-index-op '* numbers)) (defmacro index1+ (number) (make-index-op '1+ (list number))) (defmacro index1- (number) (make-index-op '1- (list number))) (defmacro index-incf (place &optional (delta 1)) (make-index-op 'incf (list place delta))) (defmacro index-decf (place &optional (delta 1)) (make-index-op 'decf (list place delta))) (defmacro index-min (&rest numbers) (make-index-op 'min numbers)) (defmacro index-max (&rest numbers) (make-index-op 'max numbers)) (defmacro index-floor (number divisor) (make-index-op 'floor (list number divisor))) (defmacro index-ceiling (number divisor) (make-index-op 'ceiling (list number divisor))) (defmacro index-truncate (number divisor) (make-index-op 'truncate (list number divisor))) (defmacro index-mod (number divisor) (make-index-op 'mod (list number divisor))) (defmacro index-ash (number count) (make-index-op 'ash (list number count))) (defmacro index-plusp (number) `(plusp (the array-index ,number))) (defmacro index-zerop (number) `(zerop (the array-index ,number))) (defmacro index-evenp (number) `(evenp (the array-index ,number))) (defmacro index-oddp (number) `(oddp (the array-index ,number))) (defmacro index> (&rest numbers) `(> ,@(mapcar #'make-index-typed numbers))) (defmacro index= (&rest numbers) `(= ,@(mapcar #'make-index-typed numbers))) (defmacro index< (&rest numbers) `(< ,@(mapcar #'make-index-typed numbers))) (defmacro index>= (&rest numbers) `(>= ,@(mapcar #'make-index-typed numbers))) (defmacro index<= (&rest numbers) `(<= ,@(mapcar #'make-index-typed numbers))) ) #+Genera (progn (defmacro index+ (&rest numbers) `(+ ,@numbers)) (defmacro index-logand (&rest numbers) `(logand ,@numbers)) (defmacro index-logior (&rest numbers) `(logior ,@numbers)) (defmacro index- (&rest numbers) `(- ,@numbers)) (defmacro index* (&rest numbers) `(* ,@numbers)) (defmacro index1+ (number) `(1+ ,number)) (defmacro index1- (number) `(1- ,number)) (defmacro index-incf (place &optional (delta 1)) `(setf ,place (index+ ,place ,delta))) (defmacro index-decf (place &optional (delta 1)) `(setf ,place (index- ,place ,delta))) (defmacro index-min (&rest numbers) `(min ,@numbers)) (defmacro index-max (&rest numbers) `(max ,@numbers)) (defun positive-power-of-two-p (x) (when (symbolp x) (multiple-value-bind (constantp value) (lt:named-constant-p x) (when constantp (setq x value)))) (and (typep x 'fixnum) (plusp x) (zerop (logand x (1- x))))) (defmacro index-floor (number divisor) (cond ((eql divisor 1) number) ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor)) `(si:%fixnum-floor ,number ,divisor)) (t `(floor ,number ,divisor)))) (defmacro index-ceiling (number divisor) (cond ((eql divisor 1) number) ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-ceiling)) `(si:%fixnum-ceiling ,number ,divisor)) (t `(ceiling ,number ,divisor)))) (defmacro index-truncate (number divisor) (cond ((eql divisor 1) number) ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor)) `(si:%fixnum-floor ,number ,divisor)) (t `(truncate ,number ,divisor)))) (defmacro index-mod (number divisor) (cond ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-mod)) `(si:%fixnum-mod ,number ,divisor)) (t `(mod ,number ,divisor)))) (defmacro index-ash (number count) (cond ((eql count 0) number) ((and (typep count 'fixnum) (minusp count) (fboundp 'si:%fixnum-floor)) `(si:%fixnum-floor ,number ,(expt 2 (- count)))) ((and (typep count 'fixnum) (plusp count) (fboundp 'si:%fixnum-multiply)) `(si:%fixnum-multiply ,number ,(expt 2 count))) (t `(ash ,number ,count)))) (defmacro index-plusp (number) `(plusp ,number)) (defmacro index-zerop (number) `(zerop ,number)) (defmacro index-evenp (number) `(evenp ,number)) (defmacro index-oddp (number) `(oddp ,number)) (defmacro index> (&rest numbers) `(> ,@numbers)) (defmacro index= (&rest numbers) `(= ,@numbers)) (defmacro index< (&rest numbers) `(< ,@numbers)) (defmacro index>= (&rest numbers) `(>= ,@numbers)) (defmacro index<= (&rest numbers) `(<= ,@numbers)) ) ;;;; Stuff for BUFFER definition (defconstant +replysize+ 32.) ;; used in defstruct initializations to avoid compiler warnings (defvar *empty-bytes* (make-sequence 'buffer-bytes 0)) (declaim (type buffer-bytes *empty-bytes*)) #+clx-overlapping-arrays (progn (defvar *empty-words* (make-sequence 'buffer-words 0)) (declaim (type buffer-words *empty-words*)) ) #+clx-overlapping-arrays (progn (defvar *empty-longs* (make-sequence 'buffer-longs 0)) (declaim (type buffer-longs *empty-longs*)) ) (defstruct (reply-buffer (:conc-name reply-) (:constructor make-reply-buffer-internal) (:copier nil) (:predicate nil)) (size 0 :type array-index) ;Buffer size ;; Byte (8 bit) input buffer (ibuf8 *empty-bytes* :type buffer-bytes) ;; Word (16bit) input buffer #+clx-overlapping-arrays (ibuf16 *empty-words* :type buffer-words) ;; Long (32bit) input buffer #+clx-overlapping-arrays (ibuf32 *empty-longs* :type buffer-longs) (next nil #-explorer :type #-explorer (or null reply-buffer)) (data-size 0 :type array-index) ) (defconstant +buffer-text16-size+ 256) (deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,+buffer-text16-size+))) ;; These are here because. (defparameter *xlib-package* (find-package :xlib)) (defun xintern (&rest parts) (intern (apply #'concatenate 'string (mapcar #'string parts)) *xlib-package*)) (defparameter *keyword-package* (find-package :keyword)) (defun kintern (name) (intern (string name) *keyword-package*)) ;;; Pseudo-class mechanism. (eval-when (:compile-toplevel :load-toplevel :execute) ;; FIXME: maybe we should reevaluate this? (defvar *def-clx-class-use-defclass* #+(or Genera allegro) t #+(and cmu pcl) '(XLIB:DRAWABLE XLIB:WINDOW XLIB:PIXMAP) #+(and cmu (not pcl)) nil #-(or Genera cmu allegro) 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 #+clx-ansi-common-lisp (find-package :common-lisp) #-clx-ansi-common-lisp (or (find-package :clos) (find-package :pcl) (let ((lisp-pkg (find-package :lisp))) (and (find-symbol (string 'defclass) lisp-pkg) lisp-pkg)))) (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 #+allegro `(progn (,(closintern 'defmethod) ,predicate (object) (declare (ignore object)) nil) (,(closintern 'defmethod) ,predicate ((object ,name)) t)) #-allegro `(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)))) #+Genera (progn (scl:defprop def-clx-class "CLX Class" si:definition-type-name) (scl:defprop def-clx-class zwei:defselect-function-spec-finder zwei:definition-function-spec-finder)) ;; We need this here so we can define DISPLAY for CLX. ;; ;; This structure is :INCLUDEd in the DISPLAY structure. ;; Overlapping (displaced) arrays are provided for byte ;; half-word and word access on both input and output. ;; (def-clx-class (buffer (:constructor nil) (:copier nil) (:predicate nil)) ;; Lock for multi-processing systems (lock (make-process-lock "CLX Buffer Lock")) #-excl (output-stream nil :type (or null stream)) #+excl (output-stream -1 :type fixnum) ;; Buffer size (size 0 :type array-index) (request-number 0 :type (unsigned-byte 16)) ;; Byte position of start of last request ;; used for appending requests and error recovery (last-request nil :type (or null array-index)) ;; Byte position of start of last flushed request (last-flushed-request nil :type (or null array-index)) ;; Current byte offset (boffset 0 :type array-index) ;; Byte (8 bit) output buffer (obuf8 *empty-bytes* :type buffer-bytes) ;; Word (16bit) output buffer #+clx-overlapping-arrays (obuf16 *empty-words* :type buffer-words) ;; Long (32bit) output buffer #+clx-overlapping-arrays (obuf32 *empty-longs* :type buffer-longs) ;; Holding buffer for 16-bit text (tbuf16 (make-sequence 'buffer-text16 +buffer-text16-size+ :initial-element 0)) ;; Probably EQ to Output-Stream #-excl (input-stream nil :type (or null stream)) #+excl (input-stream -1 :type fixnum) ;; T when the host connection has gotten errors (dead nil :type (or null (not null))) ;; T makes buffer-flush a noop. Manipulated with with-buffer-flush-inhibited. (flush-inhibit nil :type (or null (not null))) ;; Change these functions when using shared memory buffers to the server ;; Function to call when writing the buffer (write-function 'buffer-write-default) ;; Function to call when flushing the buffer (force-output-function 'buffer-force-output-default) ;; Function to call when closing a connection (close-function 'buffer-close-default) ;; Function to call when reading the buffer (input-function 'buffer-read-default) ;; Function to call to wait for data to be input (input-wait-function 'buffer-input-wait-default) ;; Function to call to listen for input data (listen-function 'buffer-listen-default) #+Genera (debug-io nil :type (or null stream)) ) ;;----------------------------------------------------------------------------- ;; Printing routines. ;;----------------------------------------------------------------------------- #-(or clx-ansi-common-lisp Genera) (defun print-unreadable-object-function (object stream type identity function) (declare #+lispm (sys:downward-funarg function)) (princ "#<" stream) (when type (let ((type (type-of object)) (pcl-package (find-package :pcl))) ;; Handle pcl type-of lossage (when (and pcl-package (symbolp type) (eq (symbol-package type) pcl-package) (string-equal (symbol-name type) "STD-INSTANCE")) (setq type (funcall (intern (symbol-name 'class-name) pcl-package) (funcall (intern (symbol-name 'class-of) pcl-package) object)))) (prin1 type stream))) (when (and type function) (princ " " stream)) (when function (funcall function)) (when (and (or type function) identity) (princ " " stream)) (when identity (princ "???" stream)) (princ ">" stream) nil) #-(or clx-ansi-common-lisp Genera) (defmacro print-unreadable-object ((object stream &key type identity) &body body) (if body `(flet ((.print-unreadable-object-body. () ,@body)) (print-unreadable-object-function ,object ,stream ,type ,identity #'.print-unreadable-object-body.)) `(print-unreadable-object-function ,object ,stream ,type ,identity nil))) ;;----------------------------------------------------------------------------- ;; 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) ;;----------------------------------------------------------------------------- ;; Foreign Functions ;;----------------------------------------------------------------------------- #+(and lucid apollo (not lcl3.0)) (lucid::define-foreign-function '(connect-to-server "connect_to_server") '((:val host :string) (:val display :integer32)) :integer32) #+(and lucid (not apollo) (not lcl3.0)) (lucid::define-c-function connect-to-server (host display) :result-type :integer) #+lcl3.0 (lucid::def-foreign-function (connect-to-server (:language :c) (:return-type :signed-32bit)) (host :simple-string) (display :signed-32bit)) ;;----------------------------------------------------------------------------- ;; Finding the server socket ;;----------------------------------------------------------------------------- ;; These are here because dep-openmcl.lisp, dep-lispworks.lisp and ;; dependent.lisp need them (defconstant +X-unix-socket-path+ "/tmp/.X11-unix/X" "The location of the X socket") (defun unix-socket-path-from-host (host display) "Return the name of the unix domain socket for host and display, or nil if a network socket should be opened." (cond ((or (string= host "") (string= host "unix")) (format nil "~A~D" +X-unix-socket-path+ display)) #+darwin ((or (and (> (length host) 10) (string= host "tmp/launch" :end1 10)) (and (> (length host) 29) (string= host "private/tmp/com.apple.launchd" :end1 29))) (format nil "/~A:~D" host display)) (t nil))) cl-clx-sbcl-0.7.4.20160323.orig/shape.lisp0000644000175000017500000001564612715665272015627 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- ;;; --------------------------------------------------------------------------- ;;; Title: X11 Shape extension ;;; Created: 1999-05-14 11:31 ;;; Author: Gilbert Baumann ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1999 by Gilbert Baumann ;;; ;;; Permission is granted to any individual or institution to use, ;;; copy, modify, and distribute this software, provided that this ;;; complete copyright and permission notice is maintained, intact, in ;;; all copies and supporting documentation. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ;;; ;;; Use xc/doc/hardcopy/Xext/shape.PS.gz obtainable from e.g. ;; ftp://ftp.xfree86.org/pub/XFree86/current/untarred/xc/hardcopy/Xext/shape.PS.gz (in-package :xlib) (export '(shape-query-version shape-rectangles shape-mask shape-combine shape-offset shape-query-extents shape-select-input shape-input-selected-p shape-get-rectangles) :xlib) (define-extension "SHAPE" :events (:shape-notify)) (declare-event :shape-notify ((data (member8 :bounding :clip)) kind) ;shape kind (card16 sequence) (window (window event-window)) ;affected window (int16 x) ;extents (int16 y) (card16 width) (card16 height) ((or null card32) time) ;timestamp (boolean shaped-p)) (defun encode-shape-kind (kind) (ecase kind (:bounding 0) (:clip 1))) (defun encode-shape-operation (operation) (ecase operation (:set 0) (:union 1) (:interset 2) (:subtract 3) (:invert 4))) (defun encode-shape-rectangle-ordering (ordering) (ecase ordering ((:unsorted :un-sorted nil) 0) ((:y-sorted) 1) ((:yx-sorted) 2) ((:yx-banded) 3))) (defun shape-query-version (display) (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") nil :sizes 16) ((data 0)) (values (card16-get 8) (card16-get 10)))) (defun shape-rectangles (window rectangles &key (kind :bounding) (x-offset 0) (y-offset 0) (operation :set) (ordering :unsorted)) (let* ((display (xlib:window-display window))) (with-buffer-request (display (extension-opcode display "SHAPE")) (data 1) (card8 (encode-shape-operation operation)) (card8 (encode-shape-kind kind)) (card8 (encode-shape-rectangle-ordering ordering)) (card8 0) ;unused (window window) (int16 x-offset) (int16 y-offset) ((sequence :format int16) rectangles)))) (defun shape-mask (window pixmap &key (kind :bounding) (x-offset 0) (y-offset 0) (operation :set)) (let* ((display (xlib:window-display window))) (with-buffer-request (display (extension-opcode display "SHAPE")) (data 2) (card8 (encode-shape-operation operation)) (card8 (encode-shape-kind kind)) (card16 0) ;unused (window window) (int16 x-offset) (int16 y-offset) ((or pixmap (member :none)) pixmap)))) (defun shape-combine (window source-window &key (kind :bounding) (source-kind :bounding) (x-offset 0) (y-offset 0) (operation :set)) (let* ((display (xlib:window-display window))) (with-buffer-request (display (extension-opcode display "SHAPE")) (data 3) (card8 (encode-shape-operation operation)) (card8 (encode-shape-kind kind)) (card8 (encode-shape-kind source-kind)) (card8 0) ;unused (window window) (int16 x-offset) (int16 y-offset) (window source-window)))) (defun shape-offset (window &key (kind :bounding) (x-offset 0) (y-offset 0)) (let* ((display (xlib:window-display window))) (with-buffer-request (display (extension-opcode display "SHAPE")) (data 4) (card8 (encode-shape-kind kind)) (card8 0) (card8 0) (card8 0) ;unused (window window) (int16 x-offset) (int16 y-offset)))) (defun shape-query-extents (window) (let* ((display (xlib:window-display window))) (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") nil :sizes (8 16 32)) ((data 5) (window window)) (values (boolean-get 8) ;bounding shaped (boolean-get 9) ;clip shaped (int16-get 12) ;bounding shape extents x (int16-get 14) ;bounding shape extents y (card16-get 16) ;bounding shape extents width (card16-get 18) ;bounding shape extents height (int16-get 20) ;clip shape extents x (int16-get 22) ;clip shape extents y (card16-get 24) ;clip shape extents width (card16-get 26))))) ;clip shape extents height (defun shape-select-input (window selected-p) (let* ((display (window-display window))) (with-buffer-request (display (extension-opcode display "SHAPE")) (data 6) (window window) (boolean selected-p)) )) (defun shape-input-selected-p (window) (let* ((display (window-display window))) (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") nil :sizes (8)) ((data 7) ;also wrong in documentation (window window)) (boolean-get 1)))) (defun shape-get-rectangles (window &optional (kind :bounding) (result-type 'list)) (let* ((display (window-display window))) (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") nil :sizes (8 16 32)) ((data 8) ;this was wrong in the specification (window window) (card8 (ecase kind (:bounding 0) (:clip 1)))) (values (sequence-get :length (print (* 4 (card32-get 8))) :result-type result-type :format int16 :index +replysize+) (ecase (card8-get 1) (0 :unsorted) (1 :y-sorted) (2 :yx-sorted) (3 :yx-banded) ))))) cl-clx-sbcl-0.7.4.20160323.orig/screensaver.lisp0000644000175000017500000000532012715665272017033 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- ;;; --------------------------------------------------------------------------- ;;; Title: X11 MIT Screensaver extension ;;; Created: 2005-08-28 01:41 ;;; Author: Istvan Marko ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2005 by Istvan Marko ;;; ;;; 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. ;;; ;;; Description: ;;; ;;; This is a partial interface to the MIT-SCREEN-SAVER ;;; extension. Only the ScreenSaverQueryVersion and ;;; ScreenSaverQueryInfo requests are implemented because I couldn't ;;; think of a use for the rest. In fact, the only use I see for this ;;; extension is screen-saver-get-idle which provides and easy way to ;;; find out how long has it been since the last keyboard or mouse ;;; activity. ;;; A description of this extension can be found at ;;; doc/hardcopy/saver/saver.PS.gz in the X11 distribution. (in-package :xlib) (export '(screen-saver-query-version screen-saver-query-info screen-saver-get-idle) :xlib) (define-extension "MIT-SCREEN-SAVER") (defun screen-saver-query-version (display) (with-buffer-request-and-reply (display (extension-opcode display "MIT-SCREEN-SAVER") nil) ((data 0) (card8 1) ;client major version (card8 0) ;client minor version (card16 0)) ; unused (values (card16-get 8) ; server major version (card16-get 10)))) ; server minor version (defun screen-saver-query-info (display drawable) (with-buffer-request-and-reply (display (extension-opcode display "MIT-SCREEN-SAVER") nil) ((data 1) (drawable drawable)) (values (card8-get 1) ; state: off, on, disabled (window-get 8) ; screen saver window if active (card32-get 12) ; tilorsince msecs. how soon before the screen saver kicks in or how long has it been active (card32-get 16) ; idle msecs (card8-get 24)))) ; kind: Blanked, Internal, External (defun screen-saver-get-idle (display drawable) "How long has it been since the last keyboard or mouse input" (multiple-value-bind (state window tilorsince idle kind) (screen-saver-query-info display drawable) (declare (ignore state window kind)) (values idle tilorsince))) cl-clx-sbcl-0.7.4.20160323.orig/CHANGES0000644000175000017500000000332512715665271014617 0ustar pdmpdmDetails of changes since R5: NOTE: this file is not updated any more. Changes since checking into version control can be found from darcs in some way shape or form. There may however be some Dark Ages between when this file was last updated and the version that was the initial version control checkin. Changes in CLX 5.02: Replace LCL:ENVIRONMENT-VALUE with LCL:ENVIRONMENT-VARIABLE. Fix a declaration in the DEFINE-ERROR macro. Quote type argument to TYPE-CHECK consistently. Changes in CLX 5.01: Support for MIT-MAGIC-COOKIE-1 authorization has been added. All VALUES declarations have been changed to CLX-VALUES declarations. VALUES is a CL type name and cannot be used as a declaration name. All ARRAY-REGISTER declarations have been removed as Genera no longer needs them. Many type declarations have been corrected or tightened up now that some Lisps look at them. Print functions have been defined for bitmap and pixmap formats. The DISPLAY-PLIST slot will be initialized to NIL. When debugging, don't optimize SPEED in the buffer macros. Make the CARD8<->CHAR and the window manager code work for sparse character sets (where some codes do not have corresponding characters). The default gcontext extension set and copy functions will take the correct number of arguments. PUT-IMAGE will now work for 24-bit images. The buffer accessors for MEMBER8, etc., will use the standard mechanisms for reporting type errors. Typographical errors in SET-WM-PROPERTIES, SET-STANDARD-COLORMAP, and POINTER-CONTROL have been fixed. Symbolics systems will do lazy macroexpansion in the buffer macros. A variety of changes for Symbolics Minima systems have been made. Some system-dependent code has been added for CMU Common Lisp.