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

Contents of /src/clx/depdefs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5