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

Contents of /src/clx/depdefs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (hide 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 ram 1.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 dtc 1.5 #+cmu
21     (ext:file-comment
22 pw 1.6 "$Header: /tiger/var/lib/cvsroots/cmucl/src/clx/depdefs.lisp,v 1.6 1999/03/16 23:37:38 pw Exp $")
23 ram 1.1
24     (in-package :xlib)
25    
26     ;;;-------------------------------------------------------------------------
27     ;;; Declarations
28     ;;;-------------------------------------------------------------------------
29    
30 ram 1.3 ;;; CLX-VALUES value1 value2 ... -- Documents the values returned by the function.
31 ram 1.1
32 ram 1.3 (declaim (declaration clx-values))
33 ram 1.1
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 ram 1.3 (declare (type ,type ,var))
54 ram 1.1 ,@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 pw 1.6 '#'eql)
87 ram 1.2 ; (eq fixnum fixnum) is not guaranteed.
88     (defmacro atom-cache-map-test ()
89 pw 1.6 '#'eq)
90 ram 1.1
91     (defmacro keysym->character-map-test ()
92 pw 1.6 '#'eql)
93 ram 1.1
94     ;;; You must define this to match the real byte order. It is used by
95     ;;; overlapping array and image code.
96    
97 ram 1.3 #+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 ram 1.1
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 pw 1.6
115 ram 1.1 (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 pw 1.6 (next nil :type (or null reply-buffer))
199 ram 1.1 (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 ram 1.2 (defparameter *xlib-package* (find-package :xlib))
208 ram 1.1
209     (defun xintern (&rest parts)
210     (intern (apply #'concatenate 'string (mapcar #'string parts)) *xlib-package*))
211    
212 ram 1.2 (defparameter *keyword-package* (find-package :keyword))
213 ram 1.1
214     (defun kintern (name)
215     (intern (string name) *keyword-package*))
216    
217     ;;; Pseudo-class mechanism.
218    
219 ram 1.2 (eval-when (eval compile load)
220 pw 1.4 (defvar *def-clx-class-use-defclass*
221     #+(and cmu pcl) '(XLIB:DRAWABLE XLIB:WINDOW XLIB:PIXMAP)
222     #+(and cmu (not pcl)) nil
223 pw 1.6 #-(or cmu) nil
224 ram 1.2 "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 ram 1.1 (defmacro def-clx-class ((name &rest options) &body slots)
232 ram 1.2 (if (or (not (listp *def-clx-class-use-defclass*))
233     (member name *def-clx-class-use-defclass*))
234 pw 1.6 (let ((clos-package (find-package :common-lisp))
235 ram 1.2 (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 ram 1.1
281 ram 1.2 (eval-when (compile load eval)
282     (setf (get ',name 'def-clx-class) ',slots))
283 ram 1.1
284 ram 1.2 ;; From here down are the system-specific expansions:
285 ram 1.1
286 ram 1.2 (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 ram 1.1
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 pw 1.6 (output-stream nil :type (or null stream))
341 ram 1.1 ;; 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 pw 1.6 (input-stream nil :type (or null stream))
357    
358 ram 1.1 ;; 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 ram 1.2

  ViewVC Help
Powered by ViewVC 1.1.5