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

Diff of /src/clx/clx.lisp

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

revision 1.1 by ram, Mon May 14 14:47:47 1990 UTC revision 1.2 by ram, Thu Nov 7 16:57:16 1991 UTC
# Line 80  Line 80 
80    
81  (in-package :xlib)  (in-package :xlib)
82    
 (export '(  
           *version*  
           card32  
           card29  
           int32  
           card16  
           int16  
           card8  
           int8  
           rgb-val  
           angle  
           mask32  
           mask16  
           array-index  
           pixel  
           image-depth  
           display  
           display-p  
           display-host  
           display-display  
           display-after-function  
           display-protocol-major-version  
           display-protocol-minor-version  
           display-vendor-name  
           display-resource-id-base  
           display-resource-id-mask  
           display-xid  
           display-byte-order  
           display-release-number  
           display-max-request-length  
           display-default-screen  
           display-nscreens  
           display-roots  
           display-motion-buffer-size  
           display-xdefaults  
           display-image-lsb-first-p  
           display-bitmap-format  
           display-pixmap-formats  
           display-min-keycode  
           display-max-keycode  
           display-error-handler  
           display-authorization-name  
           display-authorization-data  
           display-plist  
           display-report-asynchronous-errors  
           color  
           color-p  
           color-red  
           color-green  
           color-blue  
           make-color  
           color-rgb  
           resource-id  
           drawable  
           drawable-p  
           drawable-equal  
           drawable-id  
           drawable-display  
           drawable-plist  
           window  
           window-p  
           window-equal  
           window-id  
           window-display  
           window-plist  
           pixmap  
           pixmap-p  
           pixmap-equal  
           pixmap-id  
           pixmap-display  
           pixmap-plist  
           colormap  
           colormap-p  
           colormap-equal  
           colormap-id  
           colormap-display  
           colormap-visual-info  
           cursor  
           cursor-p  
           cursor-equal  
           cursor-id  
           cursor-display  
           xatom  
           stringable  
           fontable  
           timestamp  
           bit-gravity  
           win-gravity  
           grab-status  
           boolean  
           alist  
           repeat-seq  
           point-seq  
           seg-seq  
           rect-seq  
           arc-seq  
           gcontext  
           gcontext-p  
           gcontext-equal  
           gcontext-id  
           gcontext-display  
           gcontext-plist  
           event-mask-class  
           event-mask  
           pointer-event-mask-class  
           pointer-event-mask  
           device-event-mask-class  
           device-event-mask  
           modifier-key  
           modifier-mask  
           state-mask-key  
           gcontext-key  
           event-key  
           error-key  
           draw-direction  
           boole-constant  
           bitmap-format  
           bitmap-format-p  
           bitmap-format-unit  
           bitmap-format-pad  
           bitmap-format-lsb-first-p  
           pixmap-format  
           pixmap-format-p  
           pixmap-format-depth  
           pixmap-format-bits-per-pixel  
           pixmap-format-scanline-pad  
           visual-info  
           visual-info-p  
           visual-info-id  
           visual-info-display  
           visual-info-class  
           visual-info-red-mask  
           visual-info-green-mask  
           visual-info-blue-mask  
           visual-info-bits-per-rgb  
           visual-info-colormap-entries  
           visual-info-plist  
           screen  
           screen-p  
           screen-root  
           screen-width  
           screen-height  
           screen-width-in-millimeters  
           screen-height-in-millimeters  
           screen-depths  
           screen-root-depth  
           screen-root-visual-info  
           screen-root-visual  
           screen-default-colormap  
           screen-white-pixel  
           screen-black-pixel  
           screen-min-installed-maps  
           screen-max-installed-maps  
           screen-backing-stores  
           screen-save-unders-p  
           screen-event-mask-at-open  
           screen-plist  
           font  
           font-p  
           font-equal  
           font-id  
           font-display  
           font-name  
           font-direction  
           font-min-char  
           font-max-char  
           font-min-byte1  
           font-max-byte1  
           font-min-byte2  
           font-max-byte2  
           font-all-chars-exist-p  
           font-default-char  
           font-ascent  
           font-descent  
           font-properties  
           font-property  
           font-plist  
           char-left-bearing  
           max-char-left-bearing  
           min-char-left-bearing  
           char-right-bearing  
           max-char-right-bearing  
           min-char-right-bearing  
           char-width  
           max-char-width  
           min-char-width  
           char-ascent  
           max-char-ascent  
           min-char-ascent  
           char-descent  
           max-char-descent  
           min-char-descent  
           char-attributes  
           max-char-attributes  
           min-char-attributes  
           make-event-mask  
           make-event-keys  
           make-state-mask  
           make-state-keys  
           ))  
   
