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

Diff of /src/clx/depdefs.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1.1.4 by ram, Tue May 21 18:38:06 1991 UTC revision 1.9 by rtoy, Wed Jun 17 18:22:46 2009 UTC
# Line 1  Line 1 
1  ;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*-  ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
2    
3  ;; This file contains some of the system dependent code for CLX  ;; This file contains some of the system dependent code for CLX
4    
# Line 18  Line 18 
18  ;;; express or implied warranty.  ;;; express or implied warranty.
19  ;;;  ;;;
20    
21    #+cmu
22    (ext:file-comment "$Id$")
23    
24  (in-package :xlib)  (in-package :xlib)
25    
26  ;;;-------------------------------------------------------------------------  ;;;-------------------------------------------------------------------------
# Line 28  Line 31 
31  ;;;   redefine both the function and the type.  ;;;   redefine both the function and the type.
32    
33  #+(or kcl ibcl)  #+(or kcl ibcl)
 (shadow 'rational)  
   
 #+(or kcl ibcl)  
34  (progn  (progn
35    (defun rational (x)    (defun rational (x)
36      (if (rationalp x)      (if (rationalp x)
37          x          x
38          (lisp:rational x)))          (lisp:rational x)))
39    (deftype rational () 'lisp:rational))    (deftype rational (&optional l u) `(lisp:rational ,l ,u)))
40    
41  ;;; DECLAIM  ;;; DECLAIM
42    
43  #-ansi-common-lisp  #-clx-ansi-common-lisp
44  (defmacro declaim (&rest decl-specs)  (defmacro declaim (&rest decl-specs)
45    (if (cdr decl-specs)    (if (cdr decl-specs)
46        `(progn        `(progn
# Line 48  Line 48 
48                     decl-specs))                     decl-specs))
49      `(proclaim ',(car decl-specs))))      `(proclaim ',(car decl-specs))))
50    
51  ;;; VALUES value1 value2 ... -- Documents the values returned by the function.  ;;; CLX-VALUES value1 value2 ... -- Documents the values returned by the function.
52    
53  #-lispm  #-Genera
54  (declaim (declaration values))  (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  ;;; ARGLIST arg1 arg2 ... -- Documents the arglist of the function.  Overrides
60  ;;; the documentation that might get generated by the real arglist of the  ;;; the documentation that might get generated by the real arglist of the
61  ;;; function.  ;;; function.
62    
 #+lispm  
 (import '(sys:arglist))  
   
 #+lcl3.0  
 (import '(lcl:arglist))  
   
63  #-(or lispm lcl3.0)  #-(or lispm lcl3.0)
64  (declaim (declaration arglist))  (declaim (declaration arglist))
65    
 ;;; DOWNWARD-FUNARG name1 name2 ... -- Tells callers of this function that  
 ;;; closures passed in as the argument named by name can be consed on the  
 ;;; stack, as they have dynamic extent.  In Genera keyword args can't be named  
 ;;; this way.  Instead use * to specify all functional args have dynamic  
 ;;; extent.  
   
 #+lispm  
 (import '(sys:downward-funarg))  
   
 #-lispm  
 (declaim (declaration downward-funarg))  
   
66  ;;; DYNAMIC-EXTENT var -- Tells the compiler that the rest arg var has  ;;; 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  ;;; 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.  ;;; the heap, even though the value is passed out of the function.
69    
70  #+lcl3.0  #-(or clx-ansi-common-lisp lcl3.0)
 (import '(lcl:dynamic-extent))  
   
 #-(or ansi-common-lisp lcl3.0)  
71  (declaim (declaration dynamic-extent))  (declaim (declaration dynamic-extent))
72    
73  ;;; ARRAY-REGISTER var1 var2 ... -- The variables mentioned are locals (not  ;;; IGNORABLE var -- Tells the compiler that the variable might or might not be used.
 ;;; args) that hold vectors.  
74    
75  #+Genera  #-clx-ansi-common-lisp
76  (import '(sys:array-register))  (declaim (declaration ignorable))
   
 #-Genera  
 (declaim (declaration array-register))  
77    
78  ;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to  ;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to
79  ;;; indent calls to the function or macro containing the declaration.  ;;; indent calls to the function or macro containing the declaration.
80    
 #+genera  
 (import '(zwei:indentation))  
   
81  #-genera  #-genera
82  (declaim (declaration indentation))  (declaim (declaration indentation))
83    
# Line 114  Line 89 
89  ;;; and then does a type declaration and array register declaration  ;;; and then does a type declaration and array register declaration
90  (defmacro with-vector ((var type) &body body)  (defmacro with-vector ((var type) &body body)
91    `(let ((,var ,var))    `(let ((,var ,var))
92       (declare (type ,type ,var)       (declare (type ,type ,var))
               (array-register ,var))  
93       ,@body))       ,@body))
94    
95  ;;; WITHIN-DEFINITION (name type) &body body --- Includes definitions for  ;;; WITHIN-DEFINITION (name type) &body body --- Includes definitions for
# Line 146  Line 120 
120  ;;; useful for much beyond xatoms and windows (since almost nothing else  ;;; useful for much beyond xatoms and windows (since almost nothing else
121  ;;; ever comes back in events).  ;;; ever comes back in events).
122  ;;;--------------------------------------------------------------------------  ;;;--------------------------------------------------------------------------
123  (defconstant *clx-cached-types*  (defconstant +clx-cached-types+
124               '( drawable   '(drawable
125                  window     window
126                  pixmap     pixmap
127  ;               gcontext     ;;           gcontext
128                  cursor     cursor
129                  colormap     colormap
130                  font))     font))
131    
132  (defmacro resource-id-map-test ()  (defmacro resource-id-map-test ()
133    #+excl '#'equal    #+excl '#'equal
134    #-excl '#'eql)                    ; (eq fixnum fixnum) is not guaranteed.    #-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 ()  (defmacro keysym->character-map-test ()
141    #+excl '#'equal    #+excl '#'equal
# Line 166  Line 144 
144  ;;; You must define this to match the real byte order.  It is used by  ;;; You must define this to match the real byte order.  It is used by
145  ;;; overlapping array and image code.  ;;; overlapping array and image code.
146    
147  #+(or lispm vax little-endian)  #+(or lispm vax little-endian Minima)
148  (eval-when (eval compile load)  (eval-when (eval compile load)
149    (pushnew :clx-little-endian *features*))    (pushnew :clx-little-endian *features*))
150    
151  #+lcl3.0  #+lcl3.0
152  (eval-when (compile eval load)  (eval-when (compile eval load)
153    (ecase lucid::machine-endian    (ecase lucid::machine-endian
154      (:big)      (:big nil)
155      (:little (pushnew :clx-little-endian *features*))))      (:little (pushnew :clx-little-endian *features*))))
156    
157  #+cmu  #+cmu
# Line 182  Line 160 
160      (:big-endian)      (:big-endian)
161      (:little-endian (pushnew :clx-little-endian *features*))))      (:little-endian (pushnew :clx-little-endian *features*))))
162    
163    #+sbcl
164    (eval-when (:compile-toplevel :load-toplevel :execute)
165      ;; FIXME: Ideally, we shouldn't end up with the internal
166      ;; :CLX-LITTLE-ENDIAN decorating user-visible *FEATURES* lists.
167      ;; This probably wants to be split up into :compile-toplevel
168      ;; :execute and :load-toplevel clauses, so that loading the compiled
169      ;; code doesn't push the feature.
170      (ecase sb-c:*backend-byte-order*
171        (:big-endian)
172        (:little-endian (pushnew :clx-little-endian *features*))))
173    
174  ;;; Steele's Common-Lisp states:  "It is an error if the array specified  ;;; Steele's Common-Lisp states:  "It is an error if the array specified
175  ;;; as the :displaced-to argument  does not have the same :element-type  ;;; as the :displaced-to argument  does not have the same :element-type
# Line 192  Line 180 
180  ;;; this to do fast array packing/unpacking when the overlapping-arrays  ;;; this to do fast array packing/unpacking when the overlapping-arrays
181  ;;; feature is enabled.  ;;; feature is enabled.
182    
183    #+clisp
184    (eval-when (:compile-toplevel :load-toplevel :execute)
185      (unless system::*big-endian* (pushnew :clx-little-endian *features*)))
186    
187  #+(and clx-little-endian lispm)  #+(and clx-little-endian lispm)
188  (eval-when (eval compile load)  (eval-when (eval compile load)
189    (pushnew :clx-overlapping-arrays *features*))    (pushnew :clx-overlapping-arrays *features*))
# Line 313  Line 305 
305  (defmacro index-max (&rest numbers) `(max ,@numbers))  (defmacro index-max (&rest numbers) `(max ,@numbers))
306    
307  (defun positive-power-of-two-p (x)  (defun positive-power-of-two-p (x)
308      (when (symbolp x)
309        (multiple-value-bind (constantp value) (lt:named-constant-p x)
310          (when constantp (setq x value))))
311    (and (typep x 'fixnum) (plusp x) (zerop (logand x (1- x)))))    (and (typep x 'fixnum) (plusp x) (zerop (logand x (1- x)))))
312    
313  (defmacro index-floor (number divisor)  (defmacro index-floor (number divisor)
# Line 361  Line 356 
356    
357  ;;;; Stuff for BUFFER definition  ;;;; Stuff for BUFFER definition
358    
359  (defconstant *replysize* 32.)  (defconstant +replysize+ 32.)
360    
361  ;; used in defstruct initializations to avoid compiler warnings  ;; used in defstruct initializations to avoid compiler warnings
362  (defvar *empty-bytes* (make-sequence 'buffer-bytes 0))  (defvar *empty-bytes* (make-sequence 'buffer-bytes 0))
# Line 392  Line 387 
387    (data-size 0 :type array-index)    (data-size 0 :type array-index)
388    )    )
389    
390  (defconstant *buffer-text16-size* 256)  (defconstant +buffer-text16-size+ 256)
391  (deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,*buffer-text16-size*)))  (deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,+buffer-text16-size+)))
392    
393  ;; These are here because.  ;; These are here because.
394    
395  (defparameter *xlib-package* (find-package 'xlib))  (defparameter *xlib-package* (find-package :xlib))
396    
397  (defun xintern (&rest parts)  (defun xintern (&rest parts)
398    (intern (apply #'concatenate 'string (mapcar #'string parts)) *xlib-package*))    (intern (apply #'concatenate 'string (mapcar #'string parts)) *xlib-package*))
399    
400  (defparameter *keyword-package* (find-package 'keyword))  (defparameter *keyword-package* (find-package :keyword))
401    
402  (defun kintern (name)  (defun kintern (name)
403    (intern (string name) *keyword-package*))    (intern (string name) *keyword-package*))
404    
405  ;;; Pseudo-class mechanism.  ;;; Pseudo-class mechanism.
406    
407    (eval-when (:compile-toplevel :load-toplevel :execute)
408      ;; FIXME: maybe we should reevaluate this?
409      (defvar *def-clx-class-use-defclass*
410        #+(or Genera allegro) t
411        #+(and cmu pcl) '(XLIB:DRAWABLE XLIB:WINDOW XLIB:PIXMAP)
412        #+(and cmu (not pcl)) nil
413        #-(or Genera cmu allegro) nil
414        "Controls whether DEF-CLX-CLASS uses DEFCLASS.
415    
416    If it is a list, it is interpreted by DEF-CLX-CLASS to be a list of
417    type names for which DEFCLASS should be used.  If it is not a list,
418    then DEFCLASS is always used.  If it is NIL, then DEFCLASS is never
419    used, since NIL is the empty list.")
420      )
421    
422  (defmacro def-clx-class ((name &rest options) &body slots)  (defmacro def-clx-class ((name &rest options) &body slots)
423    (let ((clos-package (or (find-package 'clos)    (if (or (not (listp *def-clx-class-use-defclass*))
424                            (find-package 'pcl)            (member name *def-clx-class-use-defclass*))
425                            (let ((lisp-pkg (find-package 'lisp)))        (let ((clos-package #+clx-ansi-common-lisp
426                              (and (find-symbol (string 'defclass) lisp-pkg)                            (find-package :common-lisp)
427                                   lisp-pkg)))))                            #-clx-ansi-common-lisp
428      (if clos-package                            (or (find-package :clos)
429          (let ((constructor t)                                (find-package :pcl)
430                (constructor-args t)                                (let ((lisp-pkg (find-package :lisp)))
431                (include nil)                                  (and (find-symbol (string 'defclass) lisp-pkg)
432                (print-function nil)                                       lisp-pkg))))
433                (copier t)              (constructor t)
434                (predicate t))              (constructor-args t)
435            (dolist (option options)              (include nil)
436              (ecase (pop option)              (print-function nil)
437                (:constructor              (copier t)
438                  (setf constructor (pop option))              (predicate t))
439                  (setf constructor-args (if (null option) t (pop option))))          (dolist (option options)
440                (:include            (ecase (pop option)
441                  (setf include (pop option)))              (:constructor
442                (:print-function                (setf constructor (pop option))
443                  (setf print-function (pop option)))                (setf constructor-args (if (null option) t (pop option))))
444                (:copier              (:include
445                  (setf copier (pop option)))                (setf include (pop option)))
446                (:predicate              (:print-function
447                  (setf predicate (pop option)))))                (setf print-function (pop option)))
448            (flet ((cintern (&rest symbols)              (:copier
449                     (intern (apply #'concatenate 'simple-string                (setf copier (pop option)))
450                                    (mapcar #'symbol-name symbols))              (:predicate
451                             *package*))                (setf predicate (pop option)))))
452                   (kintern (symbol)          (flet ((cintern (&rest symbols)
453                     (intern (symbol-name symbol) (find-package 'keyword)))                   (intern (apply #'concatenate 'simple-string
454                   (closintern (symbol)                                  (mapcar #'symbol-name symbols))
455                     (intern (symbol-name symbol) clos-package)))                           *package*))
456              (when (eq constructor t)                 (kintern (symbol)
457                (setf constructor (cintern 'make- name)))                          (intern (symbol-name symbol) (find-package :keyword)))
458              (when (eq copier t)                 (closintern (symbol)
459                (setf copier (cintern 'copy- name)))                   (intern (symbol-name symbol) clos-package)))
460              (when (eq predicate t)            (when (eq constructor t)
461                (setf predicate (cintern name '-p)))              (setf constructor (cintern 'make- name)))
462              (when include            (when (eq copier t)
463                (setf slots (append (get include 'def-clx-class) slots)))              (setf copier (cintern 'copy- name)))
464              (let* ((n-slots (length slots))            (when (eq predicate t)
465                     (slot-names (make-list n-slots))              (setf predicate (cintern name '-p)))
466                     (slot-initforms (make-list n-slots))            (when include
467                     (slot-types (make-list n-slots)))              (setf slots (append (get include 'def-clx-class) slots)))
468                (dotimes (i n-slots)            (let* ((n-slots (length slots))
469                  (let ((slot (elt slots i)))                   (slot-names (make-list n-slots))
470                    (setf (elt slot-names i) (pop slot))                   (slot-initforms (make-list n-slots))
471                    (setf (elt slot-initforms i) (pop slot))                   (slot-types (make-list n-slots)))
472                    (setf (elt slot-types i) (getf slot :type t))))              (dotimes (i n-slots)
473                `(progn                (let ((slot (elt slots i)))
474                    (setf (elt slot-names i) (pop slot))
475                   (eval-when (compile load eval)                  (setf (elt slot-initforms i) (pop slot))
476                     (setf (get ',name 'def-clx-class) ',slots))                  (setf (elt slot-types i) (getf slot :type t))))
477                `(progn
478                   ;; From here down are the system-specific expansions:  
479                   (eval-when (:compile-toplevel :load-toplevel :execute)
480                   ,(cond (clos-package                   (setf (get ',name 'def-clx-class) ',slots))
481                           `(within-definition (,name def-clx-class)  
482                              (,(closintern 'defclass)                 ;; From here down are the system-specific expansions:
483                               ,name ,(and include `(,include))  
484                               (,@(map 'list                 (within-definition (,name def-clx-class)
485                                       #'(lambda (slot-name slot-initform slot-type)                   (,(closintern 'defclass)
486                                           `(,slot-name                    ,name ,(and include `(,include))
487                                             :initform ,slot-initform :type ,slot-type                    (,@(map 'list
488                                             :accessor ,(cintern name '- slot-name)                            #'(lambda (slot-name slot-initform slot-type)
489                                             ,@(when (and constructor                                `(,slot-name
490                                                          (or (eq constructor-args t)                                  :initform ,slot-initform :type ,slot-type
491                                                              (member slot-name                                  :accessor ,(cintern name '- slot-name)
492                                                                      constructor-args)))                                  ,@(when (and constructor
493                                                 `(:initarg ,(kintern slot-name)))                                               (or (eq constructor-args t)
494                                             ))                                                   (member slot-name
495                                       slot-names slot-initforms slot-types)))                                                           constructor-args)))
496                              ,(when constructor                                      `(:initarg ,(kintern slot-name)))
497                                 (if (eq constructor-args t)                                  ))
498                                     `(defun ,constructor (&rest args)                            slot-names slot-initforms slot-types)))
499                                        (apply #',(closintern 'make-instance)                   ,(when constructor
500                                               ',name args))                      (if (eq constructor-args t)
501                                     `(defun ,constructor ,constructor-args                          `(defun ,constructor (&rest args)
502                                        (,(closintern 'make-instance) ',name                             (apply #',(closintern 'make-instance)
503                                         ,@(mapcan #'(lambda (slot-name)                                    ',name args))
504                                                       (and (member slot-name slot-names)                          `(defun ,constructor ,constructor-args
505                                                            `(,(kintern slot-name) ,slot-name)))                             (,(closintern 'make-instance) ',name
506                                                   constructor-args)))))                              ,@(mapcan #'(lambda (slot-name)
507                              ,(when predicate                                            (and (member slot-name slot-names)
508                                 `(defun ,predicate (object)                                                 `(,(kintern slot-name) ,slot-name)))
509                                    (typep object ',name)))                                        constructor-args)))))
510                              ,(when copier                   ,(when predicate
511                                 `(,(closintern 'defmethod) ,copier ((.object. ,name))                      #+allegro
512                                   (,(closintern 'with-slots) ,slot-names .object.                      `(progn
513                                    (,(closintern 'make-instance) ',name                         (,(closintern 'defmethod) ,predicate (object)
514                                     ,@(mapcan #'(lambda (slot-name)                           (declare (ignore object))
515                                                   `(,(kintern slot-name) ,slot-name))                           nil)
516                                               slot-names)))))                         (,(closintern 'defmethod) ,predicate ((object ,name))
517                              ,(when print-function                           t))
518                                 `(,(closintern 'defmethod)                      #-allegro
519                                   ,(closintern 'print-object)                      `(defun ,predicate (object)
520                                   ((object ,name) stream)                         (typep object ',name)))
521                                   (,print-function object stream 0)))))                   ,(when copier
522                        `(,(closintern 'defmethod) ,copier ((.object. ,name))
523                          #+Genera                        (,(closintern 'with-slots) ,slot-names .object.
524                          (t                         (,(closintern 'make-instance) ',name
525                           `(within-definition (,name def-clx-class)                          ,@(mapcan #'(lambda (slot-name)
526                              (flavor:defflavor ,name                                        `(,(kintern slot-name) ,slot-name))
527                                      (,@(map 'list                                    slot-names)))))
528                                              #'(lambda (slot-name slot-initform)                   ,(when print-function
529                                                  `(,slot-name ,slot-initform))                      `(,(closintern 'defmethod)
530                                              slot-names slot-initforms))                        ,(closintern 'print-object)
531                                      ,(and include `(,include))                        ((object ,name) stream)
532                                :initable-instance-variables                        (,print-function object stream 0))))))))
533                                :locatable-instance-variables        `(within-definition (,name def-clx-class)
534                                :readable-instance-variables           (defstruct (,name ,@options)
535                                :writable-instance-variables             ,@slots))))
                               ,(if constructor  
                                    `(:constructor ,constructor  
                                      ,(if (eq constructor-args t)  
                                           `(&key ,@slot-names)  
                                           constructor-args))  
                                    :abstract-flavor))  
                             ,(when predicate  
                                `(defun ,predicate (object)  
                                   (typep object ',name)))  
                             ,(when copier  
                                (error ":COPIER not supported."))  
                             ,(when print-function  
                                `(flavor:defmethod (sys:print-self ,name)  
                                                   (stream depth *print-escape*)  
                                   (,print-function sys:self stream depth)))  
                             (flavor:compile-flavor-methods ,name))))))))  
         `(within-definition (,name def-clx-class)  
            (defstruct (,name ,@options)  
              ,@slots)))))  
536    
537  #+Genera  #+Genera
538  (progn  (progn
# Line 559  Line 550 
550  (def-clx-class (buffer (:constructor nil) (:copier nil) (:predicate nil))  (def-clx-class (buffer (:constructor nil) (:copier nil) (:predicate nil))
551    ;; Lock for multi-processing systems    ;; Lock for multi-processing systems
552    (lock (make-process-lock "CLX Buffer Lock"))    (lock (make-process-lock "CLX Buffer Lock"))
553    #-(or excl) (output-stream nil :type (or null stream))    #-excl (output-stream nil :type (or null stream))
554    #+(or excl) (output-stream nil :type (or null fixnum))    #+excl (output-stream -1 :type fixnum)
555    ;; Buffer size    ;; Buffer size
556    (size 0 :type array-index)    (size 0 :type array-index)
557    (request-number 0 :type (unsigned-byte 16))    (request-number 0 :type (unsigned-byte 16))
# Line 580  Line 571 
571    #+clx-overlapping-arrays    #+clx-overlapping-arrays
572    (obuf32 *empty-longs* :type buffer-longs)    (obuf32 *empty-longs* :type buffer-longs)
573    ;; Holding buffer for 16-bit text    ;; Holding buffer for 16-bit text
574    (tbuf16 (make-sequence 'buffer-text16 *buffer-text16-size* :initial-element 0))    (tbuf16 (make-sequence 'buffer-text16 +buffer-text16-size+ :initial-element 0))
575    ;; Probably EQ to Output-Stream    ;; Probably EQ to Output-Stream
576    #-(or excl) (input-stream nil :type (or null stream))    #-excl (input-stream nil :type (or null stream))
577    #+(or excl) (input-stream nil :type (or null fixnum))    #+excl (input-stream -1 :type fixnum)
578    ;; T when the host connection has gotten errors    ;; T when the host connection has gotten errors
579    (dead nil :type (or null (not null)))    (dead nil :type (or null (not null)))
580    ;; T makes buffer-flush a noop.  Manipulated with with-buffer-flush-inhibited.    ;; T makes buffer-flush a noop.  Manipulated with with-buffer-flush-inhibited.
# Line 610  Line 601 
601  ;; Printing routines.  ;; Printing routines.
602  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
603    
604  #+(and (not ansi-common-lisp) Genera)  #-(or clx-ansi-common-lisp Genera)
 (import 'future-common-lisp:print-unreadable-object)  
   
 #-(or ansi-common-lisp Genera)  
605  (defun print-unreadable-object-function (object stream type identity function)  (defun print-unreadable-object-function (object stream type identity function)
606      (declare #+lispm
607               (sys:downward-funarg function))
608    (princ "#<" stream)    (princ "#<" stream)
609    (when type    (when type
610      (let ((type (type-of object))      (let ((type (type-of object))
611            (pcl-package (find-package 'pcl)))            (pcl-package (find-package :pcl)))
612        ;; Handle pcl type-of lossage        ;; Handle pcl type-of lossage
613        (when (and pcl-package        (when (and pcl-package
614                   (symbolp type)                   (symbolp type)
# Line 636  Line 626 
626    (princ ">" stream)    (princ ">" stream)
627    nil)    nil)
628    
629  #-(or ansi-common-lisp Genera)  #-(or clx-ansi-common-lisp Genera)
630  (defmacro print-unreadable-object  (defmacro print-unreadable-object
631            ((object stream &key type identity) &body body)            ((object stream &key type identity) &body body)
632    `(print-unreadable-object-function    (if body
633       ,object ,stream ,type ,identity        `(flet ((.print-unreadable-object-body. () ,@body))
634       ,(and body `#'(lambda () ,@body))))           (print-unreadable-object-function
635               ,object ,stream ,type ,identity #'.print-unreadable-object-body.))
636        `(print-unreadable-object-function ,object ,stream ,type ,identity nil)))
637    
638    
639  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
640  ;; Image stuff  ;; Image stuff
641  ;;-----------------------------------------------------------------------------  ;;-----------------------------------------------------------------------------
642    
643  (defconstant *image-bit-lsb-first-p*  (defconstant +image-bit-lsb-first-p+
644               #+clx-little-endian t               #+clx-little-endian t
645               #-clx-little-endian nil)               #-clx-little-endian nil)
646    
647  (defconstant *image-byte-lsb-first-p*  (defconstant +image-byte-lsb-first-p+
648               #+clx-little-endian t               #+clx-little-endian t
649               #-clx-little-endian nil)               #-clx-little-endian nil)
650    
651  (defconstant *image-unit* 32)  (defconstant +image-unit+ 32)
652    
653    (defconstant +image-pad+ 32)
654    
655    
656    ;;-----------------------------------------------------------------------------
657    ;; Foreign Functions
658    ;;-----------------------------------------------------------------------------
659    
660    #+(and lucid apollo (not lcl3.0))
661    (lucid::define-foreign-function '(connect-to-server "connect_to_server")
662      '((:val host    :string)
663        (:val display :integer32))
664      :integer32)
665    
666    #+(and lucid (not apollo) (not lcl3.0))
667    (lucid::define-c-function connect-to-server (host display)
668      :result-type :integer)
669    
670    #+lcl3.0
671    (lucid::def-foreign-function
672        (connect-to-server
673          (:language :c)
674          (:return-type :signed-32bit))
675      (host :simple-string)
676      (display :signed-32bit))
677    
678    
679    ;;-----------------------------------------------------------------------------
680    ;; Finding the server socket
681    ;;-----------------------------------------------------------------------------
682    
683  (defconstant *image-pad* 32)  ;; These are here because dep-openmcl.lisp and dependent.lisp both need them
684    (defconstant +X-unix-socket-path+
685      "/tmp/.X11-unix/X"
686      "The location of the X socket")
687    
688    (defun unix-socket-path-from-host (host display)
689      "Return the name of the unix domain socket for host and display, or
690    nil if a network socket should be opened."
691      (cond ((or (string= host "") (string= host "unix"))
692             (format nil "~A~D" +X-unix-socket-path+ display))
693            #+darwin
694            ((and (> (length host) 10) (string= host "tmp/launch" :end1 10))
695             (format nil "/~A:~D" host display))
696            (t nil)))

Legend:
Removed from v.1.1.1.4  
changed lines
  Added in v.1.9

  ViewVC Help
Powered by ViewVC 1.1.5