/[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 - (hide 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 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 ram 1.1 (in-package :xlib)
22    
23     ;;;-------------------------------------------------------------------------
24     ;;; Declarations
25     ;;;-------------------------------------------------------------------------
26    
27 fgilham 1.7 ;;; 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 ram 1.3 ;;; CLX-VALUES value1 value2 ... -- Documents the values returned by the function.
49 ram 1.1
50 fgilham 1.7 #-Genera
51 ram 1.3 (declaim (declaration clx-values))
52 ram 1.1
53 fgilham 1.7 #+Genera
54     (setf (get 'clx-values 'si:declaration-alias) 'scl:values)
55    
56 ram 1.1 ;;; 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 fgilham 1.7 #-(or lispm lcl3.0)
61 ram 1.1 (declaim (declaration arglist))
62    
63 fgilham 1.7 ;;; 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 ram 1.1 ;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to
76     ;;; indent calls to the function or macro containing the declaration.
77    
78 fgilham 1.7 #-genera
79 ram 1.1 (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 ram 1.3 (declare (type ,type ,var))
90 ram 1.1 ,@body))
91    
92     ;;; WITHIN-DEFINITION (name type) &body body --- Includes definitions for
93     ;;; Meta-.
94    
95 fgilham 1.7 #+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 ram 1.1 (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 fgilham 1.7 (defconstant +clx-cached-types+
121     '(drawable
122     window
123     pixmap
124     ;; gcontext
125     cursor
126     colormap
127     font))
128 ram 1.1
129     (defmacro resource-id-map-test ()
130 fgilham 1.7 #+excl '#'equal
131     #-excl '#'eql)
132 ram 1.2 ; (eq fixnum fixnum) is not guaranteed.
133     (defmacro atom-cache-map-test ()
134 fgilham 1.7 #+excl '#'equal
135     #-excl '#'eq)
136 ram 1.1
137     (defmacro keysym->character-map-test ()
138 fgilham 1.7 #+excl '#'equal
139     #-excl '#'eql)
140 ram 1.1
141     ;;; You must define this to match the real byte order. It is used by
142     ;;; overlapping array and image code.
143    
144 fgilham 1.7 #+(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 ram 1.3 #+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 ram 1.1
160 fgilham 1.7 #+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 ram 1.1 (deftype buffer-bytes () `(simple-array (unsigned-byte 8) (*)))
201    
202 fgilham 1.7 #+clx-overlapping-arrays
203     (progn
204     (deftype buffer-words () `(vector overlap16))
205     (deftype buffer-longs () `(vector overlap32))
206     )
207    
208 ram 1.1 ;;; 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 fgilham 1.7 #-Genera
218 ram 1.1 (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 fgilham 1.7 #+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 ram 1.1
354     ;;;; Stuff for BUFFER definition
355    
356 fgilham 1.7 (defconstant +replysize+ 32.)
357 ram 1.1
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 fgilham 1.7 #+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 ram 1.1
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 fgilham 1.7 #+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 ram 1.1 (data-size 0 :type array-index)
385     )
386    
387 fgilham 1.7 (defconstant +buffer-text16-size+ 256)
388     (deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,+buffer-text16-size+)))
389 ram 1.1
390     ;; These are here because.
391    
392 ram 1.2 (defparameter *xlib-package* (find-package :xlib))
393 ram 1.1
394     (defun xintern (&rest parts)
395     (intern (apply #'concatenate 'string (mapcar #'string parts)) *xlib-package*))
396    
397 ram 1.2 (defparameter *keyword-package* (find-package :keyword))
398 ram 1.1
399     (defun kintern (name)
400     (intern (string name) *keyword-package*))
401    
402     ;;; Pseudo-class mechanism.
403    
404 fgilham 1.7 (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 ram 1.2
419 ram 1.1 (defmacro def-clx-class ((name &rest options) &body slots)
420 ram 1.2 (if (or (not (listp *def-clx-class-use-defclass*))
421     (member name *def-clx-class-use-defclass*))
422 fgilham 1.7 (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 ram 1.2 (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 ram 1.1
476 fgilham 1.7 (eval-when (:compile-toplevel :load-toplevel :execute)
477 ram 1.2 (setf (get ',name 'def-clx-class) ',slots))
478 ram 1.1
479 ram 1.2 ;; From here down are the system-specific expansions:
480 ram 1.1
481 ram 1.2 (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 fgilham 1.7 #+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 ram 1.2 `(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 ram 1.1
534 fgilham 1.7 #+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 ram 1.1 ;; 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 fgilham 1.7 #-excl (output-stream nil :type (or null stream))
551     #+excl (output-stream -1 :type fixnum)
552 ram 1.1 ;; 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 fgilham 1.7 ;; 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 ram 1.1 ;; Holding buffer for 16-bit text
571 fgilham 1.7 (tbuf16 (make-sequence 'buffer-text16 +buffer-text16-size+ :initial-element 0))
572 ram 1.1 ;; Probably EQ to Output-Stream
573 fgilham 1.7 #-excl (input-stream nil :type (or null stream))
574     #+excl (input-stream -1 :type fixnum)
575 ram 1.1 ;; 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 fgilham 1.7 #+Genera (debug-io nil :type (or null stream))
595 ram 1.1 )
596    
597     ;;-----------------------------------------------------------------------------
598 fgilham 1.7 ;; 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 ram 1.1 ;; Image stuff
638     ;;-----------------------------------------------------------------------------
639    
640 fgilham 1.7 (defconstant +image-bit-lsb-first-p+
641 ram 1.1 #+clx-little-endian t
642     #-clx-little-endian nil)
643    
644 fgilham 1.7 (defconstant +image-byte-lsb-first-p+
645 ram 1.1 #+clx-little-endian t
646     #-clx-little-endian nil)
647    
648 fgilham 1.7 (defconstant +image-unit+ 32)
649 ram 1.1
650 fgilham 1.7 (defconstant +image-pad+ 32)
651    
652    
653     ;;-----------------------------------------------------------------------------
654     ;; Foreign Functions
655     ;;-----------------------------------------------------------------------------
656 ram 1.2
657 fgilham 1.7 #+(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 rtoy 1.8.14.1
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