From c06530bb3931d950c5fefc564087eb24b85537e1 Mon Sep 17 00:00:00 2001 From: cer <cer> Date: Tue, 16 Jun 1992 19:11:15 +0000 Subject: [PATCH] jdimerge --- tk-silica/xt-graphics.lisp | 308 +++++++++++++++++++++++++------------ tk-silica/xt-silica.lisp | 21 ++- tk/convenience.lisp | 60 ++++---- tk/gcontext.lisp | 119 ++++++++------ tk/graphics.lisp | 14 +- tk/make-classes.lisp | 182 +++++++++++----------- tk/meta-tk.lisp | 35 ++--- tk/pkg.lisp | 10 +- tk/resources.lisp | 31 ++-- tk/xlib.lisp | 18 ++- utils/lisp-utilities.lisp | 25 ++- 11 files changed, 494 insertions(+), 329 deletions(-) diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index 20ff1569..a5357e21 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-graphics.lisp,v 1.25 92/06/03 18:19:11 cer Exp Locker: cer $ +;; $fiHeader: xt-graphics.lisp,v 1.26 92/06/16 15:02:24 cer Exp Locker: cer $ (in-package :tk-silica) @@ -466,6 +466,164 @@ and on color servers, unless using white or black") gc)))))))) + +;; Line (& maybe eventually non-rectangular polygon) clipping + +;; We use 32000 instead of the more correct 32768 because some buggy X servers +;; barf on numbers very close to 32768. + +(defmacro valid-point-p (x y) + `(and (excl:fixnump ,x) (excl:fixnump ,y) + (< (the fixnum ,x) 32000) (> (the fixnum ,x) -32000) + (< (the fixnum ,y) 32000) (> (the fixnum ,y) -32000))) + +;; +;; Here we implement a simple version of the Cohen-Sutherland clipping +;; algorithm. Specifically, we only try to clip the line so that it will +;; be legal to pass to X, we don't try to clip to window boundaries. +;; In port-draw-line* we special case trivial accepts for speed. +;; +(defun clipper (x1 y1 x2 y2 + &optional (xmin -32000) (xmax 32000) (ymin -32000) (ymax 32000)) + (declare (optimize (speed 3) (safety 0)) + #+ignore + (:explain :calls :types) + (fixnum x1 y1 x2 y2 xmin xmax ymin ymax)) + (macrolet ((outcodes (x y) + `(+ (ash (if (minusp (- ymax ,y)) 1 0) 3) + (ash (if (minusp (- ,y ymin)) 1 0) 2) + (ash (if (minusp (- xmax ,x)) 1 0) 1) + (if (minusp (- ,x xmin)) 1 0))) + (rejectp (oc1 oc2) `(plusp (logand ,oc1 ,oc2))) + (acceptp (oc1 oc2) + `(and (zerop ,oc1) (zerop ,oc2)))) + (let ((outcode1 0) (outcode2 0)) + (declare (type (unsigned-byte 4) outcode1 outcode2)) + (loop + (setq outcode1 (outcodes x1 y1) + outcode2 (outcodes x2 y2)) + #+ignore + (format excl:*initial-terminal-io* "oc1 = ~d, oc2 = ~d~%" outcode1 outcode2) + (if (rejectp outcode1 outcode2) + (return-from clipper nil)) + (if* (acceptp outcode1 outcode2) + then (return) + else ;; If P1 is inside window, exchange P1 and P2 to guarantee + ;; that P1 is outside window. + (if (zerop outcode1) + (psetq x1 x2 + y1 y2 + x2 x1 + y2 y1 + outcode1 outcode2 + outcode2 outcode1)) + ;; Now perform a subdivision; move P1 to the intersection point. + ;; Use the formulas y=y1+slope*(x-x1), x=x1+(1/slope)*(y-y1). + (if* (logbitp 3 outcode1) + then ;; Divide line at top of window. + (setq x1 (round (+ x1 (* (- x2 x1) + (/ (- ymax y1) (- y2 y1)))))) + (setq y1 ymax) + elseif (logbitp 2 outcode1) + then ;; Divide line at bottom of window. + (setq x1 (round (+ x1 (* (- x2 x1) + (/ (- ymin y1) (- y2 y1)))))) + (setq y1 ymin) + elseif (logbitp 1 outcode1) + then ;; Divide line at right of window. + (setq x1 xmax) + (setq y1 (round (+ y1 (* (- y2 y1) + (/ (- xmax x1) (- x2 x1)))))) + elseif (logbitp 0 outcode1) + then ;; Divide line at left of window. + (setq x1 xmin) + (setq y1 (round (+ y1 (* (- y2 y1) + (/ (- xmin x1) (- x2 x1))))))) + )))) + (values x1 y1 x2 y2)) + +(defmacro clip-invalidate-line (x1 y1 x2 y2) + `(if (or (not (valid-point-p ,x1 ,y1)) + (not (valid-point-p ,x2 ,y2))) + (multiple-value-setq (,x1 ,y1 ,x2 ,y2) + (clipper ,x1 ,y1 ,x2 ,y2)))) + +(defmethod port-draw-line* ((port xt-port) sheet medium x1 y1 x2 y2) + (let ((drawable (medium-drawable medium))) + (when drawable + (let ((ink (medium-ink medium)) + (transform (sheet-device-transformation sheet))) + (convert-to-device-coordinates transform x1 y1 x2 y2) + (clip-invalidate-line x1 y1 x2 y2) + (tk::draw-line + drawable + (adjust-ink (decode-ink ink medium) + medium + (medium-line-style medium) + (the fixnum (min (the fixnum x1) (the fixnum x2))) + (the fixnum (min (the fixnum y1) (the fixnum y2)))) + x1 y1 x2 y2))))) + +;; Discarding of other illegal graphics + +#| + +(defmacro int16ify (int &optional check-type-string) + "Make int (a fixnum) into an xlib:int16; int must be a + place. Call check-type if it isn't in bounds." + ;; These are ordered in expected frequency of usage + `(if* (and (>= ,int -32768) (< ,int 32768)) + then + nil + else + (setf ,int (make-into-int16 ,int ,check-type-string)))) + +(defmacro card16ify (int &optional check-type-string) + "Make int (a fixnum) into an xlib:card16; int must be a + place. Call check-type if it isn't in bounds." + ;; These are ordered in expected frequency of usage + `(if* (and (>= ,int 0) (< ,int 65536)) + then + nil + else + (setf ,int (make-into-card16 ,int ,check-type-string)))) + +(defun make-into-int16 (object string) + ;; Now it must be too big to fit in an xlib:int16. + (cond (cw::*fix-up-illegal-graphics-p* + (max -32767 (min 32766 object))) + (t + (check-type object xlib:int16 string) + object))) + +(defun make-into-card16 (object string) + ;; Now it must be too big to fit in an xlib:int16. + (cond (cw::*fix-up-illegal-graphics-p* + (max 0 (min 65534 object))) + (t + (check-type object xlib:card16 string) + object))) + +|# + +(defvar *discard-illegal-graphics* t) + +(defmacro discard-illegal-coordinates (function-name &rest positions) + (assert (evenp (length positions)) (positions) + "There must be an even number of elements in ~S" positions) + (let ((forms nil)) + (do () + ((null positions)) + (let* ((x (pop positions)) + (y (pop positions))) + (push `(valid-point-p ,x ,y) forms))) + `(unless (and ,@forms) + (if* *discard-illegal-graphics* + then (return-from ,function-name) + else (error "Coordinate(s) out of (signed-byte 16) range"))))) + + + (defmethod port-draw-point* ((port xt-port) sheet medium x y) (let ((drawable (medium-drawable medium))) (when drawable @@ -474,6 +632,7 @@ and on color servers, unless using white or black") (thickness (line-style-thickness line-style)) (transform (sheet-device-transformation sheet))) (convert-to-device-coordinates transform x y) + (discard-illegal-coordinates port-draw-point* x y) (cond ((< thickness 1.5) (tk::draw-point drawable @@ -498,27 +657,9 @@ and on color servers, unless using white or black") thickness 0 2pi t))))))) -(defmethod port-draw-line* ((port xt-port) sheet medium - x1 y1 x2 y2) - (let ((drawable (medium-drawable medium))) - (when drawable - (let ((ink (medium-ink medium)) - (transform (sheet-device-transformation sheet))) - (convert-to-device-coordinates transform - x1 y1 x2 y2) - (tk::draw-line - drawable - (adjust-ink (decode-ink ink medium) - medium - (medium-line-style medium) - (the fixnum (min (the fixnum x1) (the fixnum x2))) - (the fixnum (min (the fixnum y1) (the fixnum y2)))) - x1 y1 x2 y2))))) (defmethod port-draw-lines* ((port xt-port) sheet medium list-of-x-and-ys) - ;;-- We should decide which version to use. - ;;-- We also need to deal with line clipping. (let* ((transform (sheet-device-transformation sheet)) (len (length list-of-x-and-ys)) (npoints (/ len 4)) @@ -528,89 +669,46 @@ and on color servers, unless using white or black") (minx most-positive-fixnum) (miny most-positive-fixnum) ink) - (if (listp list-of-x-and-ys) + (macrolet ((stuff-line-guts (x1 y1 x2 y2) + `(let ((x1 ,x1) + (y1 ,y1) + (x2 ,x2) + (y2 ,y2)) + (convert-to-device-coordinates transform x1 y1) + (convert-to-device-coordinates transform x2 y2) + (clip-invalidate-line x1 y1 x2 y2) + (minf minx x1) + (minf miny y1) + (minf minx x2) + (minf miny y2) + (setf (tk::xsegment-array-x1 points i) x1 + (tk::xsegment-array-y1 points i) y1 + (tk::xsegment-array-x2 points i) x2 + (tk::xsegment-array-y2 points i) y2)))) + (if (listp list-of-x-and-ys) + (do ((ps list-of-x-and-ys) + (i 0 (1+ i))) + ((null ps)) + (declare (fixnum i)) + (stuff-line-guts (pop ps) (pop ps) (pop ps) (pop ps))) (do ((ps list-of-x-and-ys) - (i 0 (1+ i))) - ((null ps)) - (declare (fixnum i)) - (let ((x (pop ps)) - (y (pop ps))) - (convert-to-device-coordinates transform x y) - (minf minx x) - (minf miny y) - (setf (tk::xsegment-array-x1 points i) x - (tk::xsegment-array-y1 points i) y)) - (let ((x (pop ps)) - (y (pop ps))) - (convert-to-device-coordinates transform x y) - (minf minx x) - (minf miny y) - (setf (tk::xsegment-array-x2 points i) x - (tk::xsegment-array-y2 points i) y))) - (do ((ps list-of-x-and-ys) - (j 0 (+ 2 j)) - (i 0 (+ i 4))) - ((= j len)) - (declare (fixnum i j)) - (let ((x (aref ps j)) - (y (aref ps (1+ j)))) - (convert-to-device-coordinates transform x y) - (minf minx x) - (minf miny y) - (setf (tk::xsegment-array-x1 points i) x - (tk::xsegment-array-y1 points i) y)) - - (let ((x (aref ps (+ 2 j))) - (y (aref ps (+ 3 j)))) - (convert-to-device-coordinates transform x y) - (minf minx x) - (minf miny y) - (setf (tk::xsegment-array-x2 points i) x - (tk::xsegment-array-y2 points i) y)))) - (setq ink - (adjust-ink (decode-ink (medium-ink medium) medium) medium - (medium-line-style medium) - minx miny)) - (when (medium-drawable medium) - (x11:xdrawsegments + (j 0 (+ 2 j)) + (i 0 (+ i 4))) + ((= j len)) + (declare (fixnum i j)) + (stuff-line-guts (aref ps j) (aref ps (1+ j)) (aref ps (+ 2 j)) (aref ps (+ 3 j))))) + (setq ink + (adjust-ink (decode-ink (medium-ink medium) medium) medium + (medium-line-style medium) + minx miny)) + (when (medium-drawable medium) + (x11:xdrawsegments (tk::object-display window) window ink points - npoints))) - #+ignore - (let ((drawable (medium-drawable medium))) - (when drawable - (let* ((ink (medium-ink medium)) - (transform (sheet-device-transformation sheet)) - (gc - (adjust-ink (decode-ink ink medium) - medium - (medium-line-style medium) - 0 0)) - (len (length list-of-x-and-ys)) - (lines list-of-x-and-ys)) - (if (arrayp lines) - (do ((i 0 (+ 4 i))) - ((= i len)) - (let ((x1 (aref lines i)) - (y1 (aref lines (1+ i))) - (x2 (aref lines (+ 2 i))) - (y2 (aref lines (+ 3 i)))) - (convert-to-device-coordinates transform x1 y1 x2 y2) - (tk::draw-line - drawable gc - x1 y1 x2 y2))) - (loop - (when (null lines) (return nil)) - (let ((x1 (pop lines)) - (y1 (pop lines)) - (x2 (pop lines)) - (y2 (pop lines))) - (convert-to-device-coordinates transform x1 y1 x2 y2) - (tk::draw-line - drawable gc - x1 y1 x2 y2)))))))) + npoints))))) + (defmethod port-draw-rectangle* ((port xt-port) sheet medium x1 y1 x2 y2 filled) @@ -621,6 +719,13 @@ and on color servers, unless using white or black") (cond ((rectilinear-transformation-p transform) (convert-to-device-coordinates transform x1 y1 x2 y2) + ;; Clipping a rectangle is ridiculously easy. + (unless (valid-point-p x1 y1) + (setq x1 (min (max -32000 (the fixnum x1)) 32000)) + (setq y1 (min (max -32000 (the fixnum y1)) 32000))) + (unless (valid-point-p x2 y2) + (setq x2 (min (max -32000 (the fixnum x2)) 32000)) + (setq y2 (min (max -32000 (the fixnum y2)) 32000))) (let ((min-x (min (the fixnum x1) (the fixnum x2))) (min-y (min (the fixnum y1) (the fixnum y2)))) (declare (fixnum min-x min-y)) @@ -659,6 +764,7 @@ and on color servers, unless using white or black") (let ((x (first ps)) (y (second ps))) (convert-to-device-coordinates transform x y) + (discard-illegal-coordinates port-draw-polygon* x y) (minf minx x) (minf miny y) (setf (tk::xpoint-array-x points i) x @@ -670,6 +776,7 @@ and on color servers, unless using white or black") (let ((x (aref ps j)) (y (aref ps (1+ j)))) (convert-to-device-coordinates transform x y) + (discard-illegal-coordinates port-draw-polygon* x y) (minf minx x) (minf miny y) (setf (tk::xpoint-array-x points i) x @@ -705,6 +812,7 @@ and on color servers, unless using white or black") start-angle end-angle filled) (let ((transform (sheet-device-transformation sheet))) (convert-to-device-coordinates transform center-x center-y) + (discard-illegal-coordinates port-draw-ellipse* center-x center-y) (convert-to-device-distances transform radius-1-dx radius-1-dy radius-2-dx radius-2-dy) (when (medium-drawable medium) @@ -731,6 +839,7 @@ and on color servers, unless using white or black") (font (text-style-mapping port (medium-text-style medium))) (ascent (tk::font-ascent font))) (convert-to-device-coordinates transform x y) + (discard-illegal-coordinates port-draw-text* x y) (when towards-x (convert-to-device-coordinates transform towards-x towards-y)) (when (typep string-or-char 'character) @@ -1091,6 +1200,11 @@ and on color servers, unless using white or black") (height (- from-bottom from-top)) (copy-gc (port-copy-gc port))) (when (and from-drawable to-drawable) + (if (port-safe-backing-store port) + ;; Don't bother with no-expose events. + (return-from port-copy-area + (tk::copy-area from-drawable copy-gc from-left from-top + width height to-drawable to-left to-top))) (with-port-event-lock (port) (let ((seq-no 0)) (without-interrupts diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index 538e96b3..36cbe6a2 100644 --- a/tk-silica/xt-silica.lisp +++ b/tk-silica/xt-silica.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-silica.lisp,v 1.29 92/05/26 14:33:35 cer Exp Locker: cer $ +;; $fiHeader: xt-silica.lisp,v 1.30 92/06/16 15:02:26 cer Exp Locker: cer $ (in-package :xm-silica) @@ -30,6 +30,9 @@ (context :reader port-context) (copy-gc :initform nil) (opacities :initform nil) + ;; This next is true for servers like Suns, which (pretty much) always + ;; can safely copy-area without generating graphics-exposures. + (safe-backing-store :initform nil :accessor port-safe-backing-store) (event-lock :initform (clim-sys:make-lock "port event lock") :reader port-event-lock) (rotated-font-cache :initform nil :accessor port-rotated-font-cache)) @@ -90,6 +93,15 @@ (setf (slot-value port 'application-shell) application-shell (slot-value port 'context) context (slot-value port 'display) display) + (let* ((screen (x11:xdefaultscreenofdisplay display)) + (bs-p (not (zerop (x11::screen-backing-store screen)))) + (su-p (not (zerop (x11::screen-save-unders screen)))) + (vendor (ff:char*-to-string (x11::display-vendor display)))) + (if (and bs-p su-p + ;; An amazing crock. XXX + (not (search "Network Computing Devices" vendor)) + (not (search "Tektronix" vendor))) + (setf (slot-value port 'safe-backing-store) t))) (initialize-xlib-port port display))))) (defvar *xt-font-families* '((:fix "*-*-courier-*-*-*-*-*-*-*-*-*-*-*-*") @@ -311,9 +323,10 @@ (sheet-mirror-resized-callback widget nil event sheet) nil) - ;; This is handled by the expose callback. - (:expose - nil) + (:no-expose nil) + (:graphics-expose + ;; Tricky! + (setf (port-safe-backing-store (port sheet)) nil)) (:expose ;; This gets called only for an XmBulletinBoard widget. (sheet-mirror-exposed-callback diff --git a/tk/convenience.lisp b/tk/convenience.lisp index e0b61d4b..aa650dc8 100644 --- a/tk/convenience.lisp +++ b/tk/convenience.lisp @@ -20,39 +20,39 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: convenience.lisp,v 1.8 92/04/21 20:27:27 cer Exp Locker: cer $ +;; $fiHeader: convenience.lisp,v 1.9 92/04/28 09:24:58 cer Exp $ (in-package :tk) - ; -(defmacro define-convenience-class (class superclasses entry-point) - (let ((c-function-name - (intern (substitute #\_ #\- - (lispify-tk-name entry-point :package nil))))) - `(progn - (defforeign ',c-function-name :entry-point ,entry-point) - (defclass ,class ,superclasses - () - (:metaclass xt-class)) - (defmethod make-widget ((w ,class) &rest args &key (managed t) - (name "") - parent &allow-other-keys) - (remf :name args) - (remf :parent args) - (remf :managed args) - (let* ((arglist (make-arglist-for-class - (find-class ',class) - parent - args)) - (o - (,c-function-name - parent - (string-to-char* name) - arglist - (truncate (length arglist) 2)))) - (when managed - (xt_manage_child o)) - o))))) +(eval-when (eval compile) + (defmacro define-convenience-class (class superclasses entry-point) + (let ((c-function-name + (intern (substitute #\_ #\- + (lispify-tk-name entry-point :package nil))))) + `(progn + (defforeign ',c-function-name :entry-point ,entry-point) + (defclass ,class ,superclasses + () + (:metaclass xt-class)) + (defmethod make-widget ((w ,class) &rest args &key (managed t) + (name "") + parent &allow-other-keys) + (remf :name args) + (remf :parent args) + (remf :managed args) + (let* ((arglist (make-arglist-for-class + (find-class ',class) + parent + args)) + (o + (,c-function-name + parent + (string-to-char* name) + arglist + (truncate (length arglist) 2)))) + (when managed + (xt_manage_child o)) + o)))))) (define-convenience-class xm-menu-bar (xm-row-column) "_XmCreateMenuBar") (define-convenience-class xm-pulldown-menu (xm-row-column) "_XmCreatePulldownMenu") diff --git a/tk/gcontext.lisp b/tk/gcontext.lisp index a69ebee6..755101d6 100644 --- a/tk/gcontext.lisp +++ b/tk/gcontext.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: gcontext.lisp,v 1.16 92/05/22 19:26:21 cer Exp Locker: cer $ +;; $fiHeader: gcontext.lisp,v 1.17 92/05/26 14:32:53 cer Exp $ (in-package :tk) @@ -91,7 +91,7 @@ name) :x11) gc-values) - (,encoder nv ,@args)) + (,encoder gc nv ,@args)) (x11:xchangegc (object-display gc) @@ -104,6 +104,7 @@ (defmacro define-gc-reader (name decoder &rest args) `(defmethod ,(intern (format nil "~A-~A" 'gcontext name)) ((gc gcontext)) (,decoder + gc (,(intern (format nil "~A~A" '_xgc-values- name) :x11) gc) ,@args))) @@ -186,40 +187,42 @@ ;(define-gc-accessor background (encode-pixel decode-pixel)) (defmethod gcontext-foreground ((gc gcontext)) - (decode-pixel (x11::_xgc-values-foreground gc))) + (decode-pixel gc (x11::_xgc-values-foreground gc))) (defmethod gcontext-background ((gc gcontext)) - (decode-pixel (x11::_xgc-values-background gc))) + (decode-pixel gc (x11::_xgc-values-background gc))) (defmethod (setf gcontext-foreground) (nv (gc gcontext)) (x11:xsetforeground (object-display gc) gc - (encode-pixel nv))) + (encode-pixel gc nv))) (defmethod (setf gcontext-background) (nv (gc gcontext)) (x11:xsetbackground (object-display gc) gc - (encode-pixel nv))) + (encode-pixel gc nv))) (define-gc-accessor line-width (encode-card16 decode-card16)) (defmethod gcontext-fill-style ((gc gcontext)) (decode-fill-style - (x11::_xgc-values-fill-style gc))) + gc (x11::_xgc-values-fill-style gc))) -(defun decode-fill-style (x) - (declare (optimize (speed 3) (safety 0))) +(defun decode-fill-style (gc x) + (declare (optimize (speed 3) (safety 0)) + (ignore gc)) (case x (0 :solid) (1 :tiled) (2 :stippled) (3 :opaque-stippled))) -(defun encode-fill-style (x) - (declare (optimize (speed 3) (safety 0))) +(defun encode-fill-style (gc x) + (declare (optimize (speed 3) (safety 0)) + (ignore gc)) (ecase x (:solid 0) (:tiled 1) @@ -230,14 +233,15 @@ (x11:xsetfillstyle (object-display gc) gc - (encode-fill-style nv))) + (encode-fill-style gc nv))) (define-gc-accessor fill-rule (encode-enum decode-enum) '(:even-odd :winding)) (define-gc-accessor tile (encode-pixmap decode-pixmap)) (define-gc-accessor stipple (encode-pixmap decode-pixmap)) -(defun encode-pixmap (x) +(defun encode-pixmap (gc x) + (declare (ignore gc)) x) (define-gc-accessor ts-x-origin (encode-int16 decode-int16)) @@ -247,8 +251,9 @@ (define-gc-accessor font (encode-font decode-font)) (define-gc-accessor cap-style (encode-cap-style decode-cap-style)) -(defun encode-cap-style (x) - (declare (optimize (speed 3) (safety 0))) +(defun encode-cap-style (gc x) + (declare (optimize (speed 3) (safety 0)) + (ignore gc)) (ecase x (:not-last 0) (:butt 1) @@ -257,8 +262,9 @@ (define-gc-accessor join-style (encode-join-style decode-join-style)) -(defun encode-join-style (x) - (declare (optimize (speed 3) (safety 0))) +(defun encode-join-style (gc x) + (declare (optimize (speed 3) (safety 0)) + (ignore gc)) (ecase x (:miter 0) (:round 1) @@ -285,13 +291,19 @@ #.boole-nor #.boole-eqv #.boole-c2 #.boole-orc2 #.boole-c1 #.boole-orc1 #.boole-nand #.boole-set)) -(defun encode-function (x) +(defun encode-function (gc x) + (declare (ignore gc)) (or (position x *boole-vector*) (error "Cannot encode gc function: ~S" x))) -(defun encode-card32 (x) x) -(defun encode-card16 (x) x) -(defun encode-enum (x y) +(defun encode-card32 (gc x) + (declare (ignore gc)) + x) +(defun encode-card16 (gc x) + (declare (ignore gc)) + x) +(defun encode-enum (gc x y) + (declare (ignore gc)) (or (position x y) (error "cannot find ~s in ~s" x y))) @@ -302,9 +314,9 @@ (object-display gc) gc line-width - (encode-line-style line-style) - (encode-cap-style cap-style) - (encode-join-style join-style))) + (encode-line-style gc line-style) + (encode-cap-style gc cap-style) + (encode-join-style gc join-style))) (defmethod (setf gcontext-clip-mask) ((nv (eql :none)) (gc gcontext)) (x11:xsetclipmask @@ -353,8 +365,9 @@ (define-gc-accessor line-style (encode-line-style decode-style)) -(defun encode-line-style (x) - (declare (optimize (speed 3) (safety 0))) +(defun encode-line-style (gc x) + (declare (optimize (speed 3) (safety 0)) + (ignore gc)) (ecase x (:solid 0) (:dash 1) @@ -362,7 +375,7 @@ (defmethod (setf gcontext-dashes) (nv (gc gcontext)) (multiple-value-bind (n v) - (encode-dashes nv) + (encode-dashes gc nv) (x11:xsetdashes (object-display gc) gc @@ -371,8 +384,9 @@ n))) -(defun encode-dashes (nv) - (declare (optimize (speed 3) (safety 0))) +(defun encode-dashes (gc nv) + (declare (optimize (speed 3) (safety 0)) + (ignore gc)) (let* ((n (length nv)) (v (excl:make-static-array n :element-type '(unsigned-byte 8)))) (declare (fixnum n) @@ -391,10 +405,14 @@ (values n v))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun encode-int16 (x) x) +(defun encode-int16 (gc x) + (declare (ignore gc)) + x) -(defun encode-font (x) (x11:xfontstruct-fid x)) +(defun encode-font (gc x) + (declare (ignore gc)) + (x11:xfontstruct-fid x)) @@ -402,10 +420,11 @@ ;;; wrappers -(defun decode-card16 (x) x) +(defun decode-card16 (gc x) + (declare (ignore gc)) + x) -(defun decode-font (x) - (declare (special gc)) +(defun decode-font (gc x) (if (= x #16rffffffff) (error "cannot decode font") (let* ((display (object-display gc)) @@ -413,21 +432,29 @@ (or font (query-font display x))))) -(defun decode-pixmap (x) - (declare (special gc)) +(defun decode-pixmap (gc x) (and (/= #16rffffffff x) (intern-object-xid x 'pixmap (object-display gc)))) -(defun decode-clip-mask (x) x) -(defun decode-enum (x y) +(defun decode-clip-mask (gc x) + (declare (ignore gc)) + x) +(defun decode-enum (gc x y) + (declare (ignore gc)) (or (elt y x) (error "cannot find ~s in ~s" x y))) -(defun decode-card32 (x) x) -(defun decode-dashes (x) x) -(defun decode-int16 (x) x) +(defun decode-card32 (gc x) + (declare (ignore gc)) + x) +(defun decode-dashes (gc x) + (declare (ignore gc)) + x) +(defun decode-int16 (gc x) + (declare (ignore gc)) + x) ;;;;;;;;;;;;;;;;;;; @@ -482,11 +509,13 @@ (print gc)) |# -(defun decode-pixel (x) x) +(defun decode-pixel (gc x) + (declare (ignore gc)) + x) -(defmethod encode-pixel ((x integer)) +(defmethod encode-pixel (gc (x integer)) + (declare (ignore gc)) x) -(defmethod encode-pixel ((x color)) - (declare (special gc)) +(defmethod encode-pixel (gc (x color)) (allocate-color (default-colormap (object-display gc) 0) x)) diff --git a/tk/graphics.lisp b/tk/graphics.lisp index 24892bbb..213aeae2 100644 --- a/tk/graphics.lisp +++ b/tk/graphics.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: graphics.lisp,v 1.7 92/04/15 11:44:45 cer Exp $ +;; $fiHeader: graphics.lisp,v 1.8 92/05/13 17:10:18 cer Exp $ (in-package :tk) @@ -62,20 +62,22 @@ filled) (multiple-value-bind (x-radius y-radius) (cond ((and (= radius-1-dx 0) (= radius-2-dy 0)) - (values (abs radius-2-dx) (abs radius-1-dy))) + (values (round (abs radius-2-dx)) + (round (abs radius-1-dy)))) ((and (= radius-2-dx 0) (= radius-1-dy 0)) - (values (abs radius-1-dx) (abs radius-2-dy))) + (values (round (abs radius-1-dx)) + (round (abs radius-2-dy)))) (t (let ((s-1 (+ (* radius-1-dx radius-1-dx) (* radius-1-dy radius-1-dy))) (s-2 (+ (* radius-2-dx radius-2-dx) (* radius-2-dy radius-2-dy)))) (if (= s-1 s-2) - (let ((r (truncate (sqrt s-1)))) + (let ((r (round (sqrt s-1)))) (values r r)) ;; Degrade to drawing a rectilinear ellipse - (values (truncate (sqrt s-1)) - (truncate (sqrt s-2))))))) + (values (round (sqrt s-1)) + (round (sqrt s-2))))))) (setq start-angle (round (* start-angle (/ (* 360 64) (* 2 pi))))) (setq end-angle (round (* end-angle (/ (* 360 64) (* 2 pi))))) (if (> end-angle start-angle) diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp index 3a7c6856..a7ad37ef 100644 --- a/tk/make-classes.lisp +++ b/tk/make-classes.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: make-classes.lisp,v 1.18 92/05/22 19:26:24 cer Exp Locker: cer $ +;; $fiHeader: make-classes.lisp,v 1.19 92/06/03 18:18:11 cer Exp Locker: cer $ (in-package :tk) @@ -33,10 +33,74 @@ (defun get-foreign-variable-value (x) (class-array (get-entry-point-value x) 0)) +;; This is only called to fill in the cache, so it can be (real) slow. +(defun get-resource-internal (class fn resource-class resource-name) + (let ((x (make-array 1 :element-type '(unsigned-byte 32))) + (y (make-array 1 :element-type '(unsigned-byte 32)))) + (funcall fn (class-handle class) x y) + (let ((resources (aref x 0)) + (n (aref y 0))) + (dotimes (i n) + (let* ((res (x-resource-list resources i)) + (original-name (x-resource-name res)) + (name (lispify-resource-name (char*-to-string original-name)))) + (if (equal name resource-name) + (let ((*package* (find-package :tk))) + (return-from get-resource-internal + (make-instance + resource-class + :original-name original-name + :name name + :class (lispify-resource-class + (char*-to-string (x-resource-class res))) + :type (lispify-resource-type + (char*-to-string (x-resource-type res))))))))))) + #+ignore + (error "No resource named ~s found for class ~s" resource-name class) + ;; Error is actually caught in calling functions. + #-ignore + nil) + +(defmethod find-class-resource ((class xt-class) resource-name) + (declare (optimize (speed 3) (safety 0))) + (with-slots (cached-resources specially-hacked-resources) class + (let ((value (gethash resource-name cached-resources :not-found))) + (if (not (eq value :not-found)) + value ; Never had it, never will + (setf (gethash resource-name cached-resources) + (if* (find resource-name specially-hacked-resources + :key #'resource-name) + thenret + else (get-resource-internal class + #'xt_get_resource_list + 'resource + resource-name))))))) + +(defmethod find-class-constraint-resource ((class xt-class) resource-name) + (declare (optimize (speed 3) (safety 0))) + (with-slots (cached-constraint-resources) class + (let ((value (gethash resource-name cached-constraint-resources :not-found))) + (if (not (eq value :not-found)) + value ; Never had it, never will + (setf (gethash resource-name cached-constraint-resources) + (get-resource-internal class + #'xt_get_constraint_resource_list + 'constraint-resource + resource-name)))))) + + + +;; These next five aren't used except maybe by describe-widget. +(defmethod class-resources ((class xt-class)) + (get-resource-list class)) + +(defmethod class-constraint-resources ((class xt-class)) + (get-constraint-resource-list class)) + (defun get-resource-list-internal (class fn resource-class) (let ((x (make-array 1 :element-type '(unsigned-byte 32))) (y (make-array 1 :element-type '(unsigned-byte 32)))) - (funcall fn class x y) + (funcall fn (class-handle class) x y) (let ((resources (aref x 0)) (n (aref y 0)) (r nil)) @@ -60,7 +124,7 @@ (get-resource-list-internal class #'xt_get_constraint_resource_list 'constraint-resource)) - + (defclass xt-root-class (display-object) ((events :initform nil :accessor widget-event-handler-data) @@ -88,103 +152,56 @@ (defmethod print-object ((r basic-resource) s) (print-unreadable-object (r s :type t :identity nil) - (format s "~A,~A " - (resource-name r) - (resource-type r)))) + (format s "~A,~A " + (if (slot-boundp r 'name) + (resource-name r) + "..UNBOUND..") + (if (slot-boundp r 'type) + (resource-type r) + "..UNBOUND..")))) (defun lispify-resource-name (x) (lispify-tk-name x :package :keyword)) (defun lispify-resource-class (x) (lispify-tk-name x)) (defun lispify-resource-type (x) (lispify-tk-name x)) -(defclass resource (basic-resource) - ()) +(defclass resource (basic-resource) + ()) - (defclass constraint-resource (basic-resource) - ()) + ()) (defun make-classes (classes) - (let ((direct-resources nil) - (all-resources nil)) - - - (dolist (class-ep classes) - (let ((h (get-foreign-variable-value class-ep))) - (push (list h - class-ep - (get-resource-list h) - (get-constraint-resource-list h)) - direct-resources))) - - (setq direct-resources (nreverse direct-resources)) + (let ((clist nil)) (dolist (class-ep classes) (format excl:*initial-terminal-io* ";; Initializing class ~s~%" class-ep) (let ((h (get-foreign-variable-value class-ep))) - (xt_initialize_widget_class h) - (push (list h - (get-resource-list h) - (get-constraint-resource-list h)) - all-resources))) + (push (list h class-ep) clist) + (xt_initialize_widget_class h))) + (setq clist (nreverse clist)) - (do ((directs direct-resources (cdr directs)) + (do ((cs clist (cdr cs)) r) - ((null directs) + ((null cs) (nreverse r)) - (destructuring-bind - ((handle class-ep direct-resources direct-constraints) . ignore) - directs - (declare (ignore ignore)) - (destructuring-bind - (handle all-resources all-constraints) - (assoc handle all-resources) + (destructuring-bind (handle class-ep) (car cs) (let ((class (clos::ensure-class (lispify-class-name (widget-class-name handle)) :direct-superclasses (list (if (zerop (xt-class-superclass handle)) 'xt-root-class - (lispify-class-name (widget-class-name - (xt-class-superclass handle))))) + (lispify-class-name + (widget-class-name + (xt-class-superclass handle))))) :direct-slots nil :metaclass 'xt-class - :direct-resources direct-resources - :direct-constraints direct-constraints - :resources all-resources - :constraints all-constraints :entry-point class-ep - :foreign-address (get-foreign-variable-value class-ep)))) + :foreign-address (get-foreign-variable-value class-ep)))) (register-address class) - (add-accessors-for-toolkit-class class) - (push class r))))))) - + (push class r)))))) -(defun add-accessors-for-toolkit-class (class) - #+ignore - (dolist (r (class-direct-resources class)) - (let* ((rname (resource-name r)) - (name (intern (format nil "~A-~A" 'widget rname)))) - (setq name (case name - (widget-window 'widget-stub-window) - (t name))) - (add-method - (ensure-generic-function name) - (make-instance 'clos::standard-method - :lambda-list '(x) - :qualifiers nil - :specializers (list class) - :function #'(lambda (x) - (get-values x rname)))) - (add-method - (ensure-generic-function `(setf ,name)) - (make-instance 'clos::standard-method - :lambda-list '(nv x) - :qualifiers nil - :specializers (list (find-class t) class) - :function #'(lambda (nv x) - (set-values x rname nv) - nv)))))) (defun define-toolkit-classes (&rest classes) (make-classes (remove-duplicates @@ -231,16 +248,6 @@ package) string))) -(defun collect-resource-types (c) - (let (ts) - (clos::map-over-subclasses - #'(lambda (class) - (dolist (r (append (class-constraint-resources class) (class-resources class))) - (pushnew (resource-type r) ts))) - c) - ts)) - - (defun-c-callable toolkit-error-handler ((message :unsigned-long)) (error "toolkit error: ~a" (char*-to-string message))) @@ -249,15 +256,10 @@ (let ((*error-output* excl:*initial-terminal-io*)) (warn "toolkit warning: ~a" (char*-to-string message)))) - +;; This is a terrible hack used to compensate for bugs/inconsistencies +;; in the XM and OLIT toolkits. (defun add-resource-to-class (class resource) (clos::map-over-subclasses #'(lambda (c) - (push - resource - (slot-value c 'resources))) + (pushnew resource (slot-value c 'specially-hacked-resources))) class)) - -#| -(make-widget class parent . resources) -|# diff --git a/tk/meta-tk.lisp b/tk/meta-tk.lisp index 533c86f3..f9e56b10 100644 --- a/tk/meta-tk.lisp +++ b/tk/meta-tk.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: meta-tk.lisp,v 1.7 92/03/30 17:51:45 cer Exp $ +;; $fiHeader: meta-tk.lisp,v 1.8 92/05/13 17:10:23 cer Exp $ (in-package :tk) @@ -29,18 +29,15 @@ (defclass xt-class (standard-class ff:foreign-pointer) ((entry-point :initarg :entry-point :reader class-entry-point) - (resources :initform nil - :initarg :resources - :reader class-resources) - (constraint-resources :initform nil - :initarg :constraints - :reader class-constraint-resources) - (direct-resources :initform nil - :initarg :direct-resources - :reader class-direct-resources) - (constraint-resources :initform nil - :initarg :direct-constraints - :reader class-direct-constraint-resources) + ;; Resources are now looked up on the fly, and cached lazily one by one. + ;; Note that direct resources and direct constraint resources are no + ;; longer available, since initializing the XT widget class removes the + ;; ability to determine them lazily. + (cached-resources :initform (make-hash-table :test #'equal) + :type hash-table) + (specially-hacked-resources :initform nil) ; See add-resource-to-class. + (cached-constraint-resources :initform (make-hash-table :test #'equal) + :type hash-table) (get-values-cache :initform (make-hash-table :test #'equal) :type hash-table :reader class-get-values-cache) @@ -53,15 +50,7 @@ (clos::finalize-inheritance class)) (dolist (c (clos::class-precedence-list class) (error "Cannot get handle for class" class)) - (when (typep c 'xt-class) + (when (and (typep c 'xt-class) + (not (zerop (ff:foreign-pointer-address c)))) (return c)))) -(defmethod clos::finalize-inheritance :after ((class xt-class)) - (let ((super (car (clos::class-direct-superclasses class)))) - (when (typep super 'xt-class) - (unless (slot-value class 'resources) - (setf (slot-value class 'resources) - (slot-value super 'resources))) - (unless (slot-value class 'constraint-resources) - (setf (slot-value class 'constraint-resources) - (slot-value super 'constraint-resources)))))) diff --git a/tk/pkg.lisp b/tk/pkg.lisp index cbd9cce1..a73aec7a 100644 --- a/tk/pkg.lisp +++ b/tk/pkg.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: pkg.lisp,v 1.8 92/04/21 20:27:39 cer Exp $ +;; $fiHeader: pkg.lisp,v 1.9 92/05/13 17:10:24 cer Exp $ (defpackage :tk ;;-- No we really need @@ -36,5 +36,13 @@ #:top-level-shell #:popup #:manage-child + #:card32 + #:card29 + #:card24 + #:card16 + #:card8 + #:int32 + #:int16 + #:int8 )) diff --git a/tk/resources.lisp b/tk/resources.lisp index 2f5d5b56..297e9ed9 100644 --- a/tk/resources.lisp +++ b/tk/resources.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: resources.lisp,v 1.22 92/05/22 19:26:30 cer Exp Locker: cer $ +;; $fiHeader: resources.lisp,v 1.23 92/06/16 15:01:07 cer Exp Locker: cer $ (in-package :tk) @@ -45,6 +45,7 @@ (defconstant xm_string_default_char_set "") (defmethod convert-resource-in (class (type (eql 'xm-string)) value) + (declare (ignore class)) (and (not (zerop value)) (with-ref-par ((string 0)) ;;--- I think we need to read the book about @@ -263,16 +264,14 @@ (defun fill-sv-cache (parent-class class resources) (let* ((len (length resources)) - (class-resources (class-resources class)) - (constraint-resources (and parent-class (class-constraint-resources parent-class))) (arglist (make-xt-arglist :number len)) (rds nil) (constraint-resource-used nil) (i 0)) (dolist (r resources) - (let ((resource (or (find r class-resources :key #'resource-name :test #'eq) + (let ((resource (or (find-class-resource class r) (psetq constraint-resource-used t) - (find r constraint-resources :key #'resource-name :test #'eq)))) + (and parent-class (find-class-constraint-resource parent-class r))))) (unless resource (error "No such resource ~S for widget of class ~S " r class)) @@ -328,9 +327,6 @@ (defun make-arglist-for-class (class parent args) (declare (optimize (speed 3) (safety 0))) (do ((new-args nil) - (resources-1 (class-resources class)) - (resources-2 (and parent (class-constraint-resources - (class-of parent)))) keyword value) ((null args) @@ -339,8 +335,8 @@ :initial-contents (nreverse new-args))) (setq keyword (pop args) value (pop args)) - (let ((resource (or (find keyword resources-1 :key #'resource-name) - (find keyword resources-2 :key #'resource-name)))) + (let ((resource (or (find-class-resource class keyword) + (find-class-constraint-resource class keyword)))) (when resource (push (resource-original-name resource) new-args) (let ((type (resource-type resource))) @@ -418,8 +414,6 @@ (defun fill-gv-cache (parent-class class resources) (setq resources (copy-list resources)) ; So get-values can declare dynamic-extent (let* ((len (length resources)) - (class-resources (class-resources class)) - (constraint-resources (and parent-class (class-constraint-resources parent-class))) (arglist (make-xt-arglist :number len)) (rds nil) (constraint-resource-used nil) @@ -427,9 +421,10 @@ (dotimes (j len) (setf (xt-arglist-value arglist j) (excl::malloc 8))) ; A crock... (dolist (r resources) - (let ((resource (or (find r class-resources :key #'resource-name :test #'eq) + (let ((resource (or (find-class-resource class r) (psetq constraint-resource-used t) - (find r constraint-resources :key #'resource-name :test #'eq)))) + (and parent-class + (find-class-constraint-resource parent-class r))))) (unless resource (error "No such resource ~S for widget of class ~S " r class)) @@ -556,7 +551,7 @@ (defmethod convert-resource-out ((parent t) (type (eql 'xm-background-pixmap)) value) (etypecase value (pixmap - (encode-pixmap value)))) + (encode-pixmap nil value)))) (defmethod convert-resource-out ((widget t) (type (eql 'widget)) x) x) @@ -569,7 +564,7 @@ -(defmethod convert-resource-out (parent (type (eql 'xm-string-table)) value) +(defmethod convert-resource-out ((parent t) (type (eql 'xm-string-table)) value) (if value (do* ((n (length value)) ;;--- Malloc alert @@ -612,7 +607,7 @@ ;;-- This is a problem cos we dont know the number of items -(defmethod convert-resource-in (parent (type (eql 'xm-string-table)) value) +(defmethod convert-resource-in ((parent t) (type (eql 'xm-string-table)) value) value) (defun convert-xm-string-table-in (parent table n) @@ -621,7 +616,7 @@ (push (convert-resource-in parent 'xm-string (x-arglist table i)) r)))) -(defmethod convert-resource-out (parent (type (eql 'proc)) value) +(defmethod convert-resource-out ((parent t) (type (eql 'proc)) value) (etypecase value ;;-- Should check to see if its registered (integer value))) diff --git a/tk/xlib.lisp b/tk/xlib.lisp index 964eda6f..f406e688 100644 --- a/tk/xlib.lisp +++ b/tk/xlib.lisp @@ -20,10 +20,26 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xlib.lisp,v 1.18 92/05/22 19:26:33 cer Exp Locker: cer $ +;; $fiHeader: xlib.lisp,v 1.19 92/05/26 14:32:55 cer Exp $ (in-package :tk) +(deftype card32 () '(unsigned-byte 32)) + +(deftype card29 () '(unsigned-byte 29)) + +(deftype card24 () '(unsigned-byte 24)) + +(deftype card16 () '(unsigned-byte 16)) + +(deftype card8 () '(unsigned-byte 8)) + +(deftype int32 () '(signed-byte 32)) + +(deftype int16 () '(signed-byte 16)) + +(deftype int8 () '(signed-byte 8)) + ;;; Pathetic clos interface to Xlib (defclass display-object (ff:foreign-pointer) diff --git a/utils/lisp-utilities.lisp b/utils/lisp-utilities.lisp index cb9b02c4..8e8d00dc 100644 --- a/utils/lisp-utilities.lisp +++ b/utils/lisp-utilities.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: lisp-utilities.lisp,v 1.10 92/05/13 17:10:40 cer Exp $ +;; $fiHeader: lisp-utilities.lisp,v 1.11 92/05/26 14:33:02 cer Exp $ (in-package :clim-utils) @@ -153,18 +153,17 @@ (defmacro convert-to-device-coordinates (transform &body positions) (assert (evenp (length positions)) (positions) "There must be an even number of elements in ~S" positions) - (let ((forms nil) - (nx (gensym)) - (ny (gensym))) + (let ((forms nil)) (loop (when (null positions) (return `(progn ,@(nreverse forms)))) (let* ((x (pop positions)) (y (pop positions))) - (push `(multiple-value-bind (,nx ,ny) - (transform-position ,transform ,x ,y) - (setq ,x (fix-coordinate ,nx) - ,y (fix-coordinate ,ny))) + (push `(progn + (multiple-value-setq (,x ,y) + (transform-position ,transform ,x ,y)) + (setq ,x (fix-coordinate ,x) + ,y (fix-coordinate ,y))) forms))))) ;; @@ -173,18 +172,16 @@ (defmacro convert-to-device-distances (transform &body positions) (assert (evenp (length positions)) (positions) "There must be an even number of elements in ~S" positions) - (let ((forms nil) - (nx (gensym)) - (ny (gensym))) + (let ((forms nil)) (loop (when (null positions) (return `(progn ,@(nreverse forms)))) (let* ((x (pop positions)) (y (pop positions))) - (push `(multiple-value-bind (,nx ,ny) + (push `(multiple-value-bind (,x ,y) (transform-distance ,transform ,x ,y) - (setq ,x (fix-coordinate ,nx) - ,y (fix-coordinate ,ny))) + (setq ,x (fix-coordinate ,x) + ,y (fix-coordinate ,y))) forms))))) -- GitLab