Skip to content
Snippets Groups Projects
macros.lisp 39.8 KiB
Newer Older
dan's avatar
dan committed
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-

;;;
;;;			 TEXAS INSTRUMENTS INCORPORATED
;;;				  P.O. BOX 2909
;;;			       AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;

;;; CLX basicly implements a very low overhead remote procedure call
;;; to the server.  This file contains macros which generate the code
;;; for both the client AND the server, given a specification of the
;;; interface. This was done to eliminate errors that may occur because
;;; the client and server code get/put bytes in different places, and
;;; it makes it easier to extend the protocol.

;;; This is built on top of BUFFER

(in-package :xlib)

(defmacro type-check (value type)
  value type
csr21's avatar
csr21 committed
  (when +type-check?+
dan's avatar
dan committed
    `(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))

csr21's avatar
csr21 committed
(eval-when (:compile-toplevel :load-toplevel :execute)
dan's avatar
dan committed
(defun getify (name)
  (xintern name '-get))

(defun putify (name &optional predicate-p)
  (xintern name '-put (if predicate-p '-predicating "")))

csr21's avatar
csr21 committed
;;; Use &body so zmacs indents properly
dan's avatar
dan committed
(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))
csr21's avatar
csr21 committed
       ,@(when +type-check?+
dan's avatar
dan committed
	   (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)
dan's avatar
dan committed
			     (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)))
csr21's avatar
csr21 committed
	(declare (type (integer 0 (,(length +boole-vector+))) ,value))
	(type-check ,value '(integer 0 (,(length +boole-vector+))))
	(svref +boole-vector+ ,value))))
dan's avatar
dan committed
  ((index thing)
csr21's avatar
csr21 committed
   `(write-card29 ,index (position ,thing (the simple-vector +boole-vector+))))
dan's avatar
dan committed
  ((index thing)
   (let ((value (gensym)))
csr21's avatar
csr21 committed
     `(let ((,value (position ,thing (the simple-vector +boole-vector+))))
dan's avatar
dan committed
	(and ,value (write-card29 ,index ,value))))))

(define-accessor null (32)
  ((index) `(if (zerop (read-card32 ,index)) nil (read-card32 ,index)))
  ((index value) (declare (ignore value)) `(write-card32 ,index 0)))

(define-accessor pad8 (8)
  ((index) (declare (ignore index)) nil)
  ((index value) (declare (ignore index value))  nil))

(define-accessor pad16 (16)
  ((index) (declare (ignore index)) nil)
  ((index value) (declare (ignore index value)) nil))

(define-accessor bit-vector256 (256)
  ;; used for key-maps
  ;; REAL-INDEX parameter provided so the default index can be over-ridden.
  ;; This is needed for the :keymap-notify event where the keymap overlaps
  ;; the window id.
  ((index &optional (real-index index) data)
   `(read-bitvector256 buffer-bbuf ,real-index ,data))
  ((index map &optional (real-index index) (buffer '%buffer))
   `(write-bitvector256 ,buffer (index+ buffer-boffset ,real-index) ,map)))
   
(define-accessor string (nil)
  ((length index &key reply-buffer)
   `(read-sequence-char
      ,(or reply-buffer '%reply-buffer) 'string ,length nil nil 0 ,index))
  ((index string &key buffer (start 0) end header-length appending)
   (unless buffer (setq buffer '%buffer))
   (unless header-length (setq header-length (lround index)))
   (let* ((real-
Loading
Loading full blame...