/[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.4 by wlott, Wed Apr 8 00:31:43 1992 UTC revision 1.5 by ram, Tue Aug 11 15:15:30 1992 UTC
# Line 83  Line 83 
83  (pushnew :clx *features*)  (pushnew :clx *features*)
84  (pushnew :xlib *features*)  (pushnew :xlib *features*)
85    
86  (defparameter *version* "MIT R5.0")  (defparameter *version* "MIT R5.01")
87  (pushnew :clx-mit-r4 *features*)  (pushnew :clx-mit-r4 *features*)
88  (pushnew :clx-mit-r5 *features*)  (pushnew :clx-mit-r5 *features*)
89    
# Line 92  Line 92 
92    
93  (defparameter *x-tcp-port* 6000) ;; add display number  (defparameter *x-tcp-port* 6000) ;; add display number
94    
 ; Note: various perversions of the CL type system are used below.  
 ; Examples: (list elt-type) (sequence elt-type)  
   
95  ;; Note: if you have read the Version 11 protocol document or C Xlib manual, most of  ;; Note: if you have read the Version 11 protocol document or C Xlib manual, most of
96  ;; the relationships should be fairly obvious.  We have no intention of writing yet  ;; the relationships should be fairly obvious.  We have no intention of writing yet
97  ;; another moby document for this interface.  ;; another moby document for this interface.
# Line 124  Line 121 
121  ;  ;; cache-p true.  ;  ;; cache-p true.
122  ;  (declare (type display display)  ;  (declare (type display display)
123  ;          (type integer resource-id)  ;          (type integer resource-id)
124  ;          (values <mumble>)))  ;          (clx-values <mumble>)))
125    
126  ;(defun <mumble>-display (<mumble>)  ;(defun <mumble>-display (<mumble>)
127  ;  (declare (type <mumble> <mumble>)  ;  (declare (type <mumble> <mumble>)
128  ;          (values display)))  ;          (clx-values display)))
129    
130  ;(defun <mumble>-id (<mumble>)  ;(defun <mumble>-id (<mumble>)
131  ;  (declare (type <mumble> <mumble>)  ;  (declare (type <mumble> <mumble>)
132  ;          (values integer)))  ;          (clx-values integer)))
133    
134  ;(defun <mumble>-equal (<mumble>-1 <mumble>-2)  ;(defun <mumble>-equal (<mumble>-1 <mumble>-2)
135  ;  (declare (type <mumble> <mumble>-1 <mumble>-2)))  ;  (declare (type <mumble> <mumble>-1 <mumble>-2)))
136    
137  ;(defun <mumble>-p (<mumble>-1 <mumble>-2)  ;(defun <mumble>-p (<mumble>-1 <mumble>-2)
138  ;  (declare (type <mumble> <mumble>-1 <mumble>-2)  ;  (declare (type <mumble> <mumble>-1 <mumble>-2)
139  ;          (values boolean)))  ;          (clx-values boolean)))
140    
141  (deftype boolean () '(or null (not null)))  (deftype boolean () '(or null (not null)))
142    
# Line 161  Line 158 
158    
159  (deftype card4 () '(unsigned-byte 4))  (deftype card4 () '(unsigned-byte 4))
160    
161  #-(or clx-ansi-common-lisp cmu)  #-clx-ansi-common-lisp
162  (deftype real (&optional (min '*) (max '*))  (deftype real (&optional (min '*) (max '*))
163    (labels ((convert (limit floatp)    (labels ((convert (limit floatp)
164               (typecase limit               (typecase limit
# Line 171  Line 168 
168      `(or (float ,(convert min t) ,(convert max t))      `(or (float ,(convert min t) ,(convert max t))
169           (rational ,(convert min nil) ,(convert max nil)))))           (rational ,(convert min nil) ,(convert max nil)))))
170    
171  #-(or clx-ansi-common-lisp cmu)  #-clx-ansi-common-lisp
172  (deftype base-char ()  (deftype base-char ()
173    'string-char)    'string-char)
174    
# Line 220  Line 217 
217    
218  (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)
219    (declare (type rgb-val red green blue))    (declare (type rgb-val red green blue))
220    (declare (values color))    (declare (clx-values color))
221    (make-color-internal red green blue))    (make-color-internal red green blue))
222    
223  (defun color-rgb (color)  (defun color-rgb (color)
224    (declare (type color color))    (declare (type color color))
225    (declare (values red green blue))    (declare (clx-values red green blue))
226    (values (color-red color) (color-green color) (color-blue color)))    (values (color-red color) (color-green color) (color-blue color)))
227    
228  (def-clx-class (bitmap-format (:copier nil))  (def-clx-class (bitmap-format (:copier nil) (:print-function print-bitmap-format))
229    (unit 8 :type (member 8 16 32))    (unit 8 :type (member 8 16 32))
230    (pad 8 :type (member 8 16 32))    (pad 8 :type (member 8 16 32))
231    (lsb-first-p nil :type boolean))    (lsb-first-p nil :type boolean))
232    
233  (def-clx-class (pixmap-format (:copier nil))  (defun print-bitmap-format (bitmap-format stream depth)
234      (declare (type bitmap-format bitmap-format)
235               (ignore depth))
236      (print-unreadable-object (bitmap-format stream :type t)
237        (format stream "unit ~D pad ~D ~:[M~;L~]SB first"
238                (bitmap-format-unit bitmap-format)
239                (bitmap-format-pad bitmap-format)
240                (bitmap-format-lsb-first-p bitmap-format))))
241    
242    (def-clx-class (pixmap-format (:copier nil) (:print-function print-pixmap-format))
243    (depth 0 :type image-depth)    (depth 0 :type image-depth)
244    (bits-per-pixel 8 :type (member 1 4 8 16 24 32))    (bits-per-pixel 8 :type (member 1 4 8 16 24 32))
245    (scanline-pad 8 :type (member 8 16 32)))    (scanline-pad 8 :type (member 8 16 32)))
246    
247    (defun print-pixmap-format (pixmap-format stream depth)
248      (declare (type pixmap-format pixmap-format)
249               (ignore depth))
250      (print-unreadable-object (pixmap-format stream :type t)
251        (format stream "depth ~D bits-per-pixel ~D scanline-pad ~D"
252                (pixmap-format-depth pixmap-format)
253                (pixmap-format-bits-per-pixel pixmap-format)
254                (pixmap-format-scanline-pad pixmap-format))))
255    
256  (defparameter *atom-cache-size* 200)  (defparameter *atom-cache-size* 200)
257  (defparameter *resource-id-map-size* 500)  (defparameter *resource-id-map-size* 500)
258    
# Line 302  Line 317 
317    (event-extensions '#() :type vector)          ; Vector mapping X event-codes to event keys    (event-extensions '#() :type vector)          ; Vector mapping X event-codes to event keys
318    (performance-info)                            ; Hook for gathering performance info    (performance-info)                            ; Hook for gathering performance info
319    (trace-history)                               ; Hook for debug trace    (trace-history)                               ; Hook for debug trace
320    (plist)                                       ; hook for extension to hang data    (plist nil :type list)                        ; hook for extension to hang data
321    ;; These slots are used to manage multi-process input.    ;; These slots are used to manage multi-process input.
322    (input-in-progress nil)                       ; Some process reading from the stream.    (input-in-progress nil)                       ; Some process reading from the stream.
323                                                  ; Updated with CONDITIONAL-STORE.                                                  ; Updated with CONDITIONAL-STORE.
# Line 492  Line 507 
507    (declare (ignore key-type-and-name datum-type-and-name))    (declare (ignore key-type-and-name datum-type-and-name))
508    'list)    'list)
509    
510    (deftype clx-list (&optional element-type) (declare (ignore element-type)) 'list)
511    (deftype clx-sequence (&optional element-type) (declare (ignore element-type)) 'sequence)
512    
513  ; A sequence, containing zero or more repetitions of the given elements,  ; A sequence, containing zero or more repetitions of the given elements,
514  ; with the elements expressed as (type name).  ; with the elements expressed as (type name).
515    
# Line 546  Line 564 
564             :focus-change :property-change :colormap-change :keymap-state))             :focus-change :property-change :colormap-change :keymap-state))
565    
566  (deftype event-mask ()  (deftype event-mask ()
567    '(or mask32 list)) ;; (OR integer (LIST event-mask-class))    '(or mask32 (clx-list event-mask-class)))
568    
569  (defconstant *pointer-event-mask-vector*  (defconstant *pointer-event-mask-vector*
570               '#(%error %error :button-press :button-release               '#(%error %error :button-press :button-release
# Line 561  Line 579 
579             :button-5-motion :button-motion :keymap-state))             :button-5-motion :button-motion :keymap-state))
580    
581  (deftype pointer-event-mask ()  (deftype pointer-event-mask ()
582    '(or mask32 list)) ;;  '(or integer (list pointer-event-mask-class)))    '(or mask32 (clx-list pointer-event-mask-class)))
583    
584  (defconstant *device-event-mask-vector*  (defconstant *device-event-mask-vector*
585               '#(:key-press :key-release :button-press :button-release :pointer-motion               '#(:key-press :key-release :button-press :button-release :pointer-motion
# Line 574  Line 592 
592             :button-5-motion :button-motion))             :button-5-motion :button-motion))
593    
594  (deftype device-event-mask ()  (deftype device-event-mask ()
595    '(or mask32 list)) ;;  '(or integer (list device-event-mask-class)))    '(or mask32 (clx-list device-event-mask-class)))
596    
597  (defconstant *state-mask-vector*  (defconstant *state-mask-vector*
598               '#(:shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5               '#(:shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5
# Line 584  Line 602 
602    '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5))    '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5))
603    
604  (deftype modifier-mask ()  (deftype modifier-mask ()
605    '(or (member :any) mask16 list)) ;;  '(or (member :any) integer (list modifier-key)))    '(or (member :any) mask16 (clx-list modifier-key)))
606    
607  (deftype state-mask-key ()  (deftype state-mask-key ()
608    '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5)))    '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5)))
# Line 638  Line 656 
656    (height 0 :type card16)    (height 0 :type card16)
657    (width-in-millimeters 0 :type card16)    (width-in-millimeters 0 :type card16)
658    (height-in-millimeters 0 :type card16)    (height-in-millimeters 0 :type card16)
659    (depths nil :type (alist (image-depth depth) ((list visual-info) visuals)))    (depths nil :type (alist (image-depth depth) ((clx-list visual-info) visuals)))
660    (root-depth 1 :type image-depth)    (root-depth 1 :type image-depth)
661    (root-visual-info nil :type (or null visual-info))    (root-visual-info nil :type (or null visual-info))
662    (default-colormap nil :type (or null colormap))    (default-colormap nil :type (or null colormap))
# Line 672  Line 690 
690    
691  (defun screen-root-visual (screen)  (defun screen-root-visual (screen)
692    (declare (type screen screen)    (declare (type screen screen)
693             (values resource-id))             (clx-values resource-id))
694    (visual-info-id (screen-root-visual-info screen)))    (visual-info-id (screen-root-visual-info screen)))
695    
696  ;; The list contains alternating keywords and integers.  ;; The list contains alternating keywords and integers.
# Line 751  Line 769 
769    
770  ;(defun font-<name> (font)  ;(defun font-<name> (font)
771  ;  (declare (type font font)  ;  (declare (type font font)
772  ;          (values <type>)))  ;          (clx-values <type>)))
773    
774  (macrolet ((make-font-info-accessors (useless-name &body fields)  (macrolet ((make-font-info-accessors (useless-name &body fields)
775               `(within-definition (,useless-name make-font-info-accessors)               `(within-definition (,useless-name make-font-info-accessors)
# Line 763  Line 781 
781                                 (accessor (xintern 'font-info- n)))                                 (accessor (xintern 'font-info- n)))
782                            `(defun ,name (font)                            `(defun ,name (font)
783                               (declare (type font font))                               (declare (type font font))
784                               (declare (values ,type))                               (declare (clx-values ,type))
785                               (,accessor (font-font-info font)))))                               (,accessor (font-font-info font)))))
786                      fields))))                      fields))))
787    (make-font-info-accessors ignore    (make-font-info-accessors ignore
# Line 785  Line 803 
803  (defun font-property (font name)  (defun font-property (font name)
804    (declare (type font font)    (declare (type font font)
805             (type keyword name))             (type keyword name))
806    (declare (values (or null int32)))    (declare (clx-values (or null int32)))
807    (getf (font-properties font) name))    (getf (font-properties font) name))
808    
809  (macrolet ((make-mumble-equal (type)  (macrolet ((make-mumble-equal (type)
# Line 821  Line 839 
839    ;; Returns NIL when KEY-LIST is not a list or mask.    ;; Returns NIL when KEY-LIST is not a list or mask.
840    (declare (type (simple-array keyword (*)) key-vector)    (declare (type (simple-array keyword (*)) key-vector)
841             (type (or mask32 list) key-list))             (type (or mask32 list) key-list))
842    (declare (values (or mask32 null)))    (declare (clx-values (or mask32 null)))
843    (typecase key-list    (typecase key-list
844      (mask32 key-list)      (mask32 key-list)
845      (list (let ((mask 0))      (list (let ((mask 0))
# Line 834  Line 852 
852  (defun decode-mask (key-vector mask)  (defun decode-mask (key-vector mask)
853    (declare (type (simple-array keyword (*)) key-vector)    (declare (type (simple-array keyword (*)) key-vector)
854             (type mask32 mask))             (type mask32 mask))
855    (declare (values list))    (declare (clx-values list))
856    (do ((m mask (ash m -1))    (do ((m mask (ash m -1))
857         (bit 0 (1+ bit))         (bit 0 (1+ bit))
858         (len (length key-vector))         (len (length key-vector))
# Line 848  Line 866 
866    
867  (defun encode-event-mask (event-mask)  (defun encode-event-mask (event-mask)
868    (declare (type event-mask event-mask))    (declare (type event-mask event-mask))
869    (declare (values mask32))    (declare (clx-values mask32))
870    (or (encode-mask *event-mask-vector* event-mask 'event-mask-class)    (or (encode-mask *event-mask-vector* event-mask 'event-mask-class)
871        (x-type-error event-mask 'event-mask)))        (x-type-error event-mask 'event-mask)))
872    
873  (defun make-event-mask (&rest keys)  (defun make-event-mask (&rest keys)
874    ;; This is only defined for core events.    ;; This is only defined for core events.
875    ;; Useful for constructing event-mask, pointer-event-mask, device-event-mask.    ;; Useful for constructing event-mask, pointer-event-mask, device-event-mask.
876    (declare (type list keys)) ;; (list event-mask-class)    (declare (type (clx-list event-mask-class) keys))
877    (declare (values mask32))    (declare (clx-values mask32))
878    (encode-mask *event-mask-vector* keys 'event-mask-class))    (encode-mask *event-mask-vector* keys 'event-mask-class))
879    
880  (defun make-event-keys (event-mask)  (defun make-event-keys (event-mask)
881    ;; This is only defined for core events.    ;; This is only defined for core events.
882    (declare (type mask32 event-mask))    (declare (type mask32 event-mask))
883    (declare (values (list event-mask-class)))    (declare (clx-values (clx-list event-mask-class)))
884    (decode-mask *event-mask-vector* event-mask))    (decode-mask *event-mask-vector* event-mask))
885    
886  (defun encode-device-event-mask (device-event-mask)  (defun encode-device-event-mask (device-event-mask)
887    (declare (type device-event-mask device-event-mask))    (declare (type device-event-mask device-event-mask))
888    (declare (values mask32))    (declare (clx-values mask32))
889    (or (encode-mask *device-event-mask-vector* device-event-mask    (or (encode-mask *device-event-mask-vector* device-event-mask
890                     'device-event-mask-class)                     'device-event-mask-class)
891        (x-type-error device-event-mask 'device-event-mask)))        (x-type-error device-event-mask 'device-event-mask)))
892    
893  (defun encode-modifier-mask (modifier-mask)  (defun encode-modifier-mask (modifier-mask)
894    (declare (type modifier-mask modifier-mask)) ;; (list state-mask-key)    (declare (type modifier-mask modifier-mask))
895    (declare (values mask16))    (declare (clx-values mask16))
896    (or (encode-mask *state-mask-vector* modifier-mask 'modifier-key)    (or (encode-mask *state-mask-vector* modifier-mask 'modifier-key)
897        (and (eq modifier-mask :any) #x8000)        (and (eq modifier-mask :any) #x8000)
898        (x-type-error modifier-mask 'modifier-mask)))        (x-type-error modifier-mask 'modifier-mask)))
899    
900  (defun encode-state-mask (state-mask)  (defun encode-state-mask (state-mask)
901    (declare (type (or mask16 list) state-mask)) ;; (list state-mask-key)    (declare (type (or mask16 (clx-list state-mask-key)) state-mask))
902    (declare (values mask16))    (declare (clx-values mask16))
903    (or (encode-mask *state-mask-vector* state-mask 'state-mask-key)    (or (encode-mask *state-mask-vector* state-mask 'state-mask-key)
904        (x-type-error state-mask '(or mask16 (list state-mask-key)))))        (x-type-error state-mask '(or mask16 (clx-list state-mask-key)))))
905    
906  (defun make-state-mask (&rest keys)  (defun make-state-mask (&rest keys)
907    ;; Useful for constructing modifier-mask, state-mask.    ;; Useful for constructing modifier-mask, state-mask.
908    (declare (type list keys)) ;; (list state-mask-key)    (declare (type (clx-list state-mask-key) keys))
909    (declare (values mask16))    (declare (clx-values mask16))
910    (encode-mask *state-mask-vector* keys 'state-mask-key))    (encode-mask *state-mask-vector* keys 'state-mask-key))
911    
912  (defun make-state-keys (state-mask)  (defun make-state-keys (state-mask)
913    (declare (type mask16 state-mask))    (declare (type mask16 state-mask))
914    (declare (values (list state-mask-key)))    (declare (clx-values (clx-list state-mask-key)))
915    (decode-mask *state-mask-vector* state-mask))    (decode-mask *state-mask-vector* state-mask))
916    
917  (defun encode-pointer-event-mask (pointer-event-mask)  (defun encode-pointer-event-mask (pointer-event-mask)
918    (declare (type pointer-event-mask pointer-event-mask))    (declare (type pointer-event-mask pointer-event-mask))
919    (declare (values mask32))    (declare (clx-values mask32))
920    (or (encode-mask *pointer-event-mask-vector* pointer-event-mask    (or (encode-mask *pointer-event-mask-vector* pointer-event-mask
921                     'pointer-event-mask-class)                     'pointer-event-mask-class)
922        (x-type-error pointer-event-mask 'pointer-event-mask)))        (x-type-error pointer-event-mask 'pointer-event-mask)))

Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5

  ViewVC Help
Powered by ViewVC 1.1.5