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

Contents of /src/clx/depdefs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (hide annotations)
Wed Aug 22 03:58:59 2007 UTC (6 years, 7 months ago) by fgilham
Branch: MAIN
CVS Tags: merged-unicode-utf16-extfmt-2009-06-11, unicode-utf16-extfmt-2009-03-27, snapshot-2007-09, snapshot-2008-08, snapshot-2008-09, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, sse2-base, sse2-packed-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, release-19e, unicode-utf16-sync-2008-12, label-2009-03-16, release-19f-base, merge-sse2-packed, merge-with-19f, unicode-snapshot-2009-05, unicode-snapshot-2009-06, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, snapshot-2008-04, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, unicode-utf16-sync-2008-11, release-19e-pre1, release-19e-pre2, label-2009-03-25, sse2-checkpoint-2008-10-01, sse2-merge-with-2008-11, sse2-merge-with-2008-10, unicode-utf16-extfmt-2009-06-11, unicode-utf16-string-support, release-19e-base, unicode-utf16-base, portable-clx-base, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-05, snapshot-2009-04
Branch point for: RELEASE-19F-BRANCH, portable-clx-branch, sse2-packed-branch, unicode-utf16-branch, release-19e-branch, sse2-branch, unicode-utf16-extfmt-branch
Changes since 1.7: +1 -1 lines
Fix typos in CVS Id marker.
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 fgilham 1.7
21 dtc 1.5 #+cmu
22 fgilham 1.8 (ext:file-comment "$Id: depdefs.lisp,v 1.8 2007/08/22 03:58:59 fgilham Exp $")
23 ram 1.1
24     (in-package :xlib)
25    
26     ;;;-------------------------------------------------------------------------
27     ;;; Declarations
28     ;;;-------------------------------------------------------------------------
29    
30 fgilham 1.7 ;;; fix a bug in kcl's RATIONAL...
31     ;;; redefine both the function and the type.
32    
33     #+(or kcl ibcl)
34     (progn
35     (defun rational (x)
36     (if (rationalp x)
37     x
38     (lisp:rational x)))
39     (deftype rational (&optional l u) `(lisp:rational ,l ,u)))
40    
41     ;;; DECLAIM
42    
43     #-clx-ansi-common-lisp
44     (defmacro declaim (&rest decl-specs)
45     (if (cdr decl-specs)
46     `(progn
47     ,@(mapcar #'(lambda (decl-spec) `(proclaim ',decl-spec))
48     decl-specs))
49     `(proclaim ',(car decl-specs))))
50    
51 ram 1.3 ;;; CLX-VALUES value1 value2 ... -- Documents the values returned by the function.
52 ram 1.1
53 fgilham 1.7 #-Genera
54 ram 1.3 (declaim (declaration clx-values))
55 ram 1.1
56 fgilham 1.7 #+Genera
57     (setf (get 'clx-values 'si:declaration-alias) 'scl:values)
58    
59 ram 1.1 ;;; ARGLIST arg1 arg2 ... -- Documents the arglist of the function. Overrides
60     ;;; the documentation that might get generated by the real arglist of the
61     ;;; function.
62    
63 fgilham 1.7 #-(or lispm lcl3.0)
64 ram 1.1 (declaim (declaration arglist))
65    
66 fgilham 1.7 ;;; DYNAMIC-EXTENT var -- Tells the compiler that the rest arg var has
67     ;;; dynamic extent and therefore can be kept on the stack and not copied to
68     ;;; the heap, even though the value is passed out of the function.
69    
70     #-(or clx-ansi-common-lisp lcl3.0)
71     (declaim (declaration dynamic-extent))
72    
73     ;;; IGNORABLE var -- Tells the compiler that the variable might or might not be used.
74    
75     #-clx-ansi-common-lisp
76     (declaim (declaration ignorable))
77    
78 ram 1.1 ;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to
79     ;;; indent calls to the function or macro containing the declaration.
80    
81 fgilham 1.7 #-genera
82 ram 1.1 (declaim (declaration indentation))
83    
84     ;;;-------------------------------------------------------------------------
85     ;;; Declaration macros
86     ;;;-------------------------------------------------------------------------
87    
88     ;;; WITH-VECTOR (variable type) &body body --- ensures the variable is a local
89     ;;; and then does a type declaration and array register declaration
90     (defmacro with-vector ((var type) &body body)
91     `(let ((,var ,var))
92 ram 1.3 (declare (type ,type ,var))
93 ram 1.1 ,@body))
94    
95     ;;; WITHIN-DEFINITION (name type) &body body --- Includes definitions for
96     ;;; Meta-.
97    
98 fgilham 1.7 #+lispm
99     (defmacro within-definition ((name type) &body body)
100     `(zl:local-declare
101     ((sys:function-parent ,name ,type))
102     (sys:record-source-file-name ',name ',type)
103     ,@body))
104    
105     #-lispm
106 ram 1.1 (defmacro within-definition ((name type) &body body)
107     (declare (ignore name type))
108     `(progn ,@body))
109    
110    
111     ;;;-------------------------------------------------------------------------
112     ;;; CLX can maintain a mapping from X server ID's to local data types. If
113     ;;; one takes the view that CLX objects will be instance variables of
114     ;;; objects at the next higher level, then PROCESS-EVENT will typically map
115     ;;; from resource-id to higher-level object. In that case, the lower-level
116     ;;; CLX mapping will almost never be used (except in rare cases like
117     ;;; query-tree), and only serve to consume space (which is difficult to
118     ;;; GC), in which case always-consing versions of the make-<mumble>s will
119     ;;; be better. Even when maps are maintained, it isn't clear they are
120     ;;; useful for much beyond xatoms and windows (since almost nothing else
121     ;;; ever comes back in events).
122     ;;;--------------------------------------------------------------------------
123 fgilham 1.7 (defconstant +clx-cached-types+
124     '(drawable
125     window
126     pixmap
127     ;; gcontext
128     cursor
129     colormap
130     font))
131 ram 1.1
132     (defmacro resource-id-map-test ()
133 fgilham 1.7 #+excl '#'equal
134     #-excl '#'eql)
135 ram 1.2 ; (eq fixnum fixnum) is not guaranteed.
136     (defmacro atom-cache-map-test ()
137 fgilham 1.7 #+excl '#'equal
138     #-excl '#'eq)
139 ram 1.1
140     (defmacro keysym->character-map-test ()
141 fgilham 1.7 #+excl '#'equal
142     #-excl '#'eql)
143 ram 1.1
144     ;;; You must define this to match the real byte order. It is used by
145     ;;; overlapping array and image code.
146    
147 fgilham 1.7 #+(or lispm vax little-endian Minima)
148     (eval-when (eval compile load)
149     (pushnew :clx-little-endian *features*))
150    
151     #+lcl3.0
152     (eval-when (compile eval load)
153     (ecase lucid::machine-endian
154     (:big nil)
155     (:little (pushnew :clx-little-endian *features*))))
156    
157 ram 1.3 #+cmu
158     (eval-when (compile eval load)
159     (ecase #.(c:backend-byte-order c:*backend*)
160     (:big-endian)
161     (:little-endian (pushnew :clx-little-endian *features*))))
162 ram 1.1
163 fgilham 1.7 #+sbcl
164     (eval-when (:compile-toplevel :load-toplevel :execute)
165     ;; FIXME: Ideally, we shouldn't end up with the internal
166     ;; :CLX-LITTLE-ENDIAN decorating user-visible *FEATURES* lists.
167     ;; This probably wants to be split up into :compile-toplevel
168     ;; :execute and :load-toplevel clauses, so that loading the compiled
169     ;; code doesn't push the feature.
170     (ecase sb-c:*backend-byte-order*
171     (:big-endian)
172     (:little-endian (pushnew :clx-little-endian *features*))))
173    
174     ;;; Steele's Common-Lisp states: "It is an error if the array specified
175     ;;; as the :displaced-to argument does not have the same :element-type
176     ;;; as the array being created" If this is the case on your lisp, then
177     ;;; leave the overlapping-arrays feature turned off. Lisp machines
178     ;;; (Symbolics TI and LMI) don't have this restriction, and allow arrays
179     ;;; with different element types to overlap. CLX will take advantage of
180     ;;; this to do fast array packing/unpacking when the overlapping-arrays
181     ;;; feature is enabled.
182    
183     #+clisp
184     (eval-when (:compile-toplevel :load-toplevel :execute)
185     (unless system::*big-endian* (pushnew :clx-little-endian *features*)))
186    
187     #+(and clx-little-endian lispm)
188     (eval-when (eval compile load)
189     (pushnew :clx-overlapping-arrays *features*))
190    
191     #+(and clx-overlapping-arrays genera)
192     (progn
193     (deftype overlap16 () '(unsigned-byte 16))
194     (deftype overlap32 () '(signed-byte 32))
195     )
196    
197     #+(and clx-overlapping-arrays (or explorer lambda cadr))
198     (progn
199     (deftype overlap16 () '(unsigned-byte 16))
200     (deftype overlap32 () '(unsigned-byte 32))
201     )
202    
203 ram 1.1 (deftype buffer-bytes () `(simple-array (unsigned-byte 8) (*)))
204    
205 fgilham 1.7 #+clx-overlapping-arrays
206     (progn
207     (deftype buffer-words () `(vector overlap16))
208     (deftype buffer-longs () `(vector overlap32))
209     )
210    
211 ram 1.1 ;;; This defines a type which is a subtype of the integers.
212     ;;; This type is used to describe all variables that can be array indices.
213     ;;; It is here because it is used below.
214     ;;; This is inclusive because start/end can be 1 past the end.
215     (deftype array-index () `(integer 0 ,array-dimension-limit))
216    
217    
218     ;; this is the best place to define these?
219    
220 fgilham 1.7 #-Genera
221 ram 1.1 (progn
222    
223     (defun make-index-typed (form)
224     (if (constantp form) form `(the array-index ,form)))
225    
226     (defun make-index-op (operator args)
227     `(the array-index
228     (values
229     ,(case (length args)
230     (0 `(,operator))
231     (1 `(,operator
232     ,(make-index-typed (first args))))
233     (2 `(,operator
234     ,(make-index-typed (first args))
235     ,(make-index-typed (second args))))
236     (otherwise
237     `(,operator
238     ,(make-index-op operator (subseq args 0 (1- (length args))))
239     ,(make-index-typed (first (last args)))))))))
240    
241     (defmacro index+ (&rest numbers) (make-index-op '+ numbers))
242     (defmacro index-logand (&rest numbers) (make-index-op 'logand numbers))
243     (defmacro index-logior (&rest numbers) (make-index-op 'logior numbers))
244     (defmacro index- (&rest numbers) (make-index-op '- numbers))
245     (defmacro index* (&rest numbers) (make-index-op '* numbers))
246    
247     (defmacro index1+ (number) (make-index-op '1+ (list number)))
248     (defmacro index1- (number) (make-index-op '1- (list number)))
249    
250     (defmacro index-incf (place &optional (delta 1))
251     (make-index-op 'incf (list place delta)))
252     (defmacro index-decf (place &optional (delta 1))
253     (make-index-op 'decf (list place delta)))
254    
255     (defmacro index-min (&rest numbers) (make-index-op 'min numbers))
256     (defmacro index-max (&rest numbers) (make-index-op 'max numbers))
257    
258     (defmacro index-floor (number divisor)
259     (make-index-op 'floor (list number divisor)))
260     (defmacro index-ceiling (number divisor)
261     (make-index-op 'ceiling (list number divisor)))
262     (defmacro index-truncate (number divisor)
263     (make-index-op 'truncate (list number divisor)))
264    
265     (defmacro index-mod (number divisor)
266     (make-index-op 'mod (list number divisor)))
267    
268     (defmacro index-ash (number count)
269     (make-index-op 'ash (list number count)))
270    
271     (defmacro index-plusp (number) `(plusp (the array-index ,number)))
272     (defmacro index-zerop (number) `(zerop (the array-index ,number)))
273     (defmacro index-evenp (number) `(evenp (the array-index ,number)))
274     (defmacro index-oddp (number) `(oddp (the array-index ,number)))
275    
276     (defmacro index> (&rest numbers)
277     `(> ,@(mapcar #'make-index-typed numbers)))
278     (defmacro index= (&rest numbers)
279     `(= ,@(mapcar #'make-index-typed numbers)))
280     (defmacro index< (&rest numbers)
281     `(< ,@(mapcar #'make-index-typed numbers)))
282     (defmacro index>= (&rest numbers)
283     `(>= ,@(mapcar #'make-index-typed numbers)))
284     (defmacro index<= (&rest numbers)
285     `(<= ,@(mapcar #'make-index-typed numbers)))
286    
287     )
288    
289 fgilham 1.7 #+Genera
290     (progn
291    
292     (defmacro index+ (&rest numbers) `(+ ,@numbers))
293     (defmacro index-logand (&rest numbers) `(logand ,@numbers))
294     (defmacro index-logior (&rest numbers) `(logior ,@numbers))
295     (defmacro index- (&rest numbers) `(- ,@numbers))
296     (defmacro index* (&rest numbers) `(* ,@numbers))
297    
298     (defmacro index1+ (number) `(1+ ,number))
299     (defmacro index1- (number) `(1- ,number))
300    
301     (defmacro index-incf (place &optional (delta 1)) `(setf ,place (index+ ,place ,delta)))
302     (defmacro index-decf (place &optional (delta 1)) `(setf ,place (index- ,place ,delta)))
303    
304     (defmacro index-min (&rest numbers) `(min ,@numbers))
305     (defmacro index-max (&rest numbers) `(max ,@numbers))
306    
307     (defun positive-power-of-two-p (x)
308     (when (symbolp x)
309     (multiple-value-bind (constantp value) (lt:named-constant-p x)
310     (when constantp (setq x value))))
311     (and (typep x 'fixnum) (plusp x) (zerop (logand x (1- x)))))
312    
313     (defmacro index-floor (number divisor)
314     (cond ((eql divisor 1) number)
315     ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor))
316     `(si:%fixnum-floor ,number ,divisor))
317     (t `(floor ,number ,divisor))))
318    
319     (defmacro index-ceiling (number divisor)
320     (cond ((eql divisor 1) number)
321     ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-ceiling))
322     `(si:%fixnum-ceiling ,number ,divisor))
323     (t `(ceiling ,number ,divisor))))
324    
325     (defmacro index-truncate (number divisor)
326     (cond ((eql divisor 1) number)
327     ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor))
328     `(si:%fixnum-floor ,number ,divisor))
329     (t `(truncate ,number ,divisor))))
330    
331     (defmacro index-mod (number divisor)
332     (cond ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-mod))
333     `(si:%fixnum-mod ,number ,divisor))
334     (t `(mod ,number ,divisor))))
335    
336     (defmacro index-ash (number count)
337     (cond ((eql count 0) number)
338     ((and (typep count 'fixnum) (minusp count) (fboundp 'si:%fixnum-floor))
339     `(si:%fixnum-floor ,number ,(expt 2 (- count))))
340     ((and (typep count 'fixnum) (plusp count) (fboundp 'si:%fixnum-multiply))
341     `(si:%fixnum-multiply ,number ,(expt 2 count)))
342     (t `(ash ,number ,count))))
343    
344     (defmacro index-plusp (number) `(plusp ,number))
345     (defmacro index-zerop (number) `(zerop ,number))
346     (defmacro index-evenp (number) `(evenp ,number))
347     (defmacro index-oddp (number) `(oddp ,number))
348    
349     (defmacro index> (&rest numbers) `(> ,@numbers))
350     (defmacro index= (&rest numbers) `(= ,@numbers))
351     (defmacro index< (&rest numbers) `(< ,@numbers))
352     (defmacro index>= (&rest numbers) `(>= ,@numbers))
353     (defmacro index<= (&rest numbers) `(<= ,@numbers))
354    
355     )
356 ram 1.1
357     ;;;; Stuff for BUFFER definition
358    
359 fgilham 1.7 (defconstant +replysize+ 32.)
360 ram 1.1
361     ;; used in defstruct initializations to avoid compiler warnings
362     (defvar *empty-bytes* (make-sequence 'buffer-bytes 0))
363     (declaim (type buffer-bytes *empty-bytes*))
364 fgilham 1.7 #+clx-overlapping-arrays
365     (progn
366     (defvar *empty-words* (make-sequence 'buffer-words 0))
367     (declaim (type buffer-words *empty-words*))
368     )
369     #+clx-overlapping-arrays
370     (progn
371     (defvar *empty-longs* (make-sequence 'buffer-longs 0))
372     (declaim (type buffer-longs *empty-longs*))
373     )
374 ram 1.1
375     (defstruct (reply-buffer (:conc-name reply-) (:constructor make-reply-buffer-internal)
376     (:copier nil) (:predicate nil))
377     (size 0 :type array-index) ;Buffer size
378     ;; Byte (8 bit) input buffer
379     (ibuf8 *empty-bytes* :type buffer-bytes)
380     ;; Word (16bit) input buffer
381 fgilham 1.7 #+clx-overlapping-arrays
382     (ibuf16 *empty-words* :type buffer-words)
383     ;; Long (32bit) input buffer
384     #+clx-overlapping-arrays
385     (ibuf32 *empty-longs* :type buffer-longs)
386     (next nil #-explorer :type #-explorer (or null reply-buffer))
387 ram 1.1 (data-size 0 :type array-index)
388     )
389    
390 fgilham 1.7 (defconstant +buffer-text16-size+ 256)
391     (deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,+buffer-text16-size+)))
392 ram 1.1
393     ;; These are here because.
394    
395 ram 1.2 (defparameter *xlib-package* (find-package :xlib))
396 ram 1.1
397     (defun xintern (&rest parts)
398     (intern (apply #'concatenate 'string (mapcar #'string parts)) *xlib-package*))
399    
400 ram 1.2 (defparameter *keyword-package* (find-package :keyword))
401 ram 1.1
402     (defun kintern (name)
403     (intern (string name) *keyword-package*))
404    
405     ;;; Pseudo-class mechanism.
406    
407 fgilham 1.7 (eval-when (:compile-toplevel :load-toplevel :execute)
408     ;; FIXME: maybe we should reevaluate this?
409     (defvar *def-clx-class-use-defclass*
410     #+(or Genera allegro) t
411     #+(and cmu pcl) '(XLIB:DRAWABLE XLIB:WINDOW XLIB:PIXMAP)
412     #+(and cmu (not pcl)) nil
413     #-(or Genera cmu allegro) nil
414     "Controls whether DEF-CLX-CLASS uses DEFCLASS.
415    
416     If it is a list, it is interpreted by DEF-CLX-CLASS to be a list of
417     type names for which DEFCLASS should be used. If it is not a list,
418     then DEFCLASS is always used. If it is NIL, then DEFCLASS is never
419     used, since NIL is the empty list.")
420     )
421 ram 1.2
422 ram 1.1 (defmacro def-clx-class ((name &rest options) &body slots)
423 ram 1.2 (if (or (not (listp *def-clx-class-use-defclass*))
424     (member name *def-clx-class-use-defclass*))
425 fgilham 1.7 (let ((clos-package #+clx-ansi-common-lisp
426     (find-package :common-lisp)
427     #-clx-ansi-common-lisp
428     (or (find-package :clos)
429     (find-package :pcl)
430     (let ((lisp-pkg (find-package :lisp)))
431     (and (find-symbol (string 'defclass) lisp-pkg)
432     lisp-pkg))))
433 ram 1.2 (constructor t)
434     (constructor-args t)
435     (include nil)
436     (print-function nil)
437     (copier t)
438     (predicate t))
439     (dolist (option options)
440     (ecase (pop option)
441     (:constructor
442     (setf constructor (pop option))
443     (setf constructor-args (if (null option) t (pop option))))
444     (:include
445     (setf include (pop option)))
446     (:print-function
447     (setf print-function (pop option)))
448     (:copier
449     (setf copier (pop option)))
450     (:predicate
451     (setf predicate (pop option)))))
452     (flet ((cintern (&rest symbols)
453     (intern (apply #'concatenate 'simple-string
454     (mapcar #'symbol-name symbols))
455     *package*))
456     (kintern (symbol)
457     (intern (symbol-name symbol) (find-package :keyword)))
458     (closintern (symbol)
459     (intern (symbol-name symbol) clos-package)))
460     (when (eq constructor t)
461     (setf constructor (cintern 'make- name)))
462     (when (eq copier t)
463     (setf copier (cintern 'copy- name)))
464     (when (eq predicate t)
465     (setf predicate (cintern name '-p)))
466     (when include
467     (setf slots (append (get include 'def-clx-class) slots)))
468     (let* ((n-slots (length slots))
469     (slot-names (make-list n-slots))
470     (slot-initforms (make-list n-slots))
471     (slot-types (make-list n-slots)))
472     (dotimes (i n-slots)
473     (let ((slot (elt slots i)))
474     (setf (elt slot-names i) (pop slot))
475     (setf (elt slot-initforms i) (pop slot))
476     (setf (elt slot-types i) (getf slot :type t))))
477     `(progn
478 ram 1.1
479 fgilham 1.7 (eval-when (:compile-toplevel :load-toplevel :execute)
480 ram 1.2 (setf (get ',name 'def-clx-class) ',slots))
481 ram 1.1
482 ram 1.2 ;; From here down are the system-specific expansions:
483 ram 1.1
484 ram 1.2 (within-definition (,name def-clx-class)
485     (,(closintern 'defclass)
486     ,name ,(and include `(,include))
487     (,@(map 'list
488     #'(lambda (slot-name slot-initform slot-type)
489     `(,slot-name
490     :initform ,slot-initform :type ,slot-type
491     :accessor ,(cintern name '- slot-name)
492     ,@(when (and constructor
493     (or (eq constructor-args t)
494     (member slot-name
495     constructor-args)))
496     `(:initarg ,(kintern slot-name)))
497     ))
498     slot-names slot-initforms slot-types)))
499     ,(when constructor
500     (if (eq constructor-args t)
501     `(defun ,constructor (&rest args)
502     (apply #',(closintern 'make-instance)
503     ',name args))
504     `(defun ,constructor ,constructor-args
505     (,(closintern 'make-instance) ',name
506     ,@(mapcan #'(lambda (slot-name)
507     (and (member slot-name slot-names)
508     `(,(kintern slot-name) ,slot-name)))
509     constructor-args)))))
510     ,(when predicate
511 fgilham 1.7 #+allegro
512     `(progn
513     (,(closintern 'defmethod) ,predicate (object)
514     (declare (ignore object))
515     nil)
516     (,(closintern 'defmethod) ,predicate ((object ,name))
517     t))
518     #-allegro
519 ram 1.2 `(defun ,predicate (object)
520     (typep object ',name)))
521     ,(when copier
522     `(,(closintern 'defmethod) ,copier ((.object. ,name))
523     (,(closintern 'with-slots) ,slot-names .object.
524     (,(closintern 'make-instance) ',name
525     ,@(mapcan #'(lambda (slot-name)
526     `(,(kintern slot-name) ,slot-name))
527     slot-names)))))
528     ,(when print-function
529     `(,(closintern 'defmethod)
530     ,(closintern 'print-object)
531     ((object ,name) stream)
532     (,print-function object stream 0))))))))
533     `(within-definition (,name def-clx-class)
534     (defstruct (,name ,@options)
535     ,@slots))))
536 ram 1.1
537 fgilham 1.7 #+Genera
538     (progn
539     (scl:defprop def-clx-class "CLX Class" si:definition-type-name)
540     (scl:defprop def-clx-class zwei:defselect-function-spec-finder
541     zwei:definition-function-spec-finder))
542    
543    
544 ram 1.1 ;; We need this here so we can define DISPLAY for CLX.
545     ;;
546     ;; This structure is :INCLUDEd in the DISPLAY structure.
547     ;; Overlapping (displaced) arrays are provided for byte
548     ;; half-word and word access on both input and output.
549     ;;
550     (def-clx-class (buffer (:constructor nil) (:copier nil) (:predicate nil))
551     ;; Lock for multi-processing systems
552     (lock (make-process-lock "CLX Buffer Lock"))
553 fgilham 1.7 #-excl (output-stream nil :type (or null stream))
554     #+excl (output-stream -1 :type fixnum)
555 ram 1.1 ;; Buffer size
556     (size 0 :type array-index)
557     (request-number 0 :type (unsigned-byte 16))
558     ;; Byte position of start of last request
559     ;; used for appending requests and error recovery
560     (last-request nil :type (or null array-index))
561     ;; Byte position of start of last flushed request
562     (last-flushed-request nil :type (or null array-index))
563     ;; Current byte offset
564     (boffset 0 :type array-index)
565     ;; Byte (8 bit) output buffer
566     (obuf8 *empty-bytes* :type buffer-bytes)
567 fgilham 1.7 ;; Word (16bit) output buffer
568     #+clx-overlapping-arrays
569     (obuf16 *empty-words* :type buffer-words)
570     ;; Long (32bit) output buffer
571     #+clx-overlapping-arrays
572     (obuf32 *empty-longs* :type buffer-longs)
573 ram 1.1 ;; Holding buffer for 16-bit text
574 fgilham 1.7 (tbuf16 (make-sequence 'buffer-text16 +buffer-text16-size+ :initial-element 0))
575 ram 1.1 ;; Probably EQ to Output-Stream
576 fgilham 1.7 #-excl (input-stream nil :type (or null stream))
577     #+excl (input-stream -1 :type fixnum)
578 ram 1.1 ;; T when the host connection has gotten errors
579     (dead nil :type (or null (not null)))
580     ;; T makes buffer-flush a noop. Manipulated with with-buffer-flush-inhibited.
581     (flush-inhibit nil :type (or null (not null)))
582    
583     ;; Change these functions when using shared memory buffers to the server
584     ;; Function to call when writing the buffer
585     (write-function 'buffer-write-default)
586     ;; Function to call when flushing the buffer
587     (force-output-function 'buffer-force-output-default)
588     ;; Function to call when closing a connection
589     (close-function 'buffer-close-default)
590     ;; Function to call when reading the buffer
591     (input-function 'buffer-read-default)
592     ;; Function to call to wait for data to be input
593     (input-wait-function 'buffer-input-wait-default)
594     ;; Function to call to listen for input data
595     (listen-function 'buffer-listen-default)
596    
597 fgilham 1.7 #+Genera (debug-io nil :type (or null stream))
598 ram 1.1 )
599    
600     ;;-----------------------------------------------------------------------------
601 fgilham 1.7 ;; Printing routines.
602     ;;-----------------------------------------------------------------------------
603    
604     #-(or clx-ansi-common-lisp Genera)
605     (defun print-unreadable-object-function (object stream type identity function)
606     (declare #+lispm
607     (sys:downward-funarg function))
608     (princ "#<" stream)
609     (when type
610     (let ((type (type-of object))
611     (pcl-package (find-package :pcl)))
612     ;; Handle pcl type-of lossage
613     (when (and pcl-package
614     (symbolp type)
615     (eq (symbol-package type) pcl-package)
616     (string-equal (symbol-name type) "STD-INSTANCE"))
617     (setq type
618     (funcall (intern (symbol-name 'class-name) pcl-package)
619     (funcall (intern (symbol-name 'class-of) pcl-package)
620     object))))
621     (prin1 type stream)))
622     (when (and type function) (princ " " stream))
623     (when function (funcall function))
624     (when (and (or type function) identity) (princ " " stream))
625     (when identity (princ "???" stream))
626     (princ ">" stream)
627     nil)
628    
629     #-(or clx-ansi-common-lisp Genera)
630     (defmacro print-unreadable-object
631     ((object stream &key type identity) &body body)
632     (if body
633     `(flet ((.print-unreadable-object-body. () ,@body))
634     (print-unreadable-object-function
635     ,object ,stream ,type ,identity #'.print-unreadable-object-body.))
636     `(print-unreadable-object-function ,object ,stream ,type ,identity nil)))
637    
638    
639     ;;-----------------------------------------------------------------------------
640 ram 1.1 ;; Image stuff
641     ;;-----------------------------------------------------------------------------
642    
643 fgilham 1.7 (defconstant +image-bit-lsb-first-p+
644 ram 1.1 #+clx-little-endian t
645     #-clx-little-endian nil)
646    
647 fgilham 1.7 (defconstant +image-byte-lsb-first-p+
648 ram 1.1 #+clx-little-endian t
649     #-clx-little-endian nil)
650    
651 fgilham 1.7 (defconstant +image-unit+ 32)
652 ram 1.1
653 fgilham 1.7 (defconstant +image-pad+ 32)
654    
655    
656     ;;-----------------------------------------------------------------------------
657     ;; Foreign Functions
658     ;;-----------------------------------------------------------------------------
659 ram 1.2
660 fgilham 1.7 #+(and lucid apollo (not lcl3.0))
661     (lucid::define-foreign-function '(connect-to-server "connect_to_server")
662     '((:val host :string)
663     (:val display :integer32))
664     :integer32)
665    
666     #+(and lucid (not apollo) (not lcl3.0))
667     (lucid::define-c-function connect-to-server (host display)
668     :result-type :integer)
669    
670     #+lcl3.0
671     (lucid::def-foreign-function
672     (connect-to-server
673     (:language :c)
674     (:return-type :signed-32bit))
675     (host :simple-string)
676     (display :signed-32bit))

  ViewVC Help
Powered by ViewVC 1.1.5