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

Contents of /src/clx/depdefs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5