/[cmucl]/src/clx/depdefs.lisp
ViewVC logotype

Contents of /src/clx/depdefs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Tue Mar 16 23:37:38 1999 UTC (15 years, 1 month ago) by pw
Branch: MAIN
CVS Tags: double-double-array-base, release-19b-pre1, release-19b-pre2, double-double-init-sparc-2, double-double-base, snapshot-2007-08, ppc_gencgc_snap_2006-01-06, snapshot-2007-05, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, snapshot-2003-10, snapshot-2004-10, release-18e-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19d, double-double-init-ppc, release-19c, dynamic-extent-base, LINKAGE_TABLE, release-19c-base, PRE_LINKAGE_TABLE, mod-arith-base, sparc_gencgc_merge, snapshot-2004-12, snapshot-2004-11, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, release-18e-pre2, prm-before-macosx-merge-tag, cold-pcl-base, snapshot-2003-11, snapshot-2005-07, snapshot-2007-03, release-19a-base, sparc_gencgc, snapshot-2007-04, snapshot-2007-07, snapshot-2007-06, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, double-double-irrat-end, release-19d-pre2, release-19d-pre1, release-18e, double-double-init-checkpoint-1, double-double-reader-base, snapshot-2005-03, release-19b-base, double-double-init-x86, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, snapshot-2005-10, snapshot-2005-12, snapshot-2005-01, release-19c-pre1, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, sparc_gencgc_branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, lisp-executable, double-double-branch, release-18e-branch, cold-pcl, release-19a-branch, release-19c-branch
Changes since 1.5: +11 -276 lines
Remove dead files and dead conditionalized code for dead platforms.
1 ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
2
3 ;; This file contains some of the system dependent code for CLX
4
5 ;;;
6 ;;; TEXAS INSTRUMENTS INCORPORATED
7 ;;; P.O. BOX 2909
8 ;;; AUSTIN, TEXAS 78769
9 ;;;
10 ;;; Copyright (C) 1987 Texas Instruments Incorporated.
11 ;;;
12 ;;; Permission is granted to any individual or institution to use, copy, modify,
13 ;;; and distribute this software, provided that this complete copyright and
14 ;;; permission notice is maintained, intact, in all copies and supporting
15 ;;; documentation.
16 ;;;
17 ;;; Texas Instruments Incorporated provides this software "as is" without
18 ;;; express or implied warranty.
19 ;;;
20 #+cmu
21 (ext:file-comment
22 "$Header: /tiger/var/lib/cvsroots/cmucl/src/clx/depdefs.lisp,v 1.6 1999/03/16 23:37:38 pw Exp $")
23
24 (in-package :xlib)
25
26 ;;;-------------------------------------------------------------------------
27 ;;; Declarations
28 ;;;-------------------------------------------------------------------------
29
30 ;;; CLX-VALUES value1 value2 ... -- Documents the values returned by the function.
31
32 (declaim (declaration clx-values))
33
34 ;;; ARGLIST arg1 arg2 ... -- Documents the arglist of the function. Overrides
35 ;;; the documentation that might get generated by the real arglist of the
36 ;;; function.
37
38 (declaim (declaration arglist))
39
40 ;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to
41 ;;; indent calls to the function or macro containing the declaration.
42
43 (declaim (declaration indentation))
44
45 ;;;-------------------------------------------------------------------------
46 ;;; Declaration macros
47 ;;;-------------------------------------------------------------------------
48
49 ;;; WITH-VECTOR (variable type) &body body --- ensures the variable is a local
50 ;;; and then does a type declaration and array register declaration
51 (defmacro with-vector ((var type) &body body)
52 `(let ((,var ,var))
53 (declare (type ,type ,var))
54 ,@body))
55
56 ;;; WITHIN-DEFINITION (name type) &body body --- Includes definitions for
57 ;;; Meta-.
58
59 (defmacro within-definition ((name type) &body body)
60 (declare (ignore name type))
61 `(progn ,@body))
62
63
64 ;;;-------------------------------------------------------------------------
65 ;;; CLX can maintain a mapping from X server ID's to local data types. If
66 ;;; one takes the view that CLX objects will be instance variables of
67 ;;; objects at the next higher level, then PROCESS-EVENT will typically map
68 ;;; from resource-id to higher-level object. In that case, the lower-level
69 ;;; CLX mapping will almost never be used (except in rare cases like
70 ;;; query-tree), and only serve to consume space (which is difficult to
71 ;;; GC), in which case always-consing versions of the make-<mumble>s will
72 ;;; be better. Even when maps are maintained, it isn't clear they are
73 ;;; useful for much beyond xatoms and windows (since almost nothing else
74 ;;; ever comes back in events).
75 ;;;--------------------------------------------------------------------------
76 (defconstant *clx-cached-types*
77 '( drawable
78 window
79 pixmap
80 ; gcontext
81 cursor
82 colormap
83 font))
84
85 (defmacro resource-id-map-test ()
86 '#'eql)
87 ; (eq fixnum fixnum) is not guaranteed.
88 (defmacro atom-cache-map-test ()
89 '#'eq)
90
91 (defmacro keysym->character-map-test ()
92 '#'eql)
93
94 ;;; You must define this to match the real byte order. It is used by
95 ;;; overlapping array and image code.
96
97 #+cmu
98 (eval-when (compile eval load)
99 (ecase #.(c:backend-byte-order c:*backend*)
100 (:big-endian)
101 (:little-endian (pushnew :clx-little-endian *features*))))
102
103 (deftype buffer-bytes () `(simple-array (unsigned-byte 8) (*)))
104
105 ;;; This defines a type which is a subtype of the integers.
106 ;;; This type is used to describe all variables that can be array indices.
107 ;;; It is here because it is used below.
108 ;;; This is inclusive because start/end can be 1 past the end.
109 (deftype array-index () `(integer 0 ,array-dimension-limit))
110
111
112 ;; this is the best place to define these?
113
114
115 (progn
116
117 (defun make-index-typed (form)
118 (if (constantp form) form `(the array-index ,form)))
119
120 (defun make-index-op (operator args)
121 `(the array-index
122 (values
123 ,(case (length args)
124 (0 `(,operator))
125 (1 `(,operator
126 ,(make-index-typed (first args))))
127 (2 `(,operator
128 ,(make-index-typed (first args))
129 ,(make-index-typed (second args))))
130 (otherwise
131 `(,operator
132 ,(make-index-op operator (subseq args 0 (1- (length args))))
133 ,(make-index-typed (first (last args)))))))))
134
135 (defmacro index+ (&rest numbers) (make-index-op '+ numbers))
136 (defmacro index-logand (&rest numbers) (make-index-op 'logand numbers))
137 (defmacro index-logior (&rest numbers) (make-index-op 'logior numbers))
138 (defmacro index- (&rest numbers) (make-index-op '- numbers))
139 (defmacro index* (&rest numbers) (make-index-op '* numbers))
140
141 (defmacro index1+ (number) (make-index-op '1+ (list number)))
142 (defmacro index1- (number) (make-index-op '1- (list number)))
143
144 (defmacro index-incf (place &optional (delta 1))
145 (make-index-op 'incf (list place delta)))
146 (defmacro index-decf (place &optional (delta 1))
147 (make-index-op 'decf (list place delta)))
148
149 (defmacro index-min (&rest numbers) (make-index-op 'min numbers))
150 (defmacro index-max (&rest numbers) (make-index-op 'max numbers))
151
152 (defmacro index-floor (number divisor)
153 (make-index-op 'floor (list number divisor)))
154 (defmacro index-ceiling (number divisor)
155 (make-index-op 'ceiling (list number divisor)))
156 (defmacro index-truncate (number divisor)
157 (make-index-op 'truncate (list number divisor)))
158
159 (defmacro index-mod (number divisor)
160 (make-index-op 'mod (list number divisor)))
161
162 (defmacro index-ash (number count)
163 (make-index-op 'ash (list number count)))
164
165 (defmacro index-plusp (number) `(plusp (the array-index ,number)))
166 (defmacro index-zerop (number) `(zerop (the array-index ,number)))
167 (defmacro index-evenp (number) `(evenp (the array-index ,number)))
168 (defmacro index-oddp (number) `(oddp (the array-index ,number)))
169
170 (defmacro index> (&rest numbers)
171 `(> ,@(mapcar #'make-index-typed numbers)))
172 (defmacro index= (&rest numbers)
173 `(= ,@(mapcar #'make-index-typed numbers)))
174 (defmacro index< (&rest numbers)
175 `(< ,@(mapcar #'make-index-typed numbers)))
176 (defmacro index>= (&rest numbers)
177 `(>= ,@(mapcar #'make-index-typed numbers)))
178 (defmacro index<= (&rest numbers)
179 `(<= ,@(mapcar #'make-index-typed numbers)))
180
181 )
182
183
184 ;;;; Stuff for BUFFER definition
185
186 (defconstant *replysize* 32.)
187
188 ;; used in defstruct initializations to avoid compiler warnings
189 (defvar *empty-bytes* (make-sequence 'buffer-bytes 0))
190 (declaim (type buffer-bytes *empty-bytes*))
191
192 (defstruct (reply-buffer (:conc-name reply-) (:constructor make-reply-buffer-internal)
193 (:copier nil) (:predicate nil))
194 (size 0 :type array-index) ;Buffer size
195 ;; Byte (8 bit) input buffer
196 (ibuf8 *empty-bytes* :type buffer-bytes)
197 ;; Word (16bit) input buffer
198 (next nil :type (or null reply-buffer))
199 (data-size 0 :type array-index)
200 )
201
202 (defconstant *buffer-text16-size* 256)
203 (deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,*buffer-text16-size*)))
204
205 ;; These are here because.
206
207 (defparameter *xlib-package* (find-package :xlib))
208
209 (defun xintern (&rest parts)
210 (intern (apply #'concatenate 'string (mapcar #'string parts)) *xlib-package*))
211
212 (defparameter *keyword-package* (find-package :keyword))
213
214 (defun kintern (name)
215 (intern (string name) *keyword-package*))
216
217 ;;; Pseudo-class mechanism.
218
219 (eval-when (eval compile load)
220 (defvar *def-clx-class-use-defclass*
221 #+(and cmu pcl) '(XLIB:DRAWABLE XLIB:WINDOW XLIB:PIXMAP)
222 #+(and cmu (not pcl)) nil
223 #-(or cmu) nil
224 "Controls whether DEF-CLX-CLASS uses DEFCLASS.
225 If it is a list, it is interpreted by DEF-CLX-CLASS to be a list of type names
226 for which DEFCLASS should be used.
227 If it is not a list, then DEFCLASS is always used.
228 If it is NIL, then DEFCLASS is never used, since NIL is the empty list.")
229 )
230
231 (defmacro def-clx-class ((name &rest options) &body slots)
232 (if (or (not (listp *def-clx-class-use-defclass*))
233 (member name *def-clx-class-use-defclass*))
234 (let ((clos-package (find-package :common-lisp))
235 (constructor t)
236 (constructor-args t)
237 (include nil)
238 (print-function nil)
239 (copier t)
240 (predicate t))
241 (dolist (option options)
242 (ecase (pop option)
243 (:constructor
244 (setf constructor (pop option))
245 (setf constructor-args (if (null option) t (pop option))))
246 (:include
247 (setf include (pop option)))
248 (:print-function
249 (setf print-function (pop option)))
250 (:copier
251 (setf copier (pop option)))
252 (:predicate
253 (setf predicate (pop option)))))
254 (flet ((cintern (&rest symbols)
255 (intern (apply #'concatenate 'simple-string
256 (mapcar #'symbol-name symbols))
257 *package*))
258 (kintern (symbol)
259 (intern (symbol-name symbol) (find-package :keyword)))
260 (closintern (symbol)
261 (intern (symbol-name symbol) clos-package)))
262 (when (eq constructor t)
263 (setf constructor (cintern 'make- name)))
264 (when (eq copier t)
265 (setf copier (cintern 'copy- name)))
266 (when (eq predicate t)
267 (setf predicate (cintern name '-p)))
268 (when include
269 (setf slots (append (get include 'def-clx-class) slots)))
270 (let* ((n-slots (length slots))
271 (slot-names (make-list n-slots))
272 (slot-initforms (make-list n-slots))
273 (slot-types (make-list n-slots)))
274 (dotimes (i n-slots)
275 (let ((slot (elt slots i)))
276 (setf (elt slot-names i) (pop slot))
277 (setf (elt slot-initforms i) (pop slot))
278 (setf (elt slot-types i) (getf slot :type t))))
279 `(progn
280
281 (eval-when (compile load eval)
282 (setf (get ',name 'def-clx-class) ',slots))
283
284 ;; From here down are the system-specific expansions:
285
286 (within-definition (,name def-clx-class)
287 (,(closintern 'defclass)
288 ,name ,(and include `(,include))
289 (,@(map 'list
290 #'(lambda (slot-name slot-initform slot-type)
291 `(,slot-name
292 :initform ,slot-initform :type ,slot-type
293 :accessor ,(cintern name '- slot-name)
294 ,@(when (and constructor
295 (or (eq constructor-args t)
296 (member slot-name
297 constructor-args)))
298 `(:initarg ,(kintern slot-name)))
299 ))
300 slot-names slot-initforms slot-types)))
301 ,(when constructor
302 (if (eq constructor-args t)
303 `(defun ,constructor (&rest args)
304 (apply #',(closintern 'make-instance)
305 ',name args))
306 `(defun ,constructor ,constructor-args
307 (,(closintern 'make-instance) ',name
308 ,@(mapcan #'(lambda (slot-name)
309 (and (member slot-name slot-names)
310 `(,(kintern slot-name) ,slot-name)))
311 constructor-args)))))
312 ,(when predicate
313 `(defun ,predicate (object)
314 (typep object ',name)))
315 ,(when copier
316 `(,(closintern 'defmethod) ,copier ((.object. ,name))
317 (,(closintern 'with-slots) ,slot-names .object.
318 (,(closintern 'make-instance) ',name
319 ,@(mapcan #'(lambda (slot-name)
320 `(,(kintern slot-name) ,slot-name))
321 slot-names)))))
322 ,(when print-function
323 `(,(closintern 'defmethod)
324 ,(closintern 'print-object)
325 ((object ,name) stream)
326 (,print-function object stream 0))))))))
327 `(within-definition (,name def-clx-class)
328 (defstruct (,name ,@options)
329 ,@slots))))
330
331 ;; We need this here so we can define DISPLAY for CLX.
332 ;;
333 ;; This structure is :INCLUDEd in the DISPLAY structure.
334 ;; Overlapping (displaced) arrays are provided for byte
335 ;; half-word and word access on both input and output.
336 ;;
337 (def-clx-class (buffer (:constructor nil) (:copier nil) (:predicate nil))
338 ;; Lock for multi-processing systems
339 (lock (make-process-lock "CLX Buffer Lock"))
340 (output-stream nil :type (or null stream))
341 ;; Buffer size
342 (size 0 :type array-index)
343 (request-number 0 :type (unsigned-byte 16))
344 ;; Byte position of start of last request
345 ;; used for appending requests and error recovery
346 (last-request nil :type (or null array-index))
347 ;; Byte position of start of last flushed request
348 (last-flushed-request nil :type (or null array-index))
349 ;; Current byte offset
350 (boffset 0 :type array-index)
351 ;; Byte (8 bit) output buffer
352 (obuf8 *empty-bytes* :type buffer-bytes)
353 ;; Holding buffer for 16-bit text
354 (tbuf16 (make-sequence 'buffer-text16 *buffer-text16-size* :initial-element 0))
355 ;; Probably EQ to Output-Stream
356 (input-stream nil :type (or null stream))
357
358 ;; T when the host connection has gotten errors
359 (dead nil :type (or null (not null)))
360 ;; T makes buffer-flush a noop. Manipulated with with-buffer-flush-inhibited.
361 (flush-inhibit nil :type (or null (not null)))
362
363 ;; Change these functions when using shared memory buffers to the server
364 ;; Function to call when writing the buffer
365 (write-function 'buffer-write-default)
366 ;; Function to call when flushing the buffer
367 (force-output-function 'buffer-force-output-default)
368 ;; Function to call when closing a connection
369 (close-function 'buffer-close-default)
370 ;; Function to call when reading the buffer
371 (input-function 'buffer-read-default)
372 ;; Function to call to wait for data to be input
373 (input-wait-function 'buffer-input-wait-default)
374 ;; Function to call to listen for input data
375 (listen-function 'buffer-listen-default)
376
377 )
378
379 ;;-----------------------------------------------------------------------------
380 ;; Image stuff
381 ;;-----------------------------------------------------------------------------
382
383 (defconstant *image-bit-lsb-first-p*
384 #+clx-little-endian t
385 #-clx-little-endian nil)
386
387 (defconstant *image-byte-lsb-first-p*
388 #+clx-little-endian t
389 #-clx-little-endian nil)
390
391 (defconstant *image-unit* 32)
392
393 (defconstant *image-pad* 32)
394

  ViewVC Help
Powered by ViewVC 1.1.5