Commit a25a1a8e authored by pw's avatar pw

Adds 17f release to trunk. Also adds minor fixes from x86 port

parent 540d0342
......@@ -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
......
......@@ -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 * (* *))))
......
;;; -*- 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")
......
......@@ -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.
......
......@@ -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)
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment