depdefs.lisp 21.2 KB
Newer Older
ram's avatar
ram committed
1
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
ram's avatar
ram committed
2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19

;; 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.
;;;
fgilham's avatar
fgilham committed
20

ram's avatar
ram committed
21 22 23 24 25 26
(in-package :xlib)

;;;-------------------------------------------------------------------------
;;; Declarations
;;;-------------------------------------------------------------------------

fgilham's avatar
fgilham committed
27 28 29 30 31 32 33 34 35 36 37
;;; 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)))

ram's avatar
ram committed
38
;;; CLX-VALUES value1 value2 ... -- Documents the values returned by the function.
ram's avatar
ram committed
39

fgilham's avatar
fgilham committed
40
#-Genera
ram's avatar
ram committed
41 42
(declaim (declaration clx-values))

fgilham's avatar
fgilham committed
43 44 45
#+Genera
(setf (get 'clx-values 'si:declaration-alias) 'scl:values)

ram's avatar
ram committed
46 47 48 49
;;; ARGLIST arg1 arg2 ... -- Documents the arglist of the function.  Overrides
;;; the documentation that might get generated by the real arglist of the
;;; function.

fgilham's avatar
fgilham committed
50
#-(or lispm lcl3.0)
ram's avatar
ram committed
51 52 53 54 55
(declaim (declaration arglist))

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

fgilham's avatar
fgilham committed
56
#-genera
ram's avatar
ram committed
57 58 59 60 61 62 63 64 65 66
(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))
ram's avatar
ram committed
67
     (declare (type ,type ,var))
ram's avatar
ram committed
68 69 70 71 72
     ,@body))

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

fgilham's avatar
fgilham committed
73 74 75 76 77 78 79 80
#+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
ram's avatar
ram committed
81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97
(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).
;;;--------------------------------------------------------------------------
fgilham's avatar
fgilham committed
98 99 100 101 102 103 104 105
(defconstant +clx-cached-types+
 '(drawable
   window
   pixmap
   ;;		gcontext
   cursor
   colormap
   font))
ram's avatar
ram committed
106 107

(defmacro resource-id-map-test ()
fgilham's avatar
fgilham committed
108 109
  #+excl '#'equal
  #-excl '#'eql)
ram's avatar
ram committed
110 111
					; (eq fixnum fixnum) is not guaranteed.
(defmacro atom-cache-map-test ()
fgilham's avatar
fgilham committed
112 113
  #+excl '#'equal
  #-excl '#'eq)
ram's avatar
ram committed
114 115

(defmacro keysym->character-map-test ()
fgilham's avatar
fgilham committed
116 117
  #+excl '#'equal
  #-excl '#'eql)
ram's avatar
ram committed
118 119 120 121

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

Raymond Toy's avatar
Raymond Toy committed
122
#+(or lispm vax (and (not sbcl) little-endian) Minima)
fgilham's avatar
fgilham committed
123 124 125 126 127 128 129 130 131
(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*))))

ram's avatar
ram committed
132 133 134 135 136 137
#+cmu
(eval-when (compile eval load)
  (ecase #.(c:backend-byte-order c:*backend*)
    (:big-endian)
    (:little-endian (pushnew :clx-little-endian *features*))))

fgilham's avatar
fgilham committed
138 139 140 141 142 143 144 145 146 147 148
#+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*))))

Raymond Toy's avatar
Raymond Toy committed
149 150 151 152
#+openmcl
(eval-when (:compile-toplevel :load-toplevel :execute)
  #+little-endian-target (pushnew :clx-little-endian *features*))

fgilham's avatar
fgilham committed
153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181
;;; 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))
)

