/[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.1 - (hide annotations) (vendor branch)
Mon May 14 14:59:19 1990 UTC (23 years, 11 months ago) by ram
Changes since 1.1: +10 -1 lines
.../systems-work/nnclx/depdefs.lisp, 12-May-90 14:27:05, Edit by Chiles.
  Added internal-buffer slots to buffer structure for use by
  READ-BUFFER-DEFAULT.

  Modified file options.
1 ram 1.1.1.1 ;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*-
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     (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     #-excl (output-stream nil :type (or null stream))
556     #+excl (output-stream -1 :type 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     #-excl (input-stream nil :type (or null stream))
579     #+excl (input-stream -1 :type 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 ram 1.1.1.1 ;;
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 ram 1.1
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