;;; -*- 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
;;;-------------------------------------------------------------------------

;;; CLX-VALUES value1 value2 ... -- Documents the values returned by the function.

(declaim (declaration clx-values))

;;; ARGLIST arg1 arg2 ... -- Documents the arglist of the function.  Overrides
;;; the documentation that might get generated by the real arglist of the
;;; function.

(declaim (declaration arglist))

;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to
;;; indent calls to the function or macro containing the declaration.

(declaim (declaration indentation))

;;;-------------------------------------------------------------------------
;;; Declaration macros
;;;-------------------------------------------------------------------------

;;; WITH-VECTOR (variable type) &body body --- ensures the variable is a local
;;; and then does a type declaration and array register declaration
(defmacro with-vector ((var type) &body body)
  `(let ((,var ,var))
     (declare (type ,type ,var))
     ,@body))

;;; WITHIN-DEFINITION (name type) &body body --- Includes definitions for
;;; Meta-.

(defmacro within-definition ((name type) &body body)
  (declare (ignore name type))
  `(progn ,@body))


;;;-------------------------------------------------------------------------
;;; CLX can maintain a mapping from X server ID's to local data types.  If
;;; one takes the view that CLX objects will be instance variables of
;;; objects at the next higher level, then PROCESS-EVENT will typically map
;;; from resource-id to higher-level object.  In that case, the lower-level
;;; CLX mapping will almost never be used (except in rare cases like
;;; query-tree), and only serve to consume space (which is difficult to
;;; GC), in which case always-consing versions of the make-<mumble>s will
;;; be better.  Even when maps are maintained, it isn't clear they are
;;; useful for much beyond xatoms and windows (since almost nothing else
;;; ever comes back in events).
;;;--------------------------------------------------------------------------
(defparameter *clx-cached-types*
	     '( drawable
		window
		pixmap
;		gcontext
		cursor
		colormap
		font))

(defmacro resource-id-map-test ()
  '#'eql)
					; (eq fixnum fixnum) is not guaranteed.
(defmacro atom-cache-map-test ()
  '#'eq)

(defmacro keysym->character-map-test ()
  '#'eql)

;;; You must define this to match the real byte order.  It is used by
;;; overlapping array and image code.

#+cmu
(eval-when (:compile-toplevel :execute :load-toplevel)
  (ecase #.(c:backend-byte-order c:*backend*)
    (:big-endian)
    (:little-endian (pushnew :clx-little-endian *features*))))

#+CLISP
(eval-when (:compile-toplevel :execute :load-toplevel)
  (unless system::*big-endian* (pushnew :clx-little-endian *features*)))

(deftype buffer-bytes () `(simple-array (unsigned-byte 8) (*)))

;;; This defines a type which is a subtype of the integers.
;;; This type is used to describe all variables that can be array indices.
;;; It is here because it is used below.
;;; This is inclusive because start/end can be 1 past the end.
(deftype array-index () `(integer 0 ,array-dimension-limit))


;; this is the best place to define these?