ram's avatar
ram committed
182 183
(deftype buffer-bytes () `(simple-array (unsigned-byte 8) (*)))

fgilham's avatar
fgilham committed
184 185 186 187 188 189
#+clx-overlapping-arrays
(progn
(deftype buffer-words () `(vector overlap16))
(deftype buffer-longs () `(vector overlap32))
)

ram's avatar
ram committed
190 191 192 193 194 195 196 197 198
;;; 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?

fgilham's avatar
fgilham committed
199
#-Genera
ram's avatar
ram committed
200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267
(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)))

)

fgilham's avatar
fgilham committed
268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334
#+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))

)
ram's avatar
ram committed
335 336 337

;;;; Stuff for BUFFER definition

fgilham's avatar
fgilham committed
338
(defconstant +replysize+ 32.)
ram's avatar
ram committed
339 340 341 342

;; used in defstruct initializations to avoid compiler warnings
(defvar *empty-bytes* (make-sequence 'buffer-bytes 0))
(declaim (type buffer-bytes *empty-bytes*))
fgilham's avatar
fgilham committed
343 344 345 346 347 348 349 350 351 352
#+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*))
)
ram's avatar
ram committed
353 354 355 356 357 358 359

(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
fgilham's avatar
fgilham committed
360 361 362 363 364 365
  #+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))
ram's avatar
ram committed
366 367 368
  (data-size 0 :type array-index)
  )

fgilham's avatar
fgilham committed
369 370
(defconstant +buffer-text16-size+ 256)
(deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,+buffer-text16-size+)))
ram's avatar
ram committed
371 372 373

;; These are here because.

ram's avatar
ram committed
374
(defparameter *xlib-package* (find-package :xlib))
ram's avatar
ram committed
375 376 377 378

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

ram's avatar
ram committed
379
(defparameter *keyword-package* (find-package :keyword))
ram's avatar
ram committed
380 381 382 383 384 385

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

;;; Pseudo-class mechanism.

fgilham's avatar
fgilham committed
386 387 388 389
(eval-when (:compile-toplevel :load-toplevel :execute)
  ;; FIXME: maybe we should reevaluate this?
  (defvar *def-clx-class-use-defclass*
    #+(or Genera allegro) t
390
    #-(or Genera allegro) nil
fgilham's avatar
fgilham committed
391 392 393 394 395 396 397
    "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.")
  )
ram's avatar
ram committed
398

ram's avatar
ram committed
399
(defmacro def-clx-class ((name &rest options) &body slots)
ram's avatar
ram committed
400 401
  (if (or (not (listp *def-clx-class-use-defclass*))
	  (member name *def-clx-class-use-defclass*))
Raymond Toy's avatar
Raymond Toy committed
402
      (let ((clos-package (find-package :common-lisp))
ram's avatar
ram committed
403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448
	    (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

fgilham's avatar
fgilham committed
449
	       (eval-when (:compile-toplevel :load-toplevel :execute)
ram's avatar
ram committed
450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480
		 (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
fgilham's avatar
fgilham committed
481 482 483 484 485 486 487 488
		    #+allegro
		    `(progn
		       (,(closintern 'defmethod) ,predicate (object)
			 (declare (ignore object))
			 nil)
		       (,(closintern 'defmethod) ,predicate ((object ,name))
			 t))
		    #-allegro
ram's avatar
ram committed
489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505
		    `(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))))
ram's avatar
ram committed
506

fgilham's avatar
fgilham committed
507 508 509 510 511 512 513
#+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))


ram's avatar
ram committed
514 515 516 517 518 519 520 521 522
;; 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"))
fgilham's avatar
fgilham committed
523 524
  #-excl (output-stream nil :type (or null stream))
  #+excl (output-stream -1 :type fixnum)
ram's avatar
ram committed
525 526 527 528 529 530 531 532 533 534 535 536
  ;; 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)
fgilham's avatar
fgilham committed
537 538 539 540 541 542
  ;; 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)
ram's avatar
ram committed
543
  ;; Holding buffer for 16-bit text
fgilham's avatar
fgilham committed
544
  (tbuf16 (make-sequence 'buffer-text16 +buffer-text16-size+ :initial-element 0))
ram's avatar
ram committed
545
  ;; Probably EQ to Output-Stream
fgilham's avatar
fgilham committed
546 547
  #-excl (input-stream nil :type (or null stream))
  #+excl (input-stream -1 :type fixnum)
ram's avatar
ram committed
548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566
  ;; 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)

fgilham's avatar
fgilham committed
567
  #+Genera (debug-io nil :type (or null stream))
ram's avatar
ram committed
568 569 570
  ) 

;;-----------------------------------------------------------------------------
fgilham's avatar
fgilham committed
571 572 573 574 575
;; Printing routines.
;;-----------------------------------------------------------------------------


;;-----------------------------------------------------------------------------
ram's avatar
ram committed
576 577 578
;; Image stuff
;;-----------------------------------------------------------------------------

fgilham's avatar
fgilham committed
579
(defconstant +image-bit-lsb-first-p+
ram's avatar
ram committed
580 581 582
	     #+clx-little-endian t
	     #-clx-little-endian nil)

fgilham's avatar
fgilham committed
583
(defconstant +image-byte-lsb-first-p+
ram's avatar
ram committed
584 585 586
	     #+clx-little-endian t
	     #-clx-little-endian nil)

fgilham's avatar
fgilham committed
587
(defconstant +image-unit+ 32)
ram's avatar
ram committed
588

fgilham's avatar
fgilham committed
589 590 591 592 593 594
(defconstant +image-pad+ 32)


;;-----------------------------------------------------------------------------
;; Foreign Functions
;;-----------------------------------------------------------------------------
ram's avatar
ram committed
595

fgilham's avatar
fgilham committed
596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612
#+(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))
613 614 615 616 617 618


;;-----------------------------------------------------------------------------
;; Finding the server socket
;;-----------------------------------------------------------------------------

Raymond Toy's avatar
Raymond Toy committed
619 620
;; These are here because dep-openmcl.lisp, dep-lispworks.lisp and
;; dependent.lisp need them
621 622 623 624 625 626 627 628 629 630
(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
Raymond Toy's avatar
Raymond Toy committed
631 632
	((or (and (> (length host) 10) (string= host "tmp/launch" :end1 10))
	     (and (> (length host) 29) (string= host "private/tmp/com.apple.launchd" :end1 29)))
633 634
	 (format nil "/~A:~D" host display))	  
	(t nil)))