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

Contents of /src/clx/depdefs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (show annotations)
Wed Jun 17 18:22:46 2009 UTC (4 years, 10 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, intl-branch-working-2010-02-19-1000, unicode-string-buffer-impl-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, intl-2-branch-base, GIT-CONVERSION, cross-sol-x86-merged, intl-branch-working-2010-02-11-1000, RELEASE_20b, release-20a-base, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, pre-merge-intl-branch, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, snapshot-2010-08, cross-sol-x86-2010-12-20, intl-branch-2010-03-18-1300, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, cross-sparc-branch-base, intl-branch-base, snapshot-2009-08, snapshot-2009-07, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, cross-sol-x86-branch, intl-2-branch
Changes since 1.8: +21 -1 lines
Merge portable-clx (2009-06-16) to main branch.  Tested by running
src/contrib/games/feebs and hemlock which works (in non-unicode
builds).
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
21 #+cmu
22 (ext:file-comment "$Id: depdefs.lisp,v 1.9 2009/06/17 18:22:46 rtoy Rel $")
23
24 (in-package :xlib)
25
26 ;;;-------------------------------------------------------------------------
27 ;;; Declarations
28 ;;;-------------------------------------------------------------------------
29
30 ;;; 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 ;;; CLX-VALUES value1 value2 ... -- Documents the values returned by the function.
52
53 #-Genera
54 (declaim (declaration clx-values))
55
56 #+Genera
57 (setf (get 'clx-values 'si:declaration-alias) 'scl:values)
58
59 ;;; 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 #-(or lispm lcl3.0)
64 (declaim (declaration arglist))
65
66 ;;; 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 ;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to
79 ;;; indent calls to the function or macro containing the declaration.
80
81 #-genera
82 (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 (declare (type ,type ,var))
93 ,@body))
94
95 ;;; WITHIN-DEFINITION (name type) &body body --- Includes definitions for
96 ;;; Meta-.
97
98 #+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 (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 (defconstant +clx-cached-types+
124 '(drawable
125 window
126 pixmap
127 ;; gcontext
128 cursor
129 colormap
130 font))
131
132 (defmacro resource-id-map-test ()
133 #+excl '#'equal
134 #-excl '#'eql)
135 ; (eq fixnum fixnum) is not guaranteed.
136 (defmacro atom-cache-map-test ()
137 #+excl '#'equal
138 #-excl '#'eq)
139
140 (defmacro keysym->character-map-test ()
141 #+excl '#'equal
142 #-excl '#'eql)
143
144 ;;; You must define this to match the real byte order. It is used by
145 ;;; overlapping array and image code.
146
147 #+(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 #+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
163 #+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 (deftype buffer-bytes () `(simple-array (unsigned-byte 8) (*)))
204
205 #+clx-overlapping-arrays
206 (progn
207 (deftype buffer-words () `(vector overlap16))
208 (deftype buffer-longs () `(vector overlap32))
209 )
210
211 ;;; 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 #-Genera
221 (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 #+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
357 ;;;; Stuff for BUFFER definition
358
359 (defconstant +replysize+ 32.)
360
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 #+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
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 #+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 (data-size 0 :type array-index)
388 )
389
390 (defconstant +buffer-text16-size+ 256)
391 (deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,+buffer-text16-size+)))
392
393 ;; These are here because.
394
395 (defparameter *xlib-package* (find-package :xlib))
396
397 (defun xintern (&rest parts)
398 (intern (apply #'concatenate 'string (mapcar #'string parts)) *xlib-package*))
399
400 (defparameter *keyword-package* (find-package :keyword))
401
402 (defun kintern (name)
403 (intern (string name) *keyword-package*))
404
405 ;;; Pseudo-class mechanism.
406
407 (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
422 (defmacro def-clx-class ((name &rest options) &body slots)
423 (if (or (not (listp *def-clx-class-use-defclass*))
424 (member name *def-clx-class-use-defclass*))
425 (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 (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
479 (eval-when (:compile-toplevel :load-toplevel :execute)
480 (setf (get ',name 'def-clx-class) ',slots))
481
482 ;; From here down are the system-specific expansions:
483
484 (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 #+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 `(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
537 #+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 ;; 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 #-excl (output-stream nil :type (or null stream))
554 #+excl (output-stream -1 :type fixnum)
555 ;; 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 ;; 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 ;; Holding buffer for 16-bit text
574 (tbuf16 (make-sequence 'buffer-text16 +buffer-text16-size+ :initial-element 0))
575 ;; Probably EQ to Output-Stream
576 #-excl (input-stream nil :type (or null stream))
577 #+excl (input-stream -1 :type fixnum)
578 ;; 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 #+Genera (debug-io nil :type (or null stream))
598 )
599
600 ;;-----------------------------------------------------------------------------
601 ;; 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 ;; Image stuff
641 ;;-----------------------------------------------------------------------------
642
643 (defconstant +image-bit-lsb-first-p+
644 #+clx-little-endian t
645 #-clx-little-endian nil)
646
647 (defconstant +image-byte-lsb-first-p+
648 #+clx-little-endian t
649 #-clx-little-endian nil)
650
651 (defconstant +image-unit+ 32)
652
653 (defconstant +image-pad+ 32)
654
655
656 ;;-----------------------------------------------------------------------------
657 ;; Foreign Functions
658 ;;-----------------------------------------------------------------------------
659
660 #+(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))
677
678
679 ;;-----------------------------------------------------------------------------
680 ;; Finding the server socket
681 ;;-----------------------------------------------------------------------------
682
683 ;; These are here because dep-openmcl.lisp and dependent.lisp both need them
684 (defconstant +X-unix-socket-path+
685 "/tmp/.X11-unix/X"
686 "The location of the X socket")
687
688 (defun unix-socket-path-from-host (host display)
689 "Return the name of the unix domain socket for host and display, or
690 nil if a network socket should be opened."
691 (cond ((or (string= host "") (string= host "unix"))
692 (format nil "~A~D" +X-unix-socket-path+ display))
693 #+darwin
694 ((and (> (length host) 10) (string= host "tmp/launch" :end1 10))
695 (format nil "/~A:~D" host display))
696 (t nil)))

  ViewVC Help
Powered by ViewVC 1.1.5