(progn

(defun make-index-typed (form)
  (if (constantp form) form `(the array-index ,form)))

(defun make-index-op (operator args)
  `(the array-index
	(values
	  ,(case (length args)
	     (0 `(,operator))
	     (1 `(,operator
		  ,(make-index-typed (first args))))
	     (2 `(,operator
		  ,(make-index-typed (first args))
		  ,(make-index-typed (second args))))
	     (otherwise
	       `(,operator
		 ,(make-index-op operator (subseq args 0 (1- (length args))))
		 ,(make-index-typed (first (last args)))))))))

(defmacro index+ (&rest numbers) (make-index-op '+ numbers))
(defmacro index-logand (&rest numbers) (make-index-op 'logand numbers))
(defmacro index-logior (&rest numbers) (make-index-op 'logior numbers))
(defmacro index- (&rest numbers) (make-index-op '- numbers))
(defmacro index* (&rest numbers) (make-index-op '* numbers))

(defmacro index1+ (number) (make-index-op '1+ (list number)))
(defmacro index1- (number) (make-index-op '1- (list number)))

(defmacro index-incf (place &optional (delta 1))
  (make-index-op 'incf (list place delta)))
(defmacro index-decf (place &optional (delta 1))
  (make-index-op 'decf (list place delta)))

(defmacro index-min (&rest numbers) (make-index-op 'min numbers))
(defmacro index-max (&rest numbers) (make-index-op 'max numbers))

(defmacro index-floor (number divisor)
  (make-index-op 'floor (list number divisor)))
(defmacro index-ceiling (number divisor)
  (make-index-op 'ceiling (list number divisor)))
(defmacro index-truncate (number divisor)
  (make-index-op 'truncate (list number divisor)))

(defmacro index-mod (number divisor)
  (make-index-op 'mod (list number divisor)))

(defmacro index-ash (number count)
  (make-index-op 'ash (list number count)))

(defmacro index-plusp (number) `(plusp (the array-index ,number)))
(defmacro index-zerop (number) `(zerop (the array-index ,number)))
(defmacro index-evenp (number) `(evenp (the array-index ,number)))
(defmacro index-oddp  (number) `(oddp  (the array-index ,number)))

(defmacro index> (&rest numbers)
  `(> ,@(mapcar #'make-index-typed numbers)))
(defmacro index= (&rest numbers)
  `(= ,@(mapcar #'make-index-typed numbers)))
(defmacro index< (&rest numbers)
  `(< ,@(mapcar #'make-index-typed numbers)))
(defmacro index>= (&rest numbers)
  `(>= ,@(mapcar #'make-index-typed numbers)))
(defmacro index<= (&rest numbers)
  `(<= ,@(mapcar #'make-index-typed numbers)))

)


;;;; Stuff for BUFFER definition

(defconstant +replysize+ 32.)

;; used in defstruct initializations to avoid compiler warnings
(defvar *empty-bytes* (make-sequence 'buffer-bytes 0))
(declaim (type buffer-bytes *empty-bytes*))

(defstruct (reply-buffer (:conc-name reply-) (:constructor make-reply-buffer-internal)
			 (:copier nil) (:predicate nil))
  (size 0 :type array-index)			;Buffer size
  ;; Byte (8 bit) input buffer
  (ibuf8 *empty-bytes* :type buffer-bytes)
  ;; Word (16bit) input buffer
  (next nil :type (or null reply-buffer))
  (data-size 0 :type array-index)
  )

(defconstant +buffer-text16-size+ 256)
(deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,+buffer-text16-size+)))

;; These are here because.

(defparameter *xlib-package* (find-package :xlib))

(defun xintern (&rest parts)
  (intern (apply #'concatenate 'string (mapcar #'string parts)) *xlib-package*))

(defparameter *keyword-package* (find-package :keyword))

(defun kintern (name)
  (intern (string name) *keyword-package*))

;;; Pseudo-class mechanism.

(eval-when (:execute :compile-toplevel :load-toplevel)
(defvar *def-clx-class-use-defclass*
  #+(and cmu pcl) '(XLIB:DRAWABLE XLIB:WINDOW XLIB:PIXMAP)
  #+(and cmu (not pcl)) nil
  #-(or  cmu) nil
  "Controls whether DEF-CLX-CLASS uses DEFCLASS.
   If it is a list, it is interpreted by DEF-CLX-CLASS to be a list of type names
   for which DEFCLASS should be used.
   If it is not a list, then DEFCLASS is always used.
   If it is NIL, then DEFCLASS is never used, since NIL is the empty list.")
)

(defmacro def-clx-class ((name &rest options) &body slots)
  (if (or (not (listp *def-clx-class-use-defclass*))
	  (member name *def-clx-class-use-defclass*))
      (let ((clos-package (find-package :common-lisp))
	    (constructor t)
	    (constructor-args t)
	    (include nil)
	    (print-function nil)
	    (copier t)
	    (predicate t))
	(dolist (option options)
	  (ecase (pop option)
	    (:constructor
	      (setf constructor (pop option))
	      (setf constructor-args (if (null option) t (pop option))))
	    (:include
	      (setf include (pop option)))
	    (:print-function
	      (setf print-function (pop option)))
	    (:copier
	      (setf copier (pop option)))
	    (:predicate
	      (setf predicate (pop option)))))
	(flet ((cintern (&rest symbols)
		 (intern (apply #'concatenate 'simple-string
				(mapcar #'symbol-name symbols))
			 *package*))
	       (kintern (symbol)
			(intern (symbol-name symbol) (find-package :keyword)))
	       (closintern (symbol)
		 (intern (symbol-name symbol) clos-package)))
	  (when (eq constructor t)
	    (setf constructor (cintern 'make- name)))
	  (when (eq copier t)
	    (setf copier (cintern 'copy- name)))
	  (when (eq predicate t)
	    (setf predicate (cintern name '-p)))
	  (when include
	    (setf slots (append (get include 'def-clx-class) slots)))
	  (let* ((n-slots (length slots))
		 (slot-names (make-list n-slots))
		 (slot-initforms (make-list n-slots))
		 (slot-types (make-list n-slots)))
	    (dotimes (i n-slots)
	      (let ((slot (elt slots i)))
		(setf (elt slot-names i) (pop slot))
		(setf (elt slot-initforms i) (pop slot))
		(setf (elt slot-types i) (getf slot :type t))))
	    `(progn

	       (eval-when (:compile-toplevel :load-toplevel :execute)
		 (setf (get ',name 'def-clx-class) ',slots))

	       ;; From here down are the system-specific expansions:

	       (within-definition (,name def-clx-class)
		 (,(closintern 'defclass)
		  ,name ,(and include `(,include))
		  (,@(map 'list
			  #'(lambda (slot-name slot-initform slot-type)
			      `(,slot-name
				:initform ,slot-initform :type ,slot-type
				:accessor ,(cintern name '- slot-name)
				,@(when (and constructor
					     (or (eq constructor-args t)
						 (member slot-name
							 constructor-args)))
				    `(:initarg ,(kintern slot-name)))
				))
			  slot-names slot-initforms slot-types)))
		 ,(when constructor
		    (if (eq constructor-args t)
			`(defun ,constructor (&rest args)
			   (apply #',(closintern 'make-instance)
				  ',name args))
			`(defun ,constructor ,constructor-args
			   (,(closintern 'make-instance) ',name
			    ,@(mapcan #'(lambda (slot-name)
					  (and (member slot-name slot-names)
					       `(,(kintern slot-name) ,slot-name)))
				      constructor-args)))))
		 ,(when predicate
		    `(defun ,predicate (object)
		       (typep object ',name)))
		 ,(when copier
		    `(,(closintern 'defmethod) ,copier ((.object. ,name))
		      (,(closintern 'with-slots) ,slot-names .object.
		       (,(closintern 'make-instance) ',name
			,@(mapcan #'(lambda (slot-name)
				      `(,(kintern slot-name) ,slot-name))
				  slot-names)))))
		 ,(when print-function
		    `(,(closintern 'defmethod)
		      ,(closintern 'print-object)
		      ((object ,name) stream)
		      (,print-function object stream 0))))))))
      `(within-definition (,name def-clx-class)
	 (defstruct (,name ,@options)
	   ,@slots))))

;; We need this here so we can define DISPLAY for CLX.
;;
;; This structure is :INCLUDEd in the DISPLAY structure.
;; Overlapping (displaced) arrays are provided for byte
;; half-word and word access on both input and output.
;;
(def-clx-class (buffer (:constructor nil) (:copier nil) (:predicate nil))
  ;; Lock for multi-processing systems
  (lock (make-process-lock "CLX Buffer Lock"))
  (output-stream nil :type (or null stream))
  ;; Buffer size
  (size 0 :type array-index)
  (request-number 0 :type (unsigned-byte 16))
  ;; Byte position of start of last request
  ;; used for appending requests and error recovery
  (last-request nil :type (or null array-index))
  ;; Byte position of start of last flushed request
  (last-flushed-request nil :type (or null array-index))
  ;; Current byte offset
  (boffset 0 :type array-index)
  ;; Byte (8 bit) output buffer
  (obuf8 *empty-bytes* :type buffer-bytes)
  ;; Holding buffer for 16-bit text
  (tbuf16 (make-sequence 'buffer-text16 +buffer-text16-size+ :initial-element 0))
  ;; Probably EQ to Output-Stream
  (input-stream nil :type (or null stream))

  ;; T when the host connection has gotten errors
  (dead nil :type (or null (not null)))
  ;; T makes buffer-flush a noop.  Manipulated with with-buffer-flush-inhibited.
  (flush-inhibit nil :type (or null (not null)))

  ;; Change these functions when using shared memory buffers to the server
  ;; Function to call when writing the buffer
  (write-function 'buffer-write-default)
  ;; Function to call when flushing the buffer
  (force-output-function 'buffer-force-output-default)
  ;; Function to call when closing a connection
  (close-function 'buffer-close-default)
  ;; Function to call when reading the buffer
  (input-function 'buffer-read-default)
  ;; Function to call to wait for data to be input
  (input-wait-function 'buffer-input-wait-default)
  ;; Function to call to listen for input data
  (listen-function 'buffer-listen-default)

  )

;;-----------------------------------------------------------------------------
;; Image stuff
;;-----------------------------------------------------------------------------

(defconstant +image-bit-lsb-first-p+
	     #+clx-little-endian t
	     #-clx-little-endian nil)

(defconstant +image-byte-lsb-first-p+
	     #+clx-little-endian t
	     #-clx-little-endian nil)

(defconstant +image-unit+ 32)

(defconstant +image-pad+ 32)