diff --git a/clx/buffer.lisp b/clx/buffer.lisp index 113867dceb509d968f44a62b9bb159e091722cd7..377b0eeeb917681c817c701a458b78479416e45a 100644 --- a/clx/buffer.lisp +++ b/clx/buffer.lisp @@ -519,7 +519,7 @@ (index 0 (index+ index 1))) ((index-zerop j)) (declare (type array-index j index) - (type cons lst)) + (list lst)) (setf (car lst) (read-card8 index))))) (defun read-list-card8-with-transform (reply-buffer nitems data transform start index) @@ -537,7 +537,7 @@ (index 0 (index+ index 1))) ((index-zerop j)) (declare (type array-index j index) - (type cons lst)) + (list lst)) (setf (car lst) (funcall transform (read-card8 index)))))) #-lispm @@ -668,7 +668,7 @@ (index 0 (index+ index 2))) ((index-zerop j)) (declare (type array-index j index) - (type cons lst)) + (list lst)) (setf (car lst) (read-card16 index))))) (defun read-list-card16-with-transform (reply-buffer nitems data transform start index) @@ -686,7 +686,7 @@ (index 0 (index+ index 2))) ((index-zerop j)) (declare (type array-index j index) - (type cons lst)) + (list lst)) (setf (car lst) (funcall transform (read-card16 index)))))) #-lispm @@ -827,7 +827,7 @@ (index 0 (index+ index 4))) ((index-zerop j)) (declare (type array-index j index) - (type cons lst)) + (list lst)) (setf (car lst) (read-card32 index))))) (defun read-list-card32-with-transform (reply-buffer nitems data transform start index) @@ -845,7 +845,7 @@ (index 0 (index+ index 4))) ((index-zerop j)) (declare (type array-index j index) - (type cons lst)) + (list lst)) (setf (car lst) (funcall transform (read-card32 index)))))) #-lispm diff --git a/clx/clx.lisp b/clx/clx.lisp index 0dea20d2220888a8fae9e8f5c3a6c4d6e611154c..93d976d025939fe2877f8c4a11c8bf4fc4ad171e 100644 --- a/clx/clx.lisp +++ b/clx/clx.lisp @@ -305,7 +305,7 @@ (error-handler 'default-error-handler) ; Error handler function (close-down-mode :destroy) ; Close down mode saved by Set-Close-Down-Mode (authorization-name "" :type string) - (authorization-data "" :type string) + (authorization-data "" :type (or (array (unsigned-byte 8)) string)) (last-width nil :type (or null card29)) ; Accumulated width of last string (keysym-mapping nil ; Keysym mapping cached from server :type (or null (array * (* *)))) diff --git a/clx/defsystem.lisp b/clx/defsystem.lisp index e1174d1c0c151930b2f8c774854ce95912b20e2b..a77264fbd47c1ba82a3d53eda304f1467025b0ad 100644 --- a/clx/defsystem.lisp +++ b/clx/defsystem.lisp @@ -1,4 +1,4 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: T; -*- +;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- ;;; ;;; TEXAS INSTRUMENTS INCORPORATED @@ -40,9 +40,14 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (setf *readtable* si:*ansi-common-lisp-readtable*)) -#-clx-ansi-common-lisp +#-(or clx-ansi-common-lisp cmu) (lisp:in-package :user) +#+cmu +(lisp:in-package "XLIB") +#+cmu +(export 'load-clx) + #+clx-ansi-common-lisp (common-lisp:in-package :common-lisp-user) @@ -311,7 +316,7 @@ ;;; lucid2.0/hp9000s300 ;;; must uudecode the file make-sequence-patch.uu -#+(or lucid kcl ibcl) +#+(or lucid kcl ibcl cmu) (defun clx-foreign-files (binary-path) #+(and lucid (not lcl3.0) (or mc68000 mc68020)) @@ -327,6 +332,14 @@ (list (namestring (merge-pathnames "socket.o" binary-path))) '("-lc")) + #+cmu + (declare (ignore binary-path)) + #+cmu + (alien:def-alien-routine ("connect_to_server" xlib::connect-to-server) + c-call:int + (host c-call:c-string) + (port c-call:int)) + #+(or kcl ibcl) (progn (let ((pathname (merge-pathnames "sockcl.o" binary-path)) @@ -504,7 +517,7 @@ (load binary)))) (load-binary "package") - #+(or lucid kcl ibcl) (clx-foreign-files binary-path) + #+(or lucid kcl ibcl cmu) (clx-foreign-files binary-path) #+excl (load-binary "excldep") (load-binary "depdefs") (load-binary "clx") diff --git a/clx/depdefs.lisp b/clx/depdefs.lisp index 6a89c31a8f43f6c219dbdf27a59f7d90ef62a2e0..f03ce27e1f0efa3c7ab1ad36bf1368b38f1a22cb 100644 --- a/clx/depdefs.lisp +++ b/clx/depdefs.lisp @@ -387,7 +387,11 @@ ;;; Pseudo-class mechanism. (eval-when (eval compile load) -(defvar *def-clx-class-use-defclass* #+Genera t #-Genera nil +(defvar *def-clx-class-use-defclass* + #+Genera t + #+(and cmu pcl) '(XLIB:DRAWABLE XLIB:WINDOW XLIB:PIXMAP) + #+(and cmu (not pcl)) nil + #-(or Genera cmu) nil "Controls whether DEF-CLX-CLASS uses DEFCLASS. If it is a list, it is interpreted by DEF-CLX-CLASS to be a list of type names for which DEFCLASS should be used. diff --git a/clx/fonts.lisp b/clx/fonts.lisp index fe3c995358b2b0a5e54b4f19f16494c5c96ad497..c54a42a745810d4a3d45e6b141a4bd25699fbe03 100644 --- a/clx/fonts.lisp +++ b/clx/fonts.lisp @@ -45,7 +45,7 @@ ;; Note: char16-<metric> accessors could be defined to accept two-byte indexes. -(deftype char-info-vec () '(simple-array int16 (6))) +(deftype char-info-vec () '(simple-array int16 (*))) (macrolet ((def-char-info-accessors (useless-name &body fields) `(within-definition (,useless-name def-char-info-accessors) diff --git a/clx/gcontext.lisp b/clx/gcontext.lisp index 22150ab0743afe27f4e4ae05bf7999c35bd240b4..f8c310a3f800c9f5101510af52ca8db81489e5e2 100644 --- a/clx/gcontext.lisp +++ b/clx/gcontext.lisp @@ -553,7 +553,7 @@ (declare (type gcontext ,gc) (type gcontext-state ,saved-state) (type xgcmask ,temp-mask) - (type (or null resource-id) ,temp-gc)) + (type (or null gcontext) ,temp-gc)) (with-gcontext-bindings (,gc ,saved-state ,(append indexes extension-indexes) ,ts-index ,temp-mask ,temp-gc) diff --git a/clx/image.lisp b/clx/image.lisp index be8099688a6acab9a8838c08abd67c05be0444f9..080043bc94cd0bcca7e50ab85cc28ad8b21bb9b5 100644 --- a/clx/image.lisp +++ b/clx/image.lisp @@ -807,14 +807,16 @@ (index-ceiling x 8)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y)) - (left-bits (index-mod (index- x) 8)) + (left-bits (the array-index + (mod (the (integer #x-FFFF 0) (- x)) + 8))) (right-bits (index-mod (index- width left-bits) 8)) - (middle-bits (index- width left-bits right-bits)) - (middle-bytes (index-floor middle-bits 8))) + (middle-bits (- width left-bits right-bits)) + (middle-bytes (floor middle-bits 8))) ((index>= y height)) - (declare (type array-index start y - left-bits right-bits middle-bits middle-bytes)) - (cond ((index< middle-bits 0) + (declare (type array-index start y left-bits right-bits)) + (declare (fixnum middle-bits middle-bytes)) + (cond ((< middle-bits 0) (let ((byte (aref buffer-bbuf (index1- start))) (x left-bits)) (declare (type card8 byte) @@ -938,7 +940,7 @@ (index-ceiling x 2)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y)) - (left-nibbles (index-mod (index- x) 2)) + (left-nibbles (mod (the fixnum (- x)) 2)) (right-nibbles (index-mod (index- width left-nibbles) 2)) (middle-nibbles (index- width left-nibbles right-nibbles)) (middle-bytes (index-floor middle-nibbles 2))) @@ -1961,7 +1963,7 @@ (byte-lsb-first-p (display-image-lsb-first-p display)) (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) (declare (type (member :bitmap :xy-pixmap :z-pixmap) format) - (type card16 src-x image-width image-height width height) + (type fixnum src-x image-width image-height width height) (type image-depth depth) (type display display) (type bitmap-format bitmap-format) @@ -1969,9 +1971,9 @@ (type boolean byte-lsb-first-p bit-lsb-first-p)) (when (and bitmap-p (not (index= depth 1))) (error "Bitmaps must have depth 1")) - (unless (index<= 0 src-x (index1- (image-width image))) + (unless (<= 0 src-x (index1- (image-width image))) (error "src-x not inside image")) - (unless (index<= 0 src-y (index1- (image-height image))) + (unless (<= 0 src-y (index1- (image-height image))) (error "src-y not inside image")) (when (and (index> width 0) (index> height 0)) (multiple-value-bind (pad bits-per-pixel) @@ -2034,13 +2036,13 @@ (do* ((request-src-y src-y (index+ request-src-y request-height)) (request-y y (index+ request-y request-height)) (height-remaining - height (index- height-remaining request-height)) + height (the fixnum (- height-remaining request-height))) (request-height (index-min height-remaining max-request-height) (index-min height-remaining max-request-height))) - ((index<= height-remaining 0)) - (declare (type array-index request-src-y height-remaining - request-height)) + ((<= height-remaining 0)) + (declare (type array-index request-src-y request-height) + (fixnum height-remaining)) (let* ((request-bytes (index* request-bytes-per-line request-height)) (request-words (index-ceiling request-bytes 4)) (request-length (index+ request-words 6))) @@ -2372,10 +2374,12 @@ (width (or width image-width)) (height (or height image-height))) (declare (type card16 image-width image-height width height)) - (unless (index<= 0 x (index1- image-width)) (error "x not inside image")) - (unless (index<= 0 y (index1- image-height)) (error "y not inside image")) - (setq width (index-min width (index-max (index- image-width x) 0))) - (setq height (index-min height (index-max (index- image-height y) 0))) + (unless (<= 0 x (the fixnum (1- image-width))) + (error "x not inside image")) + (unless (<= 0 y (the fixnum (1- image-height))) + (error "y not inside image")) + (setq width (index-min width (max (the fixnum (- image-width x)) 0))) + (setq height (index-min height (max (the fixnum (- image-height y)) 0))) (let ((copy (etypecase image (image-x @@ -2500,7 +2504,7 @@ line-base (index+ line-base padded-bytes-per-line))))) ;; Compensate for left-pad in width and x-hot (index-decf width left-pad) - (when (getf properties :x-hot) + (when (and (getf properties :x-hot) (plusp (getf properties :x-hot))) (index-decf (getf properties :x-hot) left-pad)) (create-image :width width :height height diff --git a/clx/resource.lisp b/clx/resource.lisp index 3e7b74aab7e7e11278b8c158d9feceb9cdcd6894..8de345c996cb59348839bd5ee7babfef88e93641 100644 --- a/clx/resource.lisp +++ b/clx/resource.lisp @@ -505,7 +505,9 @@ :start i :end end)) (when (string-equal string "#INCLUDE" :start1 i :end1 term) (let ((path (merge-pathnames - (subseq string (1+ term)) (truename stream)))) + (string-trim '(#\tab #\space #\") + (subseq string (1+ term))) + (truename stream)))) (read-resources database path :key key :test test :test-not test-not)))) (otherwise