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

Contents of /src/clx/depdefs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5