83  (pushnew :clx *features*)  (pushnew :clx *features*)
84  (pushnew :xlib *features*)  (pushnew :xlib *features*)
85    
86  (defparameter *version* "MIT R4.2")  (defparameter *version* "MIT R5.0")
87  (pushnew :clx-mit-r4 *features*)  (pushnew :clx-mit-r4 *features*)
88    (pushnew :clx-mit-r5 *features*)
89    
90  (defparameter *protocol-major-version* 11.)  (defparameter *protocol-major-version* 11.)
91  (defparameter *protocol-minor-version* 0)  (defparameter *protocol-minor-version* 0)
# Line 361  Line 161 
161    
162  (deftype card4 () '(unsigned-byte 4))  (deftype card4 () '(unsigned-byte 4))
163    
164    #-clx-ansi-common-lisp
165  (deftype real (&optional (min '*) (max '*))  (deftype real (&optional (min '*) (max '*))
166    (labels ((convert (limit floatp)    (labels ((convert (limit floatp)
167               (typecase limit               (typecase limit
# Line 370  Line 171 
171      `(or (float ,(convert min t) ,(convert max t))      `(or (float ,(convert min t) ,(convert max t))
172           (rational ,(convert min nil) ,(convert max nil)))))           (rational ,(convert min nil) ,(convert max nil)))))
173    
174    #-clx-ansi-common-lisp
175    (deftype base-char ()
176      'string-char)
177    
178  ; Note that we are explicitly using a different rgb representation than what  ; Note that we are explicitly using a different rgb representation than what
179  ; is actually transmitted in the protocol.  ; is actually transmitted in the protocol.
180    
# Line 408  Line 213 
213             (ignore depth))             (ignore depth))
214    (print-unreadable-object (color stream :type t)    (print-unreadable-object (color stream :type t)
215      (prin1 (color-red color) stream)      (prin1 (color-red color) stream)
216      (princ " " stream)      (write-string " " stream)
217      (prin1 (color-green color) stream)      (prin1 (color-green color) stream)
218      (princ " " stream)      (write-string " " stream)
219      (prin1 (color-blue color) stream)))      (prin1 (color-blue color) stream)))
220    
221  (defun make-color (&key (red 1.0) (green 1.0) (blue 1.0) &allow-other-keys)  (defun make-color (&key (red 1.0) (green 1.0) (blue 1.0) &allow-other-keys)
# Line 451  Line 256 
256      nil :type (or null reply-buffer))      nil :type (or null reply-buffer))
257    (event-queue-head                             ; Threaded queue of events    (event-queue-head                             ; Threaded queue of events
258      nil :type (or null reply-buffer))      nil :type (or null reply-buffer))
259    (atom-cache (make-hash-table :test #'eq :size *atom-cache-size*)    (atom-cache (make-hash-table :test (atom-cache-map-test) :size *atom-cache-size*)
260                :type hash-table)                 ; Hash table relating atoms keywords                :type hash-table)                 ; Hash table relating atoms keywords
261                                                  ; to atom id's                                                  ; to atom id's
262    (font-cache nil)                              ; list of font    (font-cache nil)                              ; list of font
# Line 524  Line 329 
329                 :type hash-table)                 :type hash-table)
330    )    )
331    
332    (defun print-display-name (display stream)
333      (declare (type (or null display) display))
334      (cond (display
335             #-allegro (princ (display-host display) stream)
336             #+allegro (write-string (string (display-host display)) stream)
337             (write-string ":" stream)
338             (princ (display-display display) stream))
339            (t
340             (write-string "(no display)" stream)))
341      display)
342    
343  (defun print-display (display stream depth)  (defun print-display (display stream depth)
344    (declare (type display display)    (declare (type display display)
345             (ignore depth))             (ignore depth))
346    (print-unreadable-object (display stream :type t)    (print-unreadable-object (display stream :type t)
347      (princ (display-host display) stream)      (print-display-name display stream)
348      (princ ":" stream)      (write-string " (" stream)
349      (princ (display-display display) stream)      (write-string (display-vendor-name display) stream)
350      (princ " (" stream)      (write-string " R" stream)
     (princ (display-vendor-name display) stream)  
     (princ " R" stream)  
351      (prin1 (display-release-number display) stream)      (prin1 (display-release-number display) stream)
352      (princ ")" stream)))      (write-string ")" stream)))
353    
354  ;;(deftype drawable () '(or window pixmap))  ;;(deftype drawable () '(or window pixmap))
355    
# Line 549  Line 363 
363    (declare (type drawable drawable)    (declare (type drawable drawable)
364             (ignore depth))             (ignore depth))
365    (print-unreadable-object (drawable stream :type t)    (print-unreadable-object (drawable stream :type t)
366      (princ (display-host (drawable-display drawable)) stream)      (print-display-name (drawable-display drawable) stream)
367      (princ ":" stream)      (write-string " " stream)
     (princ (display-display (drawable-display drawable)) stream)  
     (princ " " stream)  
368      (prin1 (drawable-id drawable) stream)))      (prin1 (drawable-id drawable) stream)))
369    
370  (def-clx-class (window (:include drawable) (:copier nil)  (def-clx-class (window (:include drawable) (:copier nil)
# Line 581  Line 393 
393             (ignore depth))             (ignore depth))
394    (print-unreadable-object (visual-info stream :type t)    (print-unreadable-object (visual-info stream :type t)
395      (prin1 (visual-info-bits-per-rgb visual-info) stream)      (prin1 (visual-info-bits-per-rgb visual-info) stream)
396      (princ "-bit " stream)      (write-string "-bit " stream)
397      (princ (visual-info-class visual-info) stream)      (princ (visual-info-class visual-info) stream)
398      (princ " " stream)      (write-string " " stream)
399      (princ (display-host (visual-info-display visual-info)) stream)      (print-display-name (visual-info-display visual-info) stream)
400      (princ ":" stream)      (write-string " " stream)
     (princ (display-display (visual-info-display visual-info)) stream)  
     (princ " " stream)  
401      (prin1 (visual-info-id visual-info) stream)))      (prin1 (visual-info-id visual-info) stream)))
402    
403  (def-clx-class (colormap (:copier nil) (:print-function print-colormap))  (def-clx-class (colormap (:copier nil) (:print-function print-colormap))
# Line 602  Line 412 
412    (print-unreadable-object (colormap stream :type t)    (print-unreadable-object (colormap stream :type t)
413      (when (colormap-visual-info colormap)      (when (colormap-visual-info colormap)
414        (princ (visual-info-class (colormap-visual-info colormap)) stream)        (princ (visual-info-class (colormap-visual-info colormap)) stream)
415        (princ " " stream))        (write-string " " stream))
416      (princ (display-host (colormap-display colormap)) stream)      (print-display-name (colormap-display colormap) stream)
417      (princ ":" stream)      (write-string " " stream)
     (princ (display-display (colormap-display colormap)) stream)  
     (princ " " stream)  
418      (prin1 (colormap-id colormap) stream)))      (prin1 (colormap-id colormap) stream)))
419    
420  (def-clx-class (cursor (:copier nil) (:print-function print-cursor))  (def-clx-class (cursor (:copier nil) (:print-function print-cursor))
# Line 618  Line 426 
426    (declare (type cursor cursor)    (declare (type cursor cursor)
427             (ignore depth))             (ignore depth))
428    (print-unreadable-object (cursor stream :type t)    (print-unreadable-object (cursor stream :type t)
429      (princ (display-host (cursor-display cursor)) stream)      (print-display-name (cursor-display cursor) stream)
430      (princ ":" stream)      (write-string " " stream)
     (princ (display-display (cursor-display cursor)) stream)  
     (princ " " stream)  
431      (prin1 (cursor-id cursor) stream)))      (prin1 (cursor-id cursor) stream)))
432    
433  ; Atoms are accepted as strings or symbols, and are always returned as keywords.  ; Atoms are accepted as strings or symbols, and are always returned as keywords.
# Line 719  Line 525 
525    (declare (type gcontext gcontext)    (declare (type gcontext gcontext)
526             (ignore depth))             (ignore depth))
527    (print-unreadable-object (gcontext stream :type t)    (print-unreadable-object (gcontext stream :type t)
528      (princ (display-host (gcontext-display gcontext)) stream)      (print-display-name (gcontext-display gcontext) stream)
529      (princ ":" stream)      (write-string " " stream)
     (princ (display-display (gcontext-display gcontext)) stream)  
     (princ " " stream)  
530      (prin1 (gcontext-id gcontext) stream)))      (prin1 (gcontext-id gcontext) stream)))
531    
532  (defconstant *event-mask-vector*  (defconstant *event-mask-vector*
# Line 853  Line 657 
657             (ignore depth))             (ignore depth))
658    (print-unreadable-object (screen stream :type t)    (print-unreadable-object (screen stream :type t)
659      (let ((display (drawable-display (screen-root screen))))      (let ((display (drawable-display (screen-root screen))))
660        (princ (display-host display) stream)        (print-display-name display stream)
661        (princ ":" stream)        (write-string "." stream)
       (princ (display-display display) stream)  
       (princ "." stream)  
662        (princ (position screen (display-roots display)) stream))        (princ (position screen (display-roots display)) stream))
663      (princ " " stream)      (write-string " " stream)
664      (prin1 (screen-width screen) stream)      (prin1 (screen-width screen) stream)
665      (princ "x" stream)      (write-string "x" stream)
666      (prin1 (screen-height screen) stream)      (prin1 (screen-height screen) stream)
667      (princ "x" stream)      (write-string "x" stream)
668      (prin1 (screen-root-depth screen) stream)      (prin1 (screen-root-depth screen) stream)
669      (when (screen-root-visual-info screen)      (when (screen-root-visual-info screen)
670        (princ " " stream)        (write-string " " stream)
671        (princ (visual-info-class (screen-root-visual-info screen)) stream))))        (princ (visual-info-class (screen-root-visual-info screen)) stream))))
672    
673  (defun screen-root-visual (screen)  (defun screen-root-visual (screen)
# Line 910  Line 712 
712    (print-unreadable-object (font stream :type t)    (print-unreadable-object (font stream :type t)
713      (if (font-name font)      (if (font-name font)
714          (princ (font-name font) stream)          (princ (font-name font) stream)
715        (princ "(gcontext)" stream))        (write-string "(gcontext)" stream))
716      (princ " " stream)      (write-string " " stream)
717      (princ (display-host (font-display font)) stream)      (print-display-name (font-display font) stream)
     (princ ":" stream)  
     (princ (display-display (font-display font)) stream)  
718      (when (font-id-internal font)      (when (font-id-internal font)
719        (princ " " stream)        (write-string " " stream)
720        (prin1 (font-id font) stream))))        (prin1 (font-id font) stream))))
721    
722  (defun font-id (font)  (defun font-id (font)
# Line 1021  Line 821 
821    ;; Returns NIL when KEY-LIST is not a list or mask.    ;; Returns NIL when KEY-LIST is not a list or mask.
822    (declare (type (simple-array keyword (*)) key-vector)    (declare (type (simple-array keyword (*)) key-vector)
823             (type (or mask32 list) key-list))             (type (or mask32 list) key-list))
824    (declare (values (or mask32 nil)))    (declare (values (or mask32 null)))
825    (typecase key-list    (typecase key-list
826      (mask32 key-list)      (mask32 key-list)
827      (list (let ((mask 0))      (list (let ((mask 0))

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

  ViewVC Help
Powered by ViewVC 1.1.5