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

Contents of /src/clx/depdefs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8.14.1 - (show annotations)
Wed Jun 17 15:46:26 2009 UTC (4 years, 10 months ago) by rtoy
Branch: portable-clx-branch
CVS Tags: portable-clx-import-2009-06-16
Changes since 1.8: +20 -3 lines
Import portable clx version from Christophe Rhodes darcs repository as
of 2009-06-16.

This is an exact copy of the code.  It is intended updates of
portable-clx go on the portable-clx-branch and should be merged to the
main branch as needed.  This should make it easier to do any
CMUCL-specific changes that aren't in portable-clx.

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

  ViewVC Help
Powered by ViewVC 1.1.5