cgit.sxemacs.org Git - packages/blob - xemacs-packages/xlib/lisp/xlib-xc.el

   1 ;;; xlib-xc.el --- X Connection.
   2
   3 ;; Copyright (C) 2003-2005 by XWEM Org.
   4
   5 ;; Author: Zajcev Evgeny <zevlg@yandex.ru>
   6 ;; Created: 18 October 2003
   7 ;; Keywords: xlib, xwem
   8 ;; X-CVS: $Id: xlib-xc.el,v 1.7 2005-04-04 19:55:29 lg Exp $
   9 ;; X-URL: http://lgarc.narod.ru/xwem/index.html
  10
  11 ;; This file is part of XWEM.
  12
  13 ;; XWEM is free software; you can redistribute it and/or modify it
  14 ;; under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; XWEM is distributed in the hope that it will be useful, but WITHOUT
  19 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  20 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
  21 ;; License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  25 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  26 ;; 02111-1307, USA.
  27
  28 ;;; Synched up with: Not in FSF
  29
  30 ;;; Commentary:
  31
  32 ;;
  33
  34 ;;; Code:
  35
  36 (eval-when-compile
  37   (require 'cl)
  38
  39   (mapc (lambda (el)
  40           (autoload el "xlib-xwin"))
  41         '(X-Win-event-handlers X-Win-EventHandler-runall make-X-Rect
  42           X-Win-find-or-make X-Atom-find-or-make X-Win-p))
  43   )
  44
  45 (require 'xlib-math)
  46 (require 'xlib-const)
  47
  48 (defvar X-Dpy-dpys-list nil
  49   "List of all opened displays.")
  50
  51 (defstruct X-Visual
  52   id
  53   class
  54   bits-per-rgb
  55   cmap-entries
  56   red-mask
  57   green-mask
  58   blue-mask)
  59
  60 (defstruct X-Depth
  61   depth
  62   visuals)                              ; List of X-Visual
  63
  64 (defstruct X-Screen
  65   dpy                                   ; display
  66   root                                  ; Root window
  67   colormap
  68   white-pixel black-pixel
  69   root-event-mask                       ; Event mask for root window
  70
  71   visualid
  72   backingstores
  73   save-unders
  74   width height                          ; in pixels
  75   mwidth mheight                        ; in millimeters
  76   min-maps max-maps
  77   default-gc
  78   root-depth                            ; Root depth
  79   depths                                ; List of X-Depth
  80   )
  81
  82 (defstruct X-ScreenFormat
  83   depth
  84   bits-per-pixel
  85   scanline-pad)
  86
  87 (defstruct (X-Dpy (:predicate X-Dpy-isxdpy-p))
  88   proc                                  ; process, which holds X connection
  89   log-buffer                            ; buffer for logs, when debugging is non-nil
  90   properties                            ; User defined plist
  91
  92   ;; Protecting section
  93   (readings 0)                          ; non-zero mean we are in reading mode
  94   evq                                   ; saved events queue, normally should be nil
  95
  96   snd-queue                             ; Send queue, each call to
  97                                         ; `X-Dpy-send' adds data to
  98                                         ; this queue
  99
 100   (parse-guess-dispatcher 'X-Dpy-parse-message-guess)
 101   (events-dispatcher 'X-Dpy-default-events-dispatcher)
 102
 103   event-handlers                        ; event handlers, same as in X-Win
 104
 105   message-buffer
 106
 107   ;; X section
 108   name                                  ; display name
 109   proto-maj proto-min                   ; major and minor numbers for X protocol
 110   vendor                                ; Vendor string
 111   min-keycode max-keycode               ; keycodes allowed
 112   resource-base resource-mask (resource-id 1)
 113   (rseq-id 0)                           ; requests sequence number
 114   max-request-size                      ; Maximum request size allowed
 115   motion-bufsize
 116   byte-order                            ; Images byte order
 117
 118   bitmap-scanline-unit
 119   bitmap-scanline-pad
 120   bitmap-bit-order
 121
 122   formats                               ; List of X-ScreenFormat
 123
 124   (default-screen 0)                    ; default screen number
 125   screens                               ; List of X-Screen
 126
 127   error-hooks                           ; Hooks called when X error occurs
 128
 129   ;; Various display lists
 130   atoms                                 ; list of atoms
 131   windows                               ; list of windows
 132   fonts                                 ; list of opened fonts
 133   extensions                            ; list of extensions
 134   )
 135
 136 (defmacro X-Dpy-put-property (xdpy prop val)
 137   "Put property PROP with value VAL in XDPY's properties list."
 138   `(setf (X-Dpy-properties ,xdpy)
 139          (plist-put (X-Dpy-properties ,xdpy) ,prop ,val)))
 140
 141 (defmacro X-Dpy-get-property (xdpy prop)
 142   "Get property PROP from XDPY's properties list."
 143   `(plist-get (X-Dpy-properties ,xdpy) ,prop))
 144
 145 (defsetf X-Dpy-get-property X-Dpy-put-property)
 146
 147 (defmacro X-Dpy-rem-property (xdpy prop)
 148   "Remove property PROP from XDPY's properties list."
 149   `(setf (X-Dpy-properties ,xdpy) (plist-remprop (X-Dpy-properties ,xdpy) ,prop)))
 150
 151 (defsubst X-Dpy-EventHandler-add (dpy handler &optional priority evtypes-list)
 152   "To DPY's event handlers list add HANDLER."
 153   (setf (X-Dpy-event-handlers dpy)
 154         (X-EventHandler-add (X-Dpy-event-handlers dpy) handler priority evtypes-list)))
 155
 156 (defsubst X-Dpy-EventHandler-isset (dpy handler &optional priority evtypes-list)
 157   "Return non-nil if on DPY event HANDLER is set."
 158   (X-EventHandler-isset (X-Dpy-event-handlers dpy) handler priority evtypes-list))
 159
 160 (defsubst X-Dpy-EventHandler-rem (dpy handler &optional priority evtypes-list)
 161   "From DPY's event handlers list, remove HANDLER."
 162   (setf (X-Dpy-event-handlers dpy)
 163         (X-EventHandler-rem (X-Dpy-event-handlers dpy) handler priority evtypes-list)))
 164
 165 (defsubst X-Dpy-EventHandler-enable (dpy handler &optional priority evtypes-list)
 166   "In DPY's list of event handlers activate HANDLER."
 167   (X-EventHandler-enable (X-Dpy-event-handlers dpy) handler priority evtypes-list))
 168
 169 (defsubst X-Dpy-EventHandler-disable (dpy handler &optional priority evtypes-list)
 170   "In DPY's list of event handlers disable HANDLER."
 171   (X-EventHandler-disable (X-Dpy-event-handlers dpy) handler priority evtypes-list))
 172
 173 (defsubst X-Dpy-EventHandler-runall (dpy xev)
 174   "Run all DPY's event handlers on XEV.
 175 Signal `X-Events-stop' to stop events processing."
 176   (X-EventHandler-runall (X-Dpy-event-handlers dpy) xev))
 177
 178 ;; Formats operations
 179 (defun X-formatfind (xdpy depth)
 180   "On display XDPY find proper X-ScreenFormat for gived DEPTH."
 181   (let ((formats (X-Dpy-formats xdpy)))
 182     (while (and formats (not (= depth (X-ScreenFormat-depth (car formats)))))
 183       (setq formats (cdr formats)))
 184
 185     (car formats)))
 186
 187 (defun X-formatint (xdpy depth num)
 188   "On display XDPY convert NUM to string."
 189   (let ((fmt (X-formatfind xdpy depth))
 190         bpp cfun)
 191     (if (not (X-ScreenFormat-p fmt))
 192         ""
 193
 194       (setq bpp (/ (X-ScreenFormat-bits-per-pixel fmt) 8))
 195       (setq cfun (intern (format "int->string%d" bpp)))
 196       (funcall cfun num))))
 197
 198 (defun X-formatpad (xdpy depth str)
 199   "Return padded STR."
 200   (let ((fmt (X-formatfind xdpy depth))
 201         bp)
 202
 203     ;; XXX Can't deal with bits
 204     (if (not (X-ScreenFormat-p fmt))
 205         ;; XXX Assume depth is 1 for bitmaps
 206         str
 207
 208       (setq bp (/ (X-ScreenFormat-scanline-pad fmt) 8))
 209       (concat str
 210               (make-string (% (- bp (% (length str) bp)) bp) ?\x00)))))
 211
 212 (defun X-Dpy-p (xdpy &optional sig)
 213   "Return non-nil if XDPY is X display.
 214 If SIG is given and XDPY is not X display, SIG will be signaled."
 215   (let ((isdpy (X-Dpy-isxdpy-p xdpy)))
 216     (if (and (not isdpy) sig)
 217         (signal 'wrong-type-argument (list sig 'X-Dpy-p xdpy))
 218       isdpy)))
 219
 220 (defun X-Dpy-get-id (xdpy)
 221   "Get id to be used on X display XDPY."
 222   (X-Dpy-p xdpy 'X-Dpy-get-id)
 223
 224   (let* ((newid (X-Dpy-resource-id xdpy))
 225          (newword (float 0))
 226          (bitcnt 0)                     ;bit counter in mask
 227          (idcnt 0)                      ;bit counter in id
 228          (servmask (X-Dpy-resource-mask xdpy)) ;service mask (our unique bits)
 229          (servbase (X-Dpy-resource-base xdpy))) ;service base (always set)
 230     ;; we can say <30 because top 3 bits are always 0
 231     (while (< bitcnt 30)                ;while there is more in the mask
 232       (if (Xtest servmask (Xmask bitcnt))
 233           (progn
 234             (if (Xtest newid (Xmask idcnt)) ;set bit in id if it is
 235                                         ;set in the id value.
 236                 (setq newword (Xmask-or newword (Xmask bitcnt))))
 237             (setq idcnt (1+ idcnt))))   ;inc idcnt when we have a mask match
 238       (setq bitcnt (1+ bitcnt)))        ;always inc bitmask cnter
 239
 240     (incf (X-Dpy-resource-id xdpy))     ;inc to next id counter value
 241     (Xmask-or newword servbase)))       ;return the id with base attached
 242
 243 ;;; Process functions
 244 (defun X-Dpy-create-connection (dname dnum)
 245   "Create X connection to display with name DNAME and number DNUM."
 246
 247   (let* ((xcon (open-network-stream (format "X-%s:%d" dname dnum)
 248                                    nil  ; no buffer
 249                                    dname
 250                                    (+ 6000 dnum)))
 251          (xdpy (make-X-Dpy :proc xcon :name (format "%s:%d" dname dnum))))
 252
 253     (set-process-filter xcon 'X-Dpy-filter)
 254     (set-process-sentinel xcon 'X-Dpy-sentinel)
 255
 256     (add-to-list 'X-Dpy-dpys-list xdpy)
 257     xdpy))
 258
 259 (defun X-Dpy-find-dpy (proc)
 260   "Find xdpy by process PROC."
 261   (let ((dpys X-Dpy-dpys-list))
 262     (while (and dpys (not (eq proc (X-Dpy-proc (car dpys)))))
 263       (setq dpys (cdr dpys)))
 264     (car dpys)))
 265
 266 (defun X-Dpy-filter (proc out)
 267   "Filter for X nework connections."
 268   (let ((xdpy (X-Dpy-find-dpy proc)))
 269     (X-Dpy-p xdpy 'X-Dpy-filter)
 270
 271     (setf (X-Dpy-message-buffer xdpy)
 272           (concat (X-Dpy-message-buffer xdpy) out))
 273
 274     (funcall (X-Dpy-parse-guess-dispatcher xdpy) xdpy)))
 275
 276 (defun X-Dpy-sentinel (proc &optional event)
 277   "Sentinel for X connections."
 278   (let ((xdpy (X-Dpy-find-dpy proc)))
 279     (X-Dpy-p xdpy 'X-Dpy-sentinel)
 280
 281     (message "X: Removing process %S" proc)
 282     (sit-for 1)
 283     (delete-process proc)
 284
 285     (setq X-Dpy-dpys-list (delq xdpy X-Dpy-dpys-list))))
 286
 287 (defun X-Dpy-close (xdpy)
 288   "Close connection associated with XDPY."
 289   (X-Dpy-p xdpy 'X-Dpy-close)
 290   (X-Dpy-send-flush xdpy)
 291   (X-Dpy-sentinel (X-Dpy-proc xdpy)))
 292
 293 ;; Logging
 294 ;; Supported routines are:
 295 ;;   x-display  - display related
 296 ;;   x-error    - X Errors related
 297 ;;   x-event    - X Event related
 298 ;;   x-tray     - X tray related
 299 ;;   x-misc     - Misc stuff
 300 ;;   x-record   - RECORD extension
 301
 302 (defun X-Dpy-set-log-routines (xdpy routines)
 303   "Set XDPY's log routines to ROUTINES."
 304   (X-Dpy-put-property xdpy 'log-routines routines))
 305
 306 (defun X-Dpy-get-log-routines (xdpy)
 307   "Return XDPY's log routines."
 308   (X-Dpy-get-property xdpy 'log-routines))
 309
 310 (defun X-Dpy-has-log-routine-p (xdpy routine)
 311   "Return non-nil if XDPY has log ROUTINE."
 312   (memq routine (X-Dpy-get-log-routines xdpy)))
 313
 314 (defun X-Dpy-log (xdpy routine &rest args)
 315   "Put a ROUTINE's message in the in the log buffer specified by XDPY.
 316 If XDPY is nil, then put into current buffer.  Log additional ARGS as well."
 317   (X-Dpy-p xdpy 'X-Dpy-log)
 318
 319   (when (and (X-Dpy-log-buffer xdpy)
 320              (X-Dpy-has-log-routine-p xdpy routine)
 321              (bufferp (get-buffer-create (X-Dpy-log-buffer xdpy))))
 322     (with-current-buffer (get-buffer-create (X-Dpy-log-buffer xdpy))
 323       (save-excursion
 324         (goto-char (point-min))
 325         (insert (format "%d %S: " (nth 1 (current-time)) routine))
 326         (insert (apply 'format (mapcar 'eval args)))
 327         (insert "\n")))))
 328
 329 (defun X-Dpy-log-verbatim (xdpy arg)
 330   (X-Dpy-p xdpy 'X-Dpy-log-verbatim)
 331
 332   (when (bufferp (X-Dpy-log-buffer xdpy))
 333     (with-current-buffer (X-Dpy-log-buffer xdpy)
 334       (goto-char (point-min))
 335       (insert "[" arg "]" "\n"))
 336     ))
 337
 338 ;;; Sending/receiving functions
 339 (defun X-Dpy-send-flush (xdpy)
 340   "Send XDPY's send buffer to X server."
 341   (process-send-string (X-Dpy-proc xdpy)
 342                        (mapconcat 'identity (nreverse (X-Dpy-snd-queue xdpy)) ""))
 343   (setf (X-Dpy-snd-queue xdpy) nil))
 344
 345 (defun X-Dpy-send (xdpy s)
 346   "Send the X server DPY the string S. Increase request id rseq-id.
 347 There is special mode when we are collecting X output to send it all at once."
 348   (setf (X-Dpy-snd-queue xdpy)
 349         (cons s (X-Dpy-snd-queue xdpy)))
 350   (enqueue-eval-event 'X-Dpy-send-flush xdpy)
 351   ;; increase request sequence number
 352   (incf (X-Dpy-rseq-id xdpy)))
 353
 354 ;;; Sending section
 355 (defmacro X-Force-char-num (maybechar)
 356   "Force MAYBECHAR to be a number for XEmacs platform."
 357   ;; This is an annoying XEmacs problem  To bad it slows down
 358   ;; Emacs too.
 359   (if (fboundp 'characterp)
 360       (list 'if (list 'characterp maybechar)
 361             (list 'setq maybechar (list 'char-to-int maybechar)))))
 362
 363 (defconst X-byte-order ?l "Byte order used by emacs X.  B MSB, l LSB.")
 364 (defconst X-protocol-minor-version 0 "Minor version of client.")
 365 (defconst X-protocol-major-version 11 "Major version of client.")
 366
 367 (defconst X-client-to-open
 368   (list [1 X-byte-order]
 369         [1 0]                           ;unused
 370         [2 X-protocol-major-version]
 371         [2 X-protocol-minor-version]
 372         [2 0]                           ;auth name
 373         [2 0]                           ;auth data
 374         [2 0]                           ;unused
 375         ;; No auth name or data, so empty
 376         )
 377   "XStruct list of sizes when opening a connection.")
 378
 379 (defun X-Create-message (message-s &optional pad-notneed)
 380   "Takes the MESSAGE-S structure and builds a net string.
 381 MESSAGE-S is a list of vectors and symbols which formulate the message
 382 to be sent to the XServer.  Each vector is of this form:
 383   [ SIZE VALUE ]
 384   SIZE is the number of BYTES used by the message.
 385   VALUE is the lisp object whose value is to take up SIZE bytes.
 386   If VALUE or SIZE is a symbol or list, extract that elements value.
 387     If the resulting value is still a list or symbol, extract it's value
 388     until it is no longer a symbol or a list.
 389   If VALUE is a number, massage it to the correct size.
 390   If VALUE is a string, append that string verbatum.
 391   If VALUE is nil, fill it with that many NULL characters.
 392
 393 When PAD-NOTNEED is non-nil, then do not pad to 4 bytes."
 394
 395   (let ((gc-cons-threshold most-positive-fixnum)        ;inhibit gc'ing
 396         (news nil)
 397         (ts   nil)
 398         (tvec nil)
 399         (tval nil)
 400         (tlen nil))
 401     (while message-s
 402       (setq tvec (car message-s))
 403       (setq tval (aref tvec 1))
 404       (setq tlen (aref tvec 0))
 405
 406       ;; Check for symbols, or symbols containing symbols.
 407       (while (and tlen (or (listp tlen) (symbolp tlen)))
 408         (setq tlen (eval tlen)))
 409
 410       ;; Check for symbols, or symbols containing symbols.
 411       (while (and (not (null tval))     ; nil symbol allowed
 412                   (not (eq tval t))     ; t symbol allowed
 413                   (or (listp tval) (symbolp tval)))
 414         (setq tval (eval tval)))
 415
 416       ;; Fix XEmacs 20 broken characters
 417       (X-Force-char-num tval)
 418
 419       ;; Numbers, put in.
 420       (cond
 421        ;; numbers get converted based on size.
 422        ((numberp tval)
 423         (cond
 424          ((= tlen 1)
 425           (setq ts (int->string1 tval)))
 426          ((= tlen 2)
 427           (setq ts (int->string tval)))
 428          ((= tlen 4)
 429           (setq ts (int->string4 tval)))
 430          (t
 431           (error "Wrong size for a message part to be a number!"))))
 432
 433        ;; strings get appended onto the end.
 434        ((stringp tval)
 435         (setq ts tval))
 436
 437        ;; nil is usually filler, so stuff on some 0s
 438        ((eq tval nil)
 439         (setq ts (make-string tlen ?\x00)))
 440
 441        ;; t is alias for True
 442        ((eq tval t)
 443         (setq ts (concat (make-string (- tlen 1) ?\x00) (make-string 1 ?\x01))))
 444
 445        ;; some sort of error
 446        (t
 447         (error "Invalid type to be put into an Xmessage")))
 448
 449       (setq ts (concat ts "\0\0\0\0"))  ; make sure we fill length req.
 450       (setq ts (substring ts 0 tlen))
 451       (setq news (concat news ts))
 452       (setq message-s (cdr message-s)))
 453
 454     ;; pad the message
 455     (if (and (not pad-notneed)
 456              (/= (% (length news) 4) 0))
 457         (let ((s "\0\0\0\0"))
 458           (setq news (concat news (substring s 0 (- 4 (% (length news) 4)))))))
 459     news))
 460
 461 ;;;; NEW stuff, X types declarations
 462
 463 ;; Not yet workable.
 464
 465 ;; Why is this needed?  Gives flexibility in implementing and
 466 ;; accessing X server and its resources.
 467
 468 ;; Autogenerator can be written, which will generate types according
 469 ;; to proto.TXT or other papers.
 470
 471 (defmacro define-X-type (type type-description)
 472   "Define new X value type.
 473 TYPE-DESCRIPTION is list where car of it is one of:
 474
 475    `type' - Specifies static type, next values are - LENGTH
 476             VALUE-PACKER VALUE-EXTRACTOR.
 477
 478    `resource' - Specifies some resource which has PREDICATE and
 479                 ID-EXTRACTOR functions.
 480
 481    `alias' - Alias to some already defined type.
 482
 483    `enum' - for use by SETofXXXX types.
 484
 485    `struct' - Define stucture.
 486
 487    `or' - One of other type.
 488 "
 489   `(put (quote ,type) 'X-type-description ,type-description))
 490
 491 (defun X-type-pack (dpy type val)
 492   (let* ((xtd (or (and (listp type) type)
 493                   (get type 'X-type-description)))
 494          (xt (car xtd)))
 495     (cond ((and (eq xt 'resource) (funcall (cadr xtd) val))
 496            (int32->string (funcall (caddr xtd) val)))
 497
 498           ((eq xt 'type)
 499            (funcall (caddr xtd) val))
 500
 501           ((and (eq xt 'enum) (memq val (cddr xtd)))
 502            (int->string val))
 503
 504           ((eq xt 'alias)
 505            (X-type-pack dpy (cadr xtd) val))
 506
 507           ((eq xt 'listof)
 508            (apply 'concat (mapcar #'(lambda (el)
 509                                       (X-type-pack dpy (cadr xtd) el))
 510                                   val)))
 511
 512           ((eq xt 'setof)
 513            (funcall (cond ((= (cadr xtd) 1) 'int->string1)
 514                           ((= (cadr xtd) 2) 'int->string2)
 515                           ((= (cadr xtd) 4) 'int->string4))
 516                     (apply 'Xmask-or val)))
 517
 518           ((eq xt 'struct)
 519            (apply 'concat (mapcar #'(lambda (tt)
 520                                       (X-type-pack dpy (cdr tt)
 521                                                    (funcall (car tt) val)))
 522                                   (cddr xt))))
 523
 524           ((eq xt 'or)
 525            (setq xt (cdr xt))
 526            (let (orval)
 527              (while (and xt (not orval))
 528                (setq orval (X-type-pack dpy (car xt) val)
 529                      xt (cdr xt)))
 530              orval)))))
 531
 532 (defun X-type-extract (dpy type &optional llen)
 533   (let* ((xtd (or (and (listp type) type)
 534                   (get type 'X-type-description)))
 535          (xt (car xtd)))
 536     (cond ((eq xt 'resource)
 537            (funcall (cadddr xtd) dpy (string->int32 (X-Dpy-grab-bytes dpy 4))))
 538
 539           ((eq xt 'type)
 540            (funcall (cadddr xtd) (X-Dpy-grab-bytes dpy (cadr xtd))))
 541
 542           ((eq xt 'enum)
 543            (string->int (X-Dpy-grab-bytes dpy (cadr xtd))))
 544
 545           ((eq xt 'alias)
 546            (X-type-extract dpy (cadr xtd)))
 547
 548           ((eq xt 'listof)
 549            (when (numberp llen)
 550              (let (rval)
 551                (while (> llen 0)
 552                  (setq rval (X-type-extract dpy (cadr xtd)))
 553                  (decf llen))
 554                rval)))
 555
 556           ((eq xt 'setof)
 557            (let ((smask (funcall (cond ((= (cadr xtd) 1) 'string1->int)
 558                                        ((= (cadr xtd) 2) 'string->int)
 559                                        ((= (cadr xtd) 4) 'string4->int))
 560                                  (X-Dpy-grab-bytes dpy (cadr xtd))))
 561                  (dd (get (caddr xtd) 'X-type-description))
 562                  (cmask 1)
 563                  rval)
 564              (when (eq (car dd) 'enum)
 565                (setq dd (cddr dd))
 566                (while dd
 567                  (when (Xtest smask cmask)
 568                    (setq rval (cons (car dd) rval)))
 569                  (setq cmask (lsh cmask 1)
 570                        dd (cdr dd))))
 571              rval))
 572
 573           ((eq xt 'struct)
 574            (let ((rval (funcall (cadr xtd))))
 575              (mapc #'(lambda (tt)
 576                        (eval `(setf (,(car tt) rval)
 577                                     (X-type-extract dpy ,(cdr tt)))))
 578                    (cdr xtd))
 579              rval)))))
 580
 581 ;; Add some built-in types
 582 (define-X-type WINDOW '(resource X-Win-p X-Win-id X-Win-find-or-make))
 583 (define-X-type PIXMAP '(resource X-Pixmap-p X-Pixmap-id X-Pixmap-find-or-make))
 584 (define-X-type CURSOR '(resource X-Cursor-p X-Cursor-id X-Cursor-find-or-make))
 585 (define-X-type FONT '(resource X-Font-p X-Font-id X-Font-find))
 586 (define-X-type GCONTEXT '(resource X-Gc-p X-Gc-id ignore))
 587 (define-X-type COLORMAP '(resource X-Colormap-p X-Colormap-id))
 588 (define-X-type DRAWABLE '(or WINDOW PIXMAP))
 589 (define-X-type FONTABLE '(or FONT GCONTEXT))
 590 (define-X-type ATOM '(resource X-Atom-p X-Atom-id X-Atom-find-or-make))
 591 (define-X-type VISUALID '(resource X-Visual-p X-Visual-id ignore))
 592 (define-X-type BYTE '(type 1 char-to-string string-to-char))
 593 (define-X-type INT8 '(type 1 x-int8->string x-string->int8))
 594 (define-X-type INT16 '(type 2 x-int16->string x-string->int16))
 595 (define-X-type INT32 '(type 4 x-int32->string x-string->int32))
 596 (define-X-type CARD8 '(type 1 x-card8->string x-string->card8))
 597 (define-X-type CARD16 '(type 2 x-card16->string x-string->card16))
 598 (define-X-type CARD32 '(type 4 x-card32->string x-string->card32))
 599 (define-X-type TIMESTAMP '(alias CARD32))
 600 (define-X-type BITGRAVITY (list 'enum 1
 601                                  X-ForgetGravity X-StaticGravity X-NorthWestGravity
 602                                  X-NorthGravity X-NorthEastGravity X-WestGravity
 603                                  X-CenterGravity X-EastGravity X-SouthWestGravity
 604                                  X-SouthGravity X-SouthEastGravity))
 605 (define-X-type WINGRAVITY (list 'enum 1
 606                                  X-UnmapGravity X-StaticGravity X-NorthWestGravity
 607                                  X-NorthGravity X-NorthEastGravity X-WestGravity
 608                                  X-CenterGravity X-EastGravity X-SouthWestGravity
 609                                  X-SouthGravity X-SouthEastGravity))
 610 (define-X-type BOOL (list 'enum 1 X-True X-False))
 611 (define-X-type EVENT (list 'enum 4
 612                             XM-KeyPress XM-KeyRelease XM-OwnerGrabButton XM-ButtonPress
 613                             XM-ButtonRelease XM-EnterWindow XM-LeaveWindow XM-PointerMotion
 614                             XM-PointerMotionHint XM-Button1Motion XM-Button2Motion
 615                             XM-Button3Motion XM-Button4Motion XM-Button5Motion
 616                             XM-ButtonMotion XM-Exposure XM-VisibilityChange XM-StructureNotify
 617                             XM-ResizeRedirect XM-SubstructureNotify XM-SubstructureRedirect
 618                             XM-FocusChange XM-PropertyChange XM-ColormapChange XM-KeymapState))
 619 (define-X-type POINTEREVENT (list 'enum 4
 620                                    XM-ButtonPress XM-ButtonRelease XM-EnterWindow
 621                                    XM-LeaveWindow XM-PointerMotion XM-PointerMotionHint
 622                                    XM-Button1Motion XM-Button2Motion XM-Button3Motion
 623                                    XM-Button4Motion XM-Button5Motion XM-ButtonMotion XM-KeymapState))
 624 (define-X-type DEVICEEVENT (list 'enum 4
 625                                   XM-KeyPress XM-KeyRelease XM-ButtonPress XM-ButtonRelease
 626                                   XM-PointerMotion XM-Button1Motion XM-Button2Motion
 627                                   XM-Button3Motion XM-Button4Motion XM-Button5Motion
 628                                   XM-ButtonMotion))
 629 (define-X-type KEYSYM '(alias INT32))
 630 (define-X-type KEYCODE '(alias CARD8))
 631 (define-X-type BUTTON '(alias CARD8))
 632 (define-X-type KEYMASK (list 'enum 2 X-Shift X-Lock X-Control X-Mod1 X-Mod2 X-Mod3 X-Mod4 X-Mod5))
 633 (define-X-type BUTMASK (list 'enum 2 X-Button1 X-Button2 X-Button3 X-Button4 X-Button5))
 634 (define-X-type KEYBUTMASK '(or KEYMASK BUTMASK))
 635
 636 (defun make-X-Char2B ()
 637   (make-string 2 ?\x00))
 638 (defun X-Char2B-byte0 (c2b)
 639   (aref c2b 0))
 640 (defsetf X-Char2B-byte0 (c2b) (b)
 641   `(aset ,c2b 0 ,b))
 642 (defun X-Char2B-byte1 (c2b)
 643   (aref c2b 1))
 644 (defsetf X-Char2B-byte1 (c2b) (b)
 645   `(aset ,c2b 1 ,b))
 646
 647 (define-X-type CHAR2B '(struct X-Char2B
 648                                (X-Char2B-byte0 . BYTE)
 649                                (X-Char2B-byte1 . BYTE)))
 650 (define-X-type STRING8 '(listof BYTE))
 651 (define-X-type STRING16 '(listof CHAR2B))
 652
 653 (define-X-type POINT '(struct X-Point
 654                               (X-Point-x . INT16)
 655                               (X-Point-y . INT16)))
 656 (define-X-type RECTANGLE '(struct X-Rect
 657                                   (X-Rect-x . INT16)
 658                                   (X-Rect-y . INT16)
 659                                   (X-Rect-width . CARD16)
 660                                   (X-Rect-height . CARD16)))
 661 (define-X-type ARC '(struct X-Arc
 662                             (X-Arc-x . INT16)
 663                             (X-Arc-y . INT16)
 664                             (X-Arc-width . CARD16)
 665                             (X-Arc-height . CARD16)
 666                             (X-Arc-angle1 . INT16)
 667                             (X-Arc-angle2 . INT16)))
 668 (defun make-X-Host ()
 669   (vector nil nil))
 670 (defun X-Host-family (h)
 671   (aref h 0))
 672 (defsetf X-Host-family (h) (f)
 673   `(aset ,h 0 ,f))
 674 (defun X-Host-address (h)
 675   (aref h 1))
 676 (defsetf X-Host-address (h) (a)
 677   `(aset ,h 1 ,a))
 678
 679 (define-X-type HOST `(struct X-Host
 680                              (X-Host-family . (enum 1 ,X-FamilyInternet ,X-FamilyDECnet ,X-FamilyChaos))
 681                              (X-Host-address . STRING8)))
 682
 683 (defun X-Create-Message (message-s &optional pad-notneed)
 684   "Takes the MESSAGE-S structure and builds a net string.
 685 MESSAGE-S is a list of vectors and symbols which formulate the message
 686 to be sent to the XServer.  Each vector is of this form:
 687   [ SIZE VALUE ]
 688   SIZE is the number of BYTES used by the message.
 689   VALUE is the lisp object whose value is to take up SIZE bytes.
 690   If VALUE or SIZE is a symbol or list, extract that elements value.
 691     If the resulting value is still a list or symbol, extract it's value
 692     until it is no longer a symbol or a list.
 693   If VALUE is a number, massage it to the correct size.
 694   If VALUE is a string, append that string verbatum.
 695   If VALUE is nil, fill it with that many NULL characters.
 696
 697 When PAD-NOTNEED is non-nil, then do not pad to 4 bytes."
 698
 699   (let ((gc-cons-threshold most-positive-fixnum) ;inhibit gc'ing
 700         (news "")                       ; resulting message
 701         (padlen 0)                      ; resulting message padlen (if needed)
 702         (tlen nil)
 703         (ttype nil)
 704         (tval nil))
 705     (while message-s
 706       (if (= (length (car message-s)) 2)
 707           (setq tlen 1
 708                 ttype (aref (car message-s) 0)
 709                 tval (aref (car message-s) 1))
 710         (setq tlen (aref (car message-s) 0)
 711               ttype (aref (car message-s) 1)
 712               tval (aref (car message-s) 2)))
 713
 714       ;; Check for symbols, or symbols containing symbols.
 715       (while (and (not (null tval))     ; nil symbol allowed
 716                   (not (eq tval t))     ; t symbol allowed
 717                   (or (listp tval) (symbolp tval)))
 718         (setq tval (eval tval)))
 719
 720       (while (> tlen 0)
 721         (cond ((eq tval nil)
 722                (setq tval (make-string tlen ?\x00)))
 723               ((eq tval t)
 724                (setq tval (concat (make-string (- tlen 1) ?\x00) (make-string 1 ?\x01))))
 725               (t (setq tval (X-type-pack nil ttype tval))))
 726         (setq news (concat news tval))
 727         (decf tlen))
 728       (setq message-s (cdr message-s)))
 729
 730     ;; pad the message
 731     (if (and (not pad-notneed)
 732              (/= (setq padlen (% (length news) 4)) 0))
 733         (concat news (make-string (- 4 padlen) ?\x00))
 734       news)))
 735
 736 (defun X-Parse-Message (dpy message-s)
 737   ;; TODO: write me using `X-type-extract'
 738   )
 739
 740 \f
 741 (provide 'xlib-xc)
 742
 743 ;;; xlib-xc.el ends here