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

Contents of /src/clx/depdefs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (hide annotations)
Sat Dec 19 15:21:15 1998 UTC (15 years, 4 months ago) by dtc
Branch: MAIN
Changes since 1.4: +3 -0 lines
Add CMUCL style file-comment's; from Peter Van Eynde.
1 ram 1.1 ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
2    
3     ;; This file contains some of the system dependent code for CLX
4    
5     ;;;
6     ;;; TEXAS INSTRUMENTS INCORPORATED
7     ;;; P.O. BOX 2909
8     ;;; AUSTIN, TEXAS 78769
9     ;;;
10     ;;; Copyright (C) 1987 Texas Instruments Incorporated.
11     ;;;
12     ;;; Permission is granted to any individual or institution to use, copy, modify,
13     ;;; and distribute this software, provided that this complete copyright and
14     ;;; permission notice is maintained, intact, in all copies and supporting
15     ;;; documentation.
16     ;;;
17     ;;; Texas Instruments Incorporated provides this software "as is" without
18     ;;; express or implied warranty.
19     ;;;
20 dtc 1.5 #+cmu
21     (ext:file-comment
22     "$Header: /tiger/var/lib/cvsroots/cmucl/src/clx/depdefs.lisp,v 1.5 1998/12/19 15:21:15 dtc Exp $")
23 ram 1.1
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 ram 1.2 (deftype rational (&optional l u) `(lisp:rational ,l ,u)))
40 ram 1.1
41     ;;; DECLAIM
42    
43 ram 1.2 #-clx-ansi-common-lisp
44 ram 1.1 (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 ram 1.3 #-Genera
54     (declaim (declaration clx-values))
55 ram 1.1
56 ram 1.3 #+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     #-(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 ram 1.2 #-(or clx-ansi-common-lisp lcl3.0)
71 ram 1.1 (declaim (declaration dynamic-extent))
72    
73 ram 1.2 ;;; 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     #-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 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     #+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 ram 1.2 #-excl '#'eql)
135     ; (eq fixnum fixnum) is not guaranteed.
136     (defmacro atom-cache-map-test ()
137     #+excl '#'equal
138     #-excl '#'eq)
139 ram 1.1
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 ram 1.2 #+(or lispm vax little-endian Minima)
148 ram 1.1 (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 ram 1.2 (:big nil)
155 ram 1.1 (:little (pushnew :clx-little-endian *features*))))
156 ram 1.3
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 ram 1.1
163     ;;; Steele's Common-Lisp states: "It is an error if the array specified
164     ;;; as the :displaced-to argument does not have the same :element-type
165     ;;; as the array being created" If this is the case on your lisp, then
166     ;;; leave the overlapping-arrays feature turned off. Lisp machines
167     ;;; (Symbolics TI and LMI) don't have this restriction, and allow arrays
168     ;;; with different element types to overlap. CLX will take advantage of
169     ;;; this to do fast array packing/unpacking when the overlapping-arrays
170     ;;; feature is enabled.
171    
172     #+(and clx-little-endian lispm)
173     (eval-when (eval compile load)
174     (pushnew :clx-overlapping-arrays *features*))
175    
176     #+(and clx-overlapping-arrays genera)
177     (progn
178     (deftype overlap16 () '(unsigned-byte 16))
179     (deftype overlap32 () '(signed-byte 32))
180     )
181    
182     #+(and clx-overlapping-arrays (or explorer lambda cadr))
183     (progn
184     (deftype overlap16 () '(unsigned-byte 16))
185     (deftype overlap32 () '(unsigned-byte 32))
186     )
187    
188     (deftype buffer-bytes () `(simple-array (unsigned-byte 8) (*)))
189    
190     #+clx-overlapping-arrays
191     (progn
192     (deftype buffer-words () `(vector overlap16))
193     (deftype buffer-longs () `(vector overlap32))
194     )
195    
196     ;;; This defines a type which is a subtype of the integers.
197     ;;; This type is used to describe all variables that can be array indices.
198     ;;; It is here because it is used below.
199     ;;; This is inclusive because start/end can be 1 past the end.
200     (deftype array-index () `(integer 0 ,array-dimension-limit))
201    
202    
203     ;; this is the best place to define these?
204    
205     #-Genera
206     (progn
207    
208     (defun make-index-typed (form)
209     (if (constantp form) form `(the array-index ,form)))
210    
211     (defun make-index-op (operator args)
212     `(the array-index
213     (values
214     ,(case (length args)
215     (0 `(,operator))
216     (1 `(,operator
217     ,(make-index-typed (first args))))
218     (2 `(,operator
219     ,(make-index-typed (first args))
220     ,(make-index-typed (second args))))
221     (otherwise
222     `(,operator
223     ,(make-index-op operator (subseq args 0 (1- (length args))))
224     ,(make-index-typed (first (last args)))))))))
225    
226     (defmacro index+ (&rest numbers) (make-index-op '+ numbers))
227     (defmacro index-logand (&rest numbers) (make-index-op 'logand numbers))
228     (defmacro index-logior (&rest numbers) (make-index-op 'logior numbers))
229     (defmacro index- (&rest numbers) (make-index-op '- numbers))
230     (defmacro index* (&rest numbers) (make-index-op '* numbers))
231    
232     (defmacro index1+ (number) (make-index-op '1+ (list number)))
233     (defmacro index1- (number) (make-index-op '1- (list number)))
234    
235     (defmacro index-incf (place &optional (delta 1))
236     (make-index-op 'incf (list place delta)))
237     (defmacro index-decf (place &optional (delta 1))
238     (make-index-op 'decf (list place delta)))
239    
240     (defmacro index-min (&rest numbers) (make-index-op 'min numbers))
241     (defmacro index-max (&rest numbers) (make-index-op 'max numbers))
242    
243     (defmacro index-floor (number divisor)
244     (make-index-op 'floor (list number divisor)))
245     (defmacro index-ceiling (number divisor)
246     (make-index-op 'ceiling (list number divisor)))
247     (defmacro index-truncate (number divisor)
248     (make-index-op 'truncate (list number divisor)))
249    
250     (defmacro index-mod (number divisor)
251     (make-index-op 'mod (list number divisor)))
252    
253     (defmacro index-ash (number count)
254     (make-index-op 'ash (list number count)))
255    
256     (defmacro index-plusp (number) `(plusp (the array-index ,number)))
257     (defmacro index-zerop (number) `(zerop (the array-index ,number)))
258     (defmacro index-evenp (number) `(evenp (the array-index ,number)))
259     (defmacro index-oddp (number) `(oddp (the array-index ,number)))
260    
261     (defmacro index> (&rest numbers)
262     `(> ,@(mapcar #'make-index-typed numbers)))
263     (defmacro index= (&rest numbers)
264     `(= ,@(mapcar #'make-index-typed numbers)))
265     (defmacro index< (&rest numbers)
266     `(< ,@(mapcar #'make-index-typed numbers)))
267     (defmacro index>= (&rest numbers)
268     `(>= ,@(mapcar #'make-index-typed numbers)))
269     (defmacro index<= (&rest numbers)
270     `(<= ,@(mapcar #'make-index-typed numbers)))
271    
272     )
273    
274     #+Genera
275     (progn
276    
277     (defmacro index+ (&rest numbers) `(+ ,@numbers))
278     (defmacro index-logand (&rest numbers) `(logand ,@numbers))
279     (defmacro index-logior (&rest numbers) `(logior ,@numbers))
280     (defmacro index- (&rest numbers) `(- ,@numbers))
281     (defmacro index* (&rest numbers) `(* ,@numbers))
282    
283     (defmacro index1+ (number) `(1+ ,number))
284     (defmacro index1- (number) `(1- ,number))
285    
286     (defmacro index-incf (place &optional (delta 1)) `(setf ,place (index+ ,place ,delta)))
287     (defmacro index-decf (place &optional (delta 1)) `(setf ,place (index- ,place ,delta)))
288    
289     (defmacro index-min (&rest numbers) `(min ,@numbers))
290     (defmacro index-max (&rest numbers) `(max ,@numbers))
291    
292     (defun positive-power-of-two-p (x)
293 ram 1.2 (when (symbolp x)
294     (multiple-value-bind (constantp value) (lt:named-constant-p x)
295     (when constantp (setq x value))))
296 ram 1.1 (and (typep x 'fixnum) (plusp x) (zerop (logand x (1- x)))))
297    
298     (defmacro index-floor (number divisor)
299     (cond ((eql divisor 1) number)
300     ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor))
301     `(si:%fixnum-floor ,number ,divisor))
302     (t `(floor ,number ,divisor))))
303    
304     (defmacro index-ceiling (number divisor)
305     (cond ((eql divisor 1) number)
306     ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-ceiling))
307     `(si:%fixnum-ceiling ,number ,divisor))
308     (t `(ceiling ,number ,divisor))))
309    
310     (defmacro index-truncate (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 `(truncate ,number ,divisor))))
315    
316     (defmacro index-mod (number divisor)
317     (cond ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-mod))
318     `(si:%fixnum-mod ,number ,divisor))
319     (t `(mod ,number ,divisor))))
320    
321     (defmacro index-ash (number count)
322     (cond ((eql count 0) number)
323     ((and (typep count 'fixnum) (minusp count) (fboundp 'si:%fixnum-floor))
324     `(si:%fixnum-floor ,number ,(expt 2 (- count))))
325     ((and (typep count 'fixnum) (plusp count) (fboundp 'si:%fixnum-multiply))
326     `(si:%fixnum-multiply ,number ,(expt 2 count)))
327     (t `(ash ,number ,count))))
328    
329     (defmacro index-plusp (number) `(plusp ,number))
330     (defmacro index-zerop (number) `(zerop ,number))
331     (defmacro index-evenp (number) `(evenp ,number))
332     (defmacro index-oddp (number) `(oddp ,number))
333    
334     (defmacro index> (&rest numbers) `(> ,@numbers))
335     (defmacro index= (&rest numbers) `(= ,@numbers))
336     (defmacro index< (&rest numbers) `(< ,@numbers))
337     (defmacro index>= (&rest numbers) `(>= ,@numbers))
338     (defmacro index<= (&rest numbers) `(<= ,@numbers))
339    
340     )
341    
342     ;;;; Stuff for BUFFER definition
343    
344     (defconstant *replysize* 32.)
345    
346     ;; used in defstruct initializations to avoid compiler warnings
347     (defvar *empty-bytes* (make-sequence 'buffer-bytes 0))
348     (declaim (type buffer-bytes *empty-bytes*))
349     #+clx-overlapping-arrays
350     (progn
351     (defvar *empty-words* (make-sequence 'buffer-words 0))
352     (declaim (type buffer-words *empty-words*))
353     )
354     #+clx-overlapping-arrays
355     (progn
356     (defvar *empty-longs* (make-sequence 'buffer-longs 0))
357     (declaim (type buffer-longs *empty-longs*))
358     )
359    
360     (defstruct (reply-buffer (:conc-name reply-) (:constructor make-reply-buffer-internal)
361     (:copier nil) (:predicate nil))
362     (size 0 :type array-index) ;Buffer size
363     ;; Byte (8 bit) input buffer
364     (ibuf8 *empty-bytes* :type buffer-bytes)
365     ;; Word (16bit) input buffer
366     #+clx-overlapping-arrays
367     (ibuf16 *empty-words* :type buffer-words)
368     ;; Long (32bit) input buffer
369     #+clx-overlapping-arrays
370     (ibuf32 *empty-longs* :type buffer-longs)
371     (next nil #-explorer :type #-explorer (or null reply-buffer))
372     (data-size 0 :type array-index)
373     )
374    
375     (defconstant *buffer-text16-size* 256)
376     (deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,*buffer-text16-size*)))
377    
378     ;; These are here because.
379    
380 ram 1.2 (defparameter *xlib-package* (find-package :xlib))
381 ram 1.1
382     (defun xintern (&rest parts)
383     (intern (apply #'concatenate 'string (mapcar #'string parts)) *xlib-package*))
384    
385 ram 1.2 (defparameter *keyword-package* (find-package :keyword))
386 ram 1.1
387     (defun kintern (name)
388     (intern (string name) *keyword-package*))
389    
390     ;;; Pseudo-class mechanism.
391    
392 ram 1.2 (eval-when (eval compile load)
393 pw 1.4 (defvar *def-clx-class-use-defclass*
394     #+Genera t
395     #+(and cmu pcl) '(XLIB:DRAWABLE XLIB:WINDOW XLIB:PIXMAP)
396     #+(and cmu (not pcl)) nil
397     #-(or Genera cmu) nil
398 ram 1.2 "Controls whether DEF-CLX-CLASS uses DEFCLASS.
399     If it is a list, it is interpreted by DEF-CLX-CLASS to be a list of type names
400     for which DEFCLASS should be used.
401     If it is not a list, then DEFCLASS is always used.
402     If it is NIL, then DEFCLASS is never used, since NIL is the empty list.")
403     )
404    
405 ram 1.1 (defmacro def-clx-class ((name &rest options) &body slots)
406 ram 1.2 (if (or (not (listp *def-clx-class-use-defclass*))
407     (member name *def-clx-class-use-defclass*))
408     (let ((clos-package #+clx-ansi-common-lisp
409     (find-package :common-lisp)
410     #-clx-ansi-common-lisp
411     (or (find-package :clos)
412     (find-package :pcl)
413     (let ((lisp-pkg (find-package :lisp)))
414     (and (find-symbol (string 'defclass) lisp-pkg)
415     lisp-pkg))))
416     (constructor t)
417     (constructor-args t)
418     (include nil)
419     (print-function nil)
420     (copier t)
421     (predicate t))
422     (dolist (option options)
423     (ecase (pop option)
424     (:constructor
425     (setf constructor (pop option))
426     (setf constructor-args (if (null option) t (pop option))))
427     (:include
428     (setf include (pop option)))
429     (:print-function
430     (setf print-function (pop option)))
431     (:copier
432     (setf copier (pop option)))
433     (:predicate
434     (setf predicate (pop option)))))
435     (flet ((cintern (&rest symbols)
436     (intern (apply #'concatenate 'simple-string
437     (mapcar #'symbol-name symbols))
438     *package*))
439     (kintern (symbol)
440     (intern (symbol-name symbol) (find-package :keyword)))
441     (closintern (symbol)
442     (intern (symbol-name symbol) clos-package)))
443     (when (eq constructor t)
444     (setf constructor (cintern 'make- name)))
445     (when (eq copier t)
446     (setf copier (cintern 'copy- name)))
447     (when (eq predicate t)
448     (setf predicate (cintern name '-p)))
449     (when include
450     (setf slots (append (get include 'def-clx-class) slots)))
451     (let* ((n-slots (length slots))
452     (slot-names (make-list n-slots))
453     (slot-initforms (make-list n-slots))
454     (slot-types (make-list n-slots)))
455     (dotimes (i n-slots)
456     (let ((slot (elt slots i)))
457     (setf (elt slot-names i) (pop slot))
458     (setf (elt slot-initforms i) (pop slot))
459     (setf (elt slot-types i) (getf slot :type t))))
460     `(progn
461 ram 1.1
462 ram 1.2 (eval-when (compile load eval)
463     (setf (get ',name 'def-clx-class) ',slots))
464 ram 1.1
465 ram 1.2 ;; From here down are the system-specific expansions:
466 ram 1.1
467 ram 1.2 (within-definition (,name def-clx-class)
468     (,(closintern 'defclass)
469     ,name ,(and include `(,include))
470     (,@(map 'list
471     #'(lambda (slot-name slot-initform slot-type)
472     `(,slot-name
473     :initform ,slot-initform :type ,slot-type
474     :accessor ,(cintern name '- slot-name)
475     ,@(when (and constructor
476     (or (eq constructor-args t)
477     (member slot-name
478     constructor-args)))
479     `(:initarg ,(kintern slot-name)))
480     ))
481     slot-names slot-initforms slot-types)))
482     ,(when constructor
483     (if (eq constructor-args t)
484     `(defun ,constructor (&rest args)
485     (apply #',(closintern 'make-instance)
486     ',name args))
487     `(defun ,constructor ,constructor-args
488     (,(closintern 'make-instance) ',name
489     ,@(mapcan #'(lambda (slot-name)
490     (and (member slot-name slot-names)
491     `(,(kintern slot-name) ,slot-name)))
492     constructor-args)))))
493     ,(when predicate
494     #+allegro
495     `(progn
496     (,(closintern 'defmethod) ,predicate (object)
497     (declare (ignore object))
498     nil)
499     (,(closintern 'defmethod) ,predicate ((object ,name))
500     t))
501     #-allegro
502     `(defun ,predicate (object)
503     (typep object ',name)))
504     ,(when copier
505     `(,(closintern 'defmethod) ,copier ((.object. ,name))
506     (,(closintern 'with-slots) ,slot-names .object.
507     (,(closintern 'make-instance) ',name
508     ,@(mapcan #'(lambda (slot-name)
509     `(,(kintern slot-name) ,slot-name))
510     slot-names)))))
511     ,(when print-function
512     `(,(closintern 'defmethod)
513     ,(closintern 'print-object)
514     ((object ,name) stream)
515     (,print-function object stream 0))))))))
516     `(within-definition (,name def-clx-class)
517     (defstruct (,name ,@options)
518     ,@slots))))
519 ram 1.1
520     #+Genera
521     (progn
522     (scl:defprop def-clx-class "CLX Class" si:definition-type-name)
523     (scl:defprop def-clx-class zwei:defselect-function-spec-finder
524     zwei:definition-function-spec-finder))
525    
526    
527     ;; We need this here so we can define DISPLAY for CLX.
528     ;;
529     ;; This structure is :INCLUDEd in the DISPLAY structure.
530     ;; Overlapping (displaced) arrays are provided for byte
531     ;; half-word and word access on both input and output.
532     ;;
533     (def-clx-class (buffer (:constructor nil) (:copier nil) (:predicate nil))
534     ;; Lock for multi-processing systems
535     (lock (make-process-lock "CLX Buffer Lock"))
536     #-excl (output-stream nil :type (or null stream))
537     #+excl (output-stream -1 :type fixnum)
538     ;; Buffer size
539     (size 0 :type array-index)
540     (request-number 0 :type (unsigned-byte 16))
541     ;; Byte position of start of last request
542     ;; used for appending requests and error recovery
543     (last-request nil :type (or null array-index))
544     ;; Byte position of start of last flushed request
545     (last-flushed-request nil :type (or null array-index))
546     ;; Current byte offset
547     (boffset 0 :type array-index)
548     ;; Byte (8 bit) output buffer
549     (obuf8 *empty-bytes* :type buffer-bytes)
550     ;; Word (16bit) output buffer
551     #+clx-overlapping-arrays
552     (obuf16 *empty-words* :type buffer-words)
553     ;; Long (32bit) output buffer
554     #+clx-overlapping-arrays
555     (obuf32 *empty-longs* :type buffer-longs)
556     ;; Holding buffer for 16-bit text
557     (tbuf16 (make-sequence 'buffer-text16 *buffer-text16-size* :initial-element 0))
558     ;; Probably EQ to Output-Stream
559     #-excl (input-stream nil :type (or null stream))
560     #+excl (input-stream -1 :type fixnum)
561     ;; T when the host connection has gotten errors
562     (dead nil :type (or null (not null)))
563     ;; T makes buffer-flush a noop. Manipulated with with-buffer-flush-inhibited.
564     (flush-inhibit nil :type (or null (not null)))
565    
566     ;; Change these functions when using shared memory buffers to the server
567     ;; Function to call when writing the buffer
568     (write-function 'buffer-write-default)
569     ;; Function to call when flushing the buffer
570     (force-output-function 'buffer-force-output-default)
571     ;; Function to call when closing a connection
572     (close-function 'buffer-close-default)
573     ;; Function to call when reading the buffer
574     (input-function 'buffer-read-default)
575     ;; Function to call to wait for data to be input
576     (input-wait-function 'buffer-input-wait-default)
577     ;; Function to call to listen for input data
578     (listen-function 'buffer-listen-default)
579    
580     #+Genera (debug-io nil :type (or null stream))
581     )
582    
583     ;;-----------------------------------------------------------------------------
584     ;; Printing routines.
585     ;;-----------------------------------------------------------------------------
586    
587 ram 1.2 #-(or clx-ansi-common-lisp Genera)
588 ram 1.1 (defun print-unreadable-object-function (object stream type identity function)
589 ram 1.2 (declare #+lispm
590     (sys:downward-funarg function))
591 ram 1.1 (princ "#<" stream)
592     (when type
593     (let ((type (type-of object))
594 ram 1.2 (pcl-package (find-package :pcl)))
595 ram 1.1 ;; Handle pcl type-of lossage
596     (when (and pcl-package
597     (symbolp type)
598     (eq (symbol-package type) pcl-package)
599     (string-equal (symbol-name type) "STD-INSTANCE"))
600     (setq type
601     (funcall (intern (symbol-name 'class-name) pcl-package)
602     (funcall (intern (symbol-name 'class-of) pcl-package)
603     object))))
604     (prin1 type stream)))
605     (when (and type function) (princ " " stream))
606     (when function (funcall function))
607     (when (and (or type function) identity) (princ " " stream))
608     (when identity (princ "???" stream))
609     (princ ">" stream)
610     nil)
611    
612 ram 1.2 #-(or clx-ansi-common-lisp Genera)
613 ram 1.1 (defmacro print-unreadable-object
614     ((object stream &key type identity) &body body)
615 ram 1.2 (if body
616     `(flet ((.print-unreadable-object-body. () ,@body))
617     (print-unreadable-object-function
618     ,object ,stream ,type ,identity #'.print-unreadable-object-body.))
619     `(print-unreadable-object-function ,object ,stream ,type ,identity nil)))
620 ram 1.1
621    
622     ;;-----------------------------------------------------------------------------
623     ;; Image stuff
624     ;;-----------------------------------------------------------------------------
625    
626     (defconstant *image-bit-lsb-first-p*
627     #+clx-little-endian t
628     #-clx-little-endian nil)
629    
630     (defconstant *image-byte-lsb-first-p*
631     #+clx-little-endian t
632     #-clx-little-endian nil)
633    
634     (defconstant *image-unit* 32)
635    
636     (defconstant *image-pad* 32)
637 ram 1.2
638    
639     ;;-----------------------------------------------------------------------------
640     ;; Foreign Functions
641     ;;-----------------------------------------------------------------------------
642    
643     #+(and lucid apollo (not lcl3.0))
644     (lucid::define-foreign-function '(connect-to-server "connect_to_server")
645     '((:val host :string)
646     (:val display :integer32))
647     :integer32)
648    
649     #+(and lucid (not apollo) (not lcl3.0))
650     (lucid::define-c-function connect-to-server (host display)
651     :result-type :integer)
652    
653     #+lcl3.0
654     (lucid::def-foreign-function
655     (connect-to-server
656     (:language :c)
657     (:return-type :signed-32bit))
658     (host :simple-string)
659     (display :signed-32bit))

  ViewVC Help
Powered by ViewVC 1.1.5