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

Contents of /src/clx/depdefs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5