diff --git a/Makefile b/Makefile index 92090a1a57753598f45fac711e21b702542cc217..0021f3b928925151eb6b319f04f7ffa1e667ada8 100644 --- a/Makefile +++ b/Makefile @@ -1,8 +1,8 @@ -# $fiHeader: Makefile,v 1.26 92/05/06 15:37:50 cer Exp Locker: cer $ +# $fiHeader: Makefile,v 1.27 92/05/07 13:13:41 cer Exp Locker: cer $ # # Makefile for CLIM 2.0 # -CL = /vapor/usr/tech/cer/cl/src/dcl +CL = /usr/tech/cer/cl/src/dcl DUMP-CL = $(CL) CLOPTS = -qq @@ -27,6 +27,11 @@ LOAD_XREF_INFO=nil SPEED = 3 SAFETY = 1 +CFLAGS = -O -D_NO_PROTO -DSTRINGS_ALIGNED -DNO_REGEX -DNO_ISDIR -DUSE_RE_COMP -DUSER_GETWD -I/x11/motif-1.1/lib + +OLDSPACE = 15000000 +NEWSPACE = 5000000 + # Name of dumped lisp CLIM = ./slim CLIM-SMALL = ./slim-small @@ -43,13 +48,14 @@ ECHO = /bin/echo MV = /usr/fi/mv-nfs TAGS = /usr/fi/lib/emacs/etc/etags TMP = /usr/tmp + SRC_FILES = */*.lisp *.lisp Makefile */Makefile misc/make-stub-file \ misc/undefinedsymbols misc/undefinedsymbols.olit \ misc/undefinedsymbols.motif misc/undefinedsymbols.xt DEST=/dev/null -CL_SRC=/vapor/usr/tech/cer/cl/src +CL_SRC=/usr/tech/cer/cl/src OPENWINHOME=/usr/openwin-3.0 #MOTIFHOME=/usr/motif @@ -82,8 +88,8 @@ XM_UNDEFS=misc/undefinedsymbols.motif OL_UNDEFS=misc/undefinedsymbols.olit CLIMFASLS= climg.fasl climol.fasl climxm.fasl clim-debug.fasl -CLIMOBJS= stub-x.o stub-xt.o stub-motif.o stub-olit.o -FCLIMOBJS= `pwd`/stub-motif.o `pwd`/stub-olit.o `pwd`/stub-x.o `pwd`/stub-xt.o +CLIMOBJS= stub-x.o stub-xt.o stub-motif.o stub-olit.o xlibsupport.o MyDrawingA.o +FCLIMOBJS= `pwd`/stub-motif.o `pwd`/stub-olit.o `pwd`/stub-x.o `pwd`/stub-xt.o `pwd`/xlibsupport.o `pwd`/MyDrawingA.o # @@ -424,13 +430,13 @@ makeclimobjs : $(CLIMOBJS) ################## Lower level Makefile stuff -ol-dcl : stub-x.o stub-xt.o stub-olit.o +ol-dcl : stub-x.o stub-xt.o stub-olit.o xlibsupport.o MyDrawingA.o cd $(CL_SRC) ; /bin/rm -f ucl ;\ - make ucl_xtras='$(PWD)/stub-x.o $(PWD)/stub-xt.o $(PWD)/stub-olit.o $(LIBXOL) $(OLXLIBS)' dcl + make initial_oldspace=$(OLDSPACE) oldspace=$(OLDSPACE) newspace=$(NEWSPACE) ucl_xtras='$(PWD)/stub-x.o $(PWD)/stub-xt.o $(PWD)/stub-olit.o $(PWD)/xlibsupport.o $(PWD)/MyDrawingA.o $(LIBXOL) $(OLXLIBS)' dcl -xm-dcl : stub-x.o stub-xt.o stub-motif.o +xm-dcl : stub-x.o stub-xt.o stub-motif.o xlibsupport.o MyDrawingA.o cd $(CL_SRC) ; /bin/rm -f ucl ;\ - make ucl_xtras='$(PWD)/stub-x.o $(PWD)/stub-xt.o $(PWD)/stub-motif.o $(MOTIFLIB) $(XTLIB) $(XLIB)' dcl + make initial_oldspace=$(OLDSPACE) oldspace=$(OLDSPACE) newspace=$(NEWSPACE) ucl_xtras='$(PWD)/stub-x.o $(PWD)/stub-xt.o $(PWD)/stub-motif.o $(PWD)/xlibsupport.o $(PWD)/MyDrawingA.o $(MOTIFLIB) $(XTLIB) $(XLIB)' dcl dcl : cd $(CL_SRC) ; /bin/rm -f ucl ;\ @@ -449,6 +455,12 @@ stub-x.c : $(UNDEFS) $(OL_UNDEFS) misc/make-stub-file stub-xt.c : $(XT_UNDEFS) misc/make-stub-file misc/make-stub-file "void ___lisp_load_xt_stub ()" $(XT_UNDEFS) > stub-xt.c +xlibsupport.o : xlib/xlibsupport.c + $(CC) -c $(CFLAGS) -o xlibsupport.o xlib/xlibsupport.c + +MyDrawingA.o: misc/MyDrawingA.c + $(CC) -c $(CFLAGS) -o MyDrawingA.o misc/MyDrawingA.c + FRC : xm-composer : xm-dcl diff --git a/clim/frames.lisp b/clim/frames.lisp index ad6f3fa5111fa97525419ec3be007472453f777f..9b5964fc001db06e4acc871c3533074458e8ff8e 100644 --- a/clim/frames.lisp +++ b/clim/frames.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: frames.lisp,v 1.19 92/05/07 13:12:14 cer Exp Locker: cer $ +;; $fiHeader: frames.lisp,v 1.20 92/05/12 18:24:58 cer Exp Locker: cer $ (in-package :clim-internals) @@ -359,7 +359,7 @@ (error "Invalid pane specification: ~S" (list* name code rest))))) -(defmethod find-pane-class-constructor ((typep t) &rest options) +(defmethod find-pane-class-constructor ((type t) &rest options) (error "Unknown pane type ~S with options ~S" type options)) (defmacro define-pane-type (type lambda-list &body body) diff --git a/misc/compile-1.lisp b/misc/compile-1.lisp index 717a3a5e3007b067f2190d8362f58ab1831dcfd2..da85ad8df4194e8b9de05308cdd1f057247cc2ed 100644 --- a/misc/compile-1.lisp +++ b/misc/compile-1.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: compile-1.lisp,v 1.4 92/04/28 09:26:19 cer Exp Locker: cer $ +;; $fiHeader: compile-1.lisp,v 1.5 92/05/07 13:13:46 cer Exp Locker: cer $ (in-package :user) @@ -47,8 +47,10 @@ (let ((*enable-package-locked-errors* nil)) (load "sys/defsystem"))) + + (defun compile-it (sys) - (unless (ignore-errors (defsys::find-system sys)) + (unless (ignore-errors (clim-defsys::find-system sys)) (load "sys/sysdcl")) (clim-defsys::compile-system sys :propagate t) (tenuring diff --git a/misc/dev-load-1.lisp b/misc/dev-load-1.lisp index bab56be6d45a23362f529ba3a3dd099a796dec8d..2b24b04bcf34a104d9b5046b97f3228cbbad4467 100644 --- a/misc/dev-load-1.lisp +++ b/misc/dev-load-1.lisp @@ -20,9 +20,9 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: dev-load-1.lisp,v 1.4 92/04/21 20:28:22 cer Exp Locker: cer $ +;; $fiHeader: dev-load-1.lisp,v 1.5 92/05/07 13:13:47 cer Exp Locker: cer $ -(excl::free (excl::malloc 131072)) +(excl::free (excl::malloc 262145)) (setq *ignore-package-name-case* t) (set-case-mode :case-insensitive-lower) @@ -51,10 +51,10 @@ (load "climol.fasl") (load "clim-debug.fasl"))) #+ignore - (defsys::load-system sys))) + (clim-defsys:load-system sys))) #+ignore - (defsys:update-system sys) + (clim-defsys:update-system sys) ;;-- What would be good is to mark the files in the system as having ;;-- been loaded diff --git a/silica/event.lisp b/silica/event.lisp index 0fec52a8af4bc9e4caea140bef149c96ce8ccd35..e8853bf20c6e73195d03cd5ddeb78f19cbbf5c9a 100644 --- a/silica/event.lisp +++ b/silica/event.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: event.lisp,v 1.9 92/04/15 11:45:08 cer Exp $ +;; $fiHeader: event.lisp,v 1.10 92/05/07 13:11:17 cer Exp Locker: cer $ (in-package :silica) @@ -32,6 +32,12 @@ (defgeneric port-keyboard-input-focus (port)) +(defmethod print-object ((event window-repaint-event) stream) + (with-slots (region) event + (with-bounding-rectangle* (left top right bottom) region + (print-unreadable-object (event stream :type t) + (format stream "/x ~A:~A y ~A:~A/" left right top bottom))))) + (defmethod handle-event (client (event window-repaint-event)) (handle-repaint client nil (window-event-region event))) diff --git a/silica/medium.lisp b/silica/medium.lisp index 889fb34e1a4984700d849d5e484b5273e8ab723e..bc28f171cd0b58b0948a23b3d248e098be4777b8 100644 --- a/silica/medium.lisp +++ b/silica/medium.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: medium.lisp,v 1.9 92/04/10 14:26:37 cer Exp $ +;; $fiHeader: medium.lisp,v 1.10 92/05/07 13:11:25 cer Exp Locker: cer $ (in-package :silica) @@ -15,12 +15,14 @@ (declare (ignore sheet port)) nil) + (defmethod invoke-with-sheet-medium ((sheet sheet) continuation) - (if (sheet-medium sheet) - (funcall continuation (sheet-medium sheet)) + (let ((medium (sheet-medium sheet))) + (if medium + (funcall continuation medium) (with-temporary-medium (medium sheet) (with-sheet-medium-bound (sheet medium) - (funcall continuation medium))))) + (funcall continuation medium)))))) ;; Special-case the one we know is going to work all the time (defmethod invoke-with-sheet-medium ((sheet permanent-medium-sheet-output-mixin) continuation) diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp index 6fcbe2ded8f5172386f3ca57e1aec8fd5ac7d08d..f2c8ade40a38b7e3b34c1d368c6bf74906b88c92 100644 --- a/sys/sysdcl.lisp +++ b/sys/sysdcl.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: sysdcl.lisp,v 1.14 92/04/21 20:28:13 cer Exp Locker: cer $ +;; $fiHeader: sysdcl.lisp,v 1.15 92/05/07 13:13:14 cer Exp Locker: cer $ (in-package #-ANSI-90 "USER" #+ANSI-90 :cl-user) @@ -431,9 +431,9 @@ :load-before-compile (xlib)) ;; General stuff ("pkg") + ("macros") ("xt-defs") ; Used to be 'xtk'. ("foreign-obj") - ("macros") ;; Xlib stuff ("xlib") ("font") diff --git a/test/test-suite.lisp b/test/test-suite.lisp index bb373890a9e5e866f2593d1c570f5018455ad25d..341af84d18d556999f1861ad41742ad21526d4e3 100644 --- a/test/test-suite.lisp +++ b/test/test-suite.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: test-suite.lisp,v 1.18 92/04/30 09:09:40 cer Exp Locker: cer $ +;; $fiHeader: test-suite.lisp,v 1.19 92/05/07 13:13:18 cer Exp Locker: cer $ (in-package :clim-user) diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp index 41aae234e16acb7a409d702c653fdd0f3231f748..82135e094d1d3ba46c04a6e076cdcfc034ea3dfe 100644 --- a/tk-silica/ol-gadgets.lisp +++ b/tk-silica/ol-gadgets.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-gadgets.lisp,v 1.10 92/04/21 20:28:26 cer Exp Locker: cer $ +;; $fiHeader: ol-gadgets.lisp,v 1.11 92/05/07 13:13:51 cer Exp Locker: cer $ (in-package :xm-silica) @@ -136,7 +136,6 @@ :button4-motion :button5-motion :button-motion - :exposure ) 1 'sheet-mirror-event-handler diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index 44a6a90ac853e7bab4fd211de5e3fc79361d13e9..b6f2b5a5f3c00393f53ffa31e1c65293ef0ca70d 100644 --- a/tk-silica/xm-frames.lisp +++ b/tk-silica/xm-frames.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-frames.lisp,v 1.15 92/04/28 09:26:24 cer Exp Locker: cer $ +;; $fiHeader: xm-frames.lisp,v 1.16 92/05/06 15:37:53 cer Exp Locker: cer $ (in-package :xm-silica) @@ -37,10 +37,7 @@ (defmethod establish-wm-protocol-callbacks ((framem motif-frame-manager) frame) (let ((shell (frame-shell frame))) - (tk::set-values shell - :icon-name (frame-pretty-name frame) - :title (frame-pretty-name frame) - :delete-response :do-nothing) + (tk::set-values shell :delete-response :do-nothing) (tk::add-wm-protocol-callback shell :wm-delete-window @@ -319,6 +316,8 @@ (tk::set-values shell :x (fix-coordinate x) :y (fix-coordinate y))))) + + (tk::set-values shell :title (frame-pretty-name frame)) (let ((icon (clim-internals::frame-icon frame))) (flet ((decode-pixmap (x) (etypecase x @@ -330,9 +329,12 @@ (decode-gadget-background medium sheet x)))))))) (destructuring-bind (&key name pixmap clipping-mask) icon - (when name + ;;-- Dialog shells do not have :icon-name resource + (when (and name (typep shell 'tk::top-level-shell)) (tk::set-values shell :icon-name name)) (when pixmap (tk::set-values shell :icon-pixmap (decode-pixmap pixmap))) (when clipping-mask (tk::set-values shell :clip-mask (decode-pixmap clipping-mask)))))))) + + diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index a7a8f68d651094d9ab723fb900cc50976ab164a6..120fc766ebbff4e1ce60d0c8835de98b124370f7 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-gadgets.lisp,v 1.28 92/05/07 13:13:52 cer Exp Locker: cer $ +;; $fiHeader: xm-gadgets.lisp,v 1.29 92/05/12 18:25:22 cer Exp Locker: cer $ (in-package :xm-silica) @@ -175,7 +175,7 @@ (sheet motif-push-button)) (values 'tk::xm-push-button nil)) -(defmethod add-sheet-callbacks ((port motif-port) (sheet t) (widget tk::xm-drawing-area)) +(defmethod add-sheet-callbacks ((port motif-port) (sheet t) (widget tk::xm-my-drawing-area)) (tk::add-callback widget :expose-callback 'sheet-mirror-exposed-callback @@ -195,7 +195,6 @@ :button4-motion :button5-motion :button-motion - :exposure ) 1 'sheet-mirror-event-handler @@ -212,7 +211,7 @@ (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (parent t) (sheet motif-drawing-area)) - (values 'tk::xm-drawing-area (list :margin-width 0 + (values 'tk::xm-my-drawing-area (list :margin-width 0 :resize-policy :none :margin-height 0))) @@ -416,7 +415,7 @@ (defmethod add-sheet-callbacks :after ((port motif-port) (sheet motif-top-level-sheet) - (widget tk::xm-drawing-area)) + (widget tk::xm-my-drawing-area)) (tk::add-callback widget :resize-callback 'sheet-mirror-resized-callback sheet)) @@ -438,7 +437,7 @@ :resize-policy :none :name (string (frame-name (pane-frame sheet)))))) (t - (values 'tk::xm-drawing-area + (values 'tk::xm-my-drawing-area (list :resize-policy :none :name (string (frame-name (pane-frame sheet))) :margin-width 0 :margin-height 0))))) @@ -570,7 +569,7 @@ #+ignore (defmethod add-sheet-callbacks :after ((port motif-port) (sheet clim-stream-sheet) - (widget tk::xm-drawing-area)) + (widget tk::xm-my-drawing-area)) ;;---- It would suprise me if we needed this. (tk::add-callback widget :resize-callback @@ -617,7 +616,7 @@ (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (parent t) (sheet xm-viewport)) - (values 'tk::xm-drawing-area + (values 'tk::xm-my-drawing-area '(:scrolling-policy :application-defined :margin-width 0 :margin-height 0 :resize-policy :none @@ -626,7 +625,7 @@ #+ignore (defmethod add-sheet-callbacks :after ((port motif-port) (sheet xm-viewport) - (widget tk::xm-drawing-area)) + (widget tk::xm-my-drawing-area)) ;;--- I wonder whether this is needed since it should not be resized by ;; the toolkit and only as part of the goe management code that will ;; recurse to children anyway @@ -709,7 +708,7 @@ (defmethod find-widget-class-and-initargs-for-sheet ((port xt-port) (parent t) (sheet xm-frame-viewport)) - (values 'xm-drawing-area + (values 'tk::xm-my-drawing-area ;;--- These are duplicated (list :margin-width 0 :resize-policy :none @@ -722,7 +721,7 @@ (defmethod add-sheet-callbacks :after ((port motif-port) (sheet xm-frame-viewport) - (widget tk::xm-drawing-area)) + (widget tk::xm-my-drawing-area)) (tk::add-callback widget :resize-callback 'sheet-mirror-resized-callback diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp index 1c000b9c7d3f224e28c38746ff4a347119417453..a6bba1a2942cd54545c898555a228a14abf49df8 100644 --- a/tk-silica/xm-silica.lisp +++ b/tk-silica/xm-silica.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-silica.lisp,v 1.16 92/04/21 20:28:33 cer Exp Locker: cer $ +;; $fiHeader: xm-silica.lisp,v 1.17 92/04/30 09:09:53 cer Exp Locker: cer $ (in-package :xm-silica) @@ -32,7 +32,7 @@ 'motif-port) -(defmethod change-widget-geometry ((parent tk::xm-drawing-area) child +(defmethod change-widget-geometry ((parent tk::xm-my-drawing-area) child &rest args &key x y width height) (declare (ignore x y width height)) @@ -89,7 +89,7 @@ about their children")) (declare (ignore port)) (cond ( ;;--- hack alert (popup-frame-p sheet) - (values 'xm-dialog-shell + (values 'tk::xm-dialog-shell (append (let ((x (find-shell-of-calling-frame sheet))) (and x `(:transient-for ,x))) @@ -98,7 +98,7 @@ about their children")) (call-next-method)))) (defmethod make-cursor-widget-for-port ((port motif-port) parent) - (make-instance 'tk::xm-drawing-area + (make-instance 'tk::xm-my-drawing-area :parent parent :background (tk::get-values parent :foreground) :width 2 diff --git a/tk-silica/xt-cursor.lisp b/tk-silica/xt-cursor.lisp index 36d2999e4cadb77af4f7a84fa4692214d52b2578..0397881f79fe48fff75f7f8628ce8209c7ea1bd0 100644 --- a/tk-silica/xt-cursor.lisp +++ b/tk-silica/xt-cursor.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-cursor.lisp,v 1.7 92/04/30 09:09:54 cer Exp Locker: cer $ +;; $fiHeader: xt-cursor.lisp,v 1.8 92/05/12 18:25:26 cer Exp Locker: cer $ (in-package :xm-silica) @@ -69,10 +69,10 @@ (tk::add-widget-cleanup-function gadget #'(lambda () (setf (getf clim-internals::plist 'gadget) nil))) (xt::realize-widget gadget) (let ((window (tk::widget-window gadget))) - (setf (tk::drawable-save-under window) t)) + (setf (tk::window-save-under window) t)) ;;--- This really should be done somewhere else but where?????? #+ignore (let ((window (tk::widget-window (sheet-mirror sheet)))) - (setf (xt::drawable-backing-store window) t)) + (setf (xt::window-backing-store window) t)) gadget))))) diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index 93292c940f069cb2ba3a6b2298204d1e4bfcb666..e12494b7689da32ce016581a7766bb18de7b317c 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -1,4 +1,4 @@ -U;; -*- mode: common-lisp; package: tk-silica -*- +;; -*- mode: common-lisp; package: tk-silica -*- ;; ;; -[]- ;; @@ -20,7 +20,7 @@ U;; -*- mode: common-lisp; package: tk-silica -*- ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-graphics.lisp,v 1.19 92/04/28 09:26:35 cer Exp Locker: cer $ +;; $fiHeader: xt-graphics.lisp,v 1.20 92/05/07 13:13:58 cer Exp Locker: cer $ (in-package :tk-silica) @@ -29,6 +29,7 @@ U;; -*- mode: common-lisp; package: tk-silica -*- (background-gcontext :reader medium-background-gcontext :initform nil) (flipping-gcontext :reader medium-flipping-gcontext :initform nil) (drawable :initform nil) + (clip-mask :initform nil) ; A cache. (color-p) (ink-table :initform (make-hash-table :test #'equal)) (tile-gcontext :initform nil) ; The following don't belong here. @@ -42,6 +43,56 @@ U;; -*- mode: common-lisp; package: tk-silica -*- sheet (sheet-mirror sheet)))))) + +;; +;; Clip mask is invalidated when: +;; 1. medium's sheet's device region changes +;; 2. medium's clipping region changes +;; 3. medium's sheet's device transformation changes +(defmethod medium-clip-mask ((medium xt-medium)) + (with-slots (sheet clip-mask) medium + (or clip-mask + (setf clip-mask + (let* ((dr (sheet-device-region sheet)) + (mcr (medium-clipping-region medium))) + (unless (eq mcr +everywhere+) + (setq mcr (transform-region (sheet-device-transformation sheet) mcr)) + (setq dr (region-intersection dr (bounding-rectangle mcr)))) + (cond ((eq dr +everywhere+) + :none) + ((eq dr +nowhere+) + :nowhere) + (t + (with-bounding-rectangle* (left top right bottom) dr + (list (fix-coordinate left) (fix-coordinate top) + (fix-coordinate (- right left)) + (fix-coordinate (- bottom top))))))))))) + +(defmethod (setf medium-clipping-region) :after (cr (medium xt-medium)) + (declare (ignore cr)) + (with-slots (clip-mask) medium + (setf clip-mask nil))) + +;;;---------------------- You cannot have such a class since sheet-with-medium. +;;; Probably we need a method that gets invoked on the medium to +;;; invalidate any cached state. + +(warn "These should be specialized on an 'xt' subclass of sheet-with-medium!!!!!!!!!!!!!!!!!!!!!!!!!") + +(defmethod invalidate-cached-regions :after ((sheet silica::sheet-with-medium-mixin)) + (let ((medium (sheet-medium sheet))) + (when medium + (with-slots (clip-mask) medium + (setf clip-mask nil))))) + +(defmethod invalidate-cached-transformations :after ((sheet silica::sheet-with-medium-mixin)) + (let ((medium (sheet-medium sheet))) + (when medium + (with-slots (clip-mask) medium + (setf clip-mask nil))))) + + + (defmethod deallocate-medium :after (port (medium xt-medium)) (declare (ignore port)) (with-slots (drawable) medium @@ -326,14 +377,12 @@ and on color servers, unless using white or black") white-pixel black-pixel))))))))) +(defvar *default-dashes* '(4 4)) (defmethod adjust-ink ((medium xt-medium) gc ink line-style x-origin y-origin) (declare (ignore ink)) (let* ((dashes (line-style-dashes line-style)) - (gc-line-style - (etypecase dashes - ((member nil t) :solid) - (sequence :dash)))) + (gc-line-style (if dashes :dash :solid))) (tk::set-line-attributes gc @@ -345,7 +394,8 @@ and on color servers, unless using white or black") thickness)))) (when (< thickness 2) (setq thickness 0)) - (round thickness)) + (setq thickness (the fixnum (round thickness))) + thickness) gc-line-style (ecase (line-style-cap-shape line-style) (:butt :butt) @@ -358,23 +408,12 @@ and on color servers, unless using white or black") (:round :round))) (when (eq gc-line-style :dash) - (setf (tk::gcontext-dashes gc) dashes)) + (setf (tk::gcontext-dashes gc) + (if (excl::sequencep dashes) dashes *default-dashes*)) + ;; The following isn't really right, but it's better than nothing. + (setf (tk::gcontext-dash-offset gc) (1- y-origin))) - (let* ((sheet (medium-sheet medium)) - (dr (sheet-device-region sheet)) - (mcr (medium-clipping-region medium))) - (unless (eq mcr +everywhere+) - (setq mcr (transform-region (sheet-device-transformation sheet) mcr)) - (setq dr (region-intersection dr (bounding-rectangle mcr)))) - (cond ((eq dr +everywhere+) - (setf (tk::gcontext-clip-mask gc) :none)) - ((eq dr +nowhere+) - (setf (tk::gcontext-clip-mask gc) :nowhere)) - (t - (with-bounding-rectangle* (a b c d) dr - (with-stack-list (x (fix-coordinate a) (fix-coordinate b) - (fix-coordinate (- c a)) (fix-coordinate (- d b))) - (setf (tk::gcontext-clip-mask gc) x)))))) + (setf (tk::gcontext-clip-mask gc) (medium-clip-mask medium)) (when (member (tk::gcontext-fill-style gc) '(:tiled :stippled) :test #'eq) (setf (tk::gcontext-ts-x-origin gc) x-origin @@ -432,69 +471,83 @@ and on color servers, unless using white or black") (defmethod port-draw-point* ((port xt-port) sheet medium x y) - (let ((transform (sheet-device-transformation sheet))) - (convert-to-device-coordinates transform x y)) - (when (medium-drawable medium) - (let ((thickness (line-style-thickness (medium-line-style medium)))) - (if (< thickness 2) - (tk::draw-point - (medium-drawable medium) - (adjust-ink medium - (decode-ink (medium-ink medium) medium) - (medium-ink medium) - (medium-line-style medium) - x y) - x y) - (let ((thickness (round thickness))) - (tk::draw-ellipse (medium-drawable medium) - (adjust-ink medium - (decode-ink (medium-ink medium) medium) - (medium-ink medium) - (medium-line-style medium) - (- x thickness) - (- y thickness)) - x y - 0 - thickness - 0 - thickness 0 2pi - t)))))) + (let ((drawable (medium-drawable medium))) + (when drawable + (let* ((ink (medium-ink medium)) + (line-style (medium-line-style medium)) + (thickness (line-style-thickness line-style)) + (transform (sheet-device-transformation sheet))) + (convert-to-device-coordinates transform x y) + (cond ((< thickness 1.5) + (tk::draw-point + drawable + (adjust-ink medium + (decode-ink ink medium) + ink + line-style + x y) + x y)) + (t + (setq thickness (round thickness)) + (tk::draw-ellipse + drawable + (adjust-ink medium + (decode-ink ink medium) + ink + line-style + (the fixnum (- (the fixnum x) (the fixnum thickness))) + (the fixnum (- (the fixnum y) (the fixnum thickness)))) + x y + 0 + thickness + 0 + thickness 0 2pi + t))))))) (defmethod port-draw-line* ((port xt-port) sheet medium x1 y1 x2 y2) - (let ((transform (sheet-device-transformation sheet))) - (convert-to-device-coordinates transform - x1 y1 x2 y2)) - (when (medium-drawable medium) - (tk::draw-line - (medium-drawable medium) - (adjust-ink medium - (decode-ink (medium-ink medium) medium) - (medium-ink medium) - (medium-line-style medium) - (min x1 x2) (min y1 y2)) - 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 medium + (decode-ink ink medium) + ink + (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-rectangle* ((port xt-port) sheet medium x1 y1 x2 y2 filled) - (let ((transform (sheet-device-transformation sheet))) - (if (rectilinear-transformation-p transform) - (progn - (convert-to-device-coordinates transform - x1 y1 x2 y2) - (when (medium-drawable medium) - (tk::draw-rectangle - (medium-drawable medium) - (adjust-ink medium - (decode-ink (medium-ink medium) medium) - (medium-ink medium) - (medium-line-style medium) - (min x1 x2) (min y1 y2)) - (min x1 x2) (min y1 y2) - (abs (- x2 x1)) (abs (- y2 y1)) - filled))) - (port-draw-transformed-rectangle* - port sheet medium x1 y1 x2 y2 filled)))) + (let ((drawable (medium-drawable medium))) + (when drawable + (let ((ink (medium-ink medium)) + (transform (sheet-device-transformation sheet))) + (cond ((rectilinear-transformation-p transform) + (convert-to-device-coordinates transform + x1 y1 x2 y2) + (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)) + (tk::draw-rectangle + drawable + (adjust-ink medium + (decode-ink ink medium) + ink + (medium-line-style medium) + min-x min-y) + min-x min-y + (fast-abs (the fixnum (- (the fixnum x2) (the fixnum x1)))) + (fast-abs (the fixnum (- (the fixnum y2) (the fixnum y1)))) + filled))) + (t + (port-draw-transformed-rectangle* + port sheet medium x1 y1 x2 y2 filled))))))) (defmethod port-draw-polygon* ((port xt-port) sheet medium list-of-x-and-ys diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index 735db298195da9fe292e3f962dda30440c697167..b80bc42a46a6eaa653b7c83d5ea8dd825d16dd47 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.25 92/05/07 13:14:02 cer Exp Locker: cer $ +;; $fiHeader: xt-silica.lisp,v 1.26 92/05/12 18:25:31 cer Exp Locker: cer $ (in-package :xm-silica) @@ -306,7 +306,11 @@ (sheet-mirror-resized-callback widget nil event sheet) nil) + ;; This is handled by the expose callback. (:expose + nil) + (:expose + ;; This gets called only for an XmBulletinBoard widget. (sheet-mirror-exposed-callback widget nil ; window @@ -1002,26 +1006,30 @@ (defun default-from-mirror-resources (port pane) (unless (and (medium-foreground pane) (medium-background pane)) - (let ((w (sheet-mirror pane))) + (let* ((w (sheet-mirror pane)) + (dap (typep w 'tk::xm-drawing-area))) + ;;-- What about the case when there is a pixmap - (when (typep w 'xm-drawing-area) - (multiple-value-bind - (foreground background) - (tk::get-values w :foreground :background) - ;; Now we have to convert into CLIM colors. - (flet ((ccm (x) - (multiple-value-bind - (r g b) - (tk::query-color (tk::default-colormap (port-display port)) x) - (let ((x #.(1- (ash 1 16)))) - (make-rgb-color - (/ r x) - (/ g x) - (/ b x)))))) + (multiple-value-bind + (foreground background) + (if dap + (tk::get-values w :foreground :background) + (values nil (tk::get-values w :background))) + ;; Now we have to convert into CLIM colors. + (flet ((ccm (x) + (multiple-value-bind + (r g b) + (tk::query-color (tk::default-colormap (port-display port)) x) + (let ((x #.(1- (ash 1 16)))) + (make-rgb-color + (/ r x) + (/ g x) + (/ b x)))))) + (when foreground (unless (medium-foreground pane) - (setf (medium-foreground pane) (ccm foreground))) - (unless (medium-background pane) - (setf (medium-background pane) (ccm background))))))))) + (setf (medium-foreground pane) (ccm foreground)))) + (unless (medium-background pane) + (setf (medium-background pane) (ccm background)))))))) ;;;--- Gadget activation deactivate diff --git a/tk/callbacks.lisp b/tk/callbacks.lisp index 0161de06c78f362b4a442cefc3ffb024b978f081..72ca6a186bc8058a7ee9cd28de751b4c86529b86 100644 --- a/tk/callbacks.lisp +++ b/tk/callbacks.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: callbacks.lisp,v 1.11 92/05/06 15:37:07 cer Exp Locker: cer $ +;; $fiHeader: callbacks.lisp,v 1.12 92/05/07 13:10:47 cer Exp Locker: cer $ (in-package :tk) @@ -63,7 +63,7 @@ *callback-handler-address* (caar (push (list (new-callback-id) (cons function args) type) - (widget-callback-data widget )))))) + (widget-callback-data widget)))))) (defvar *callback-ids* 0) (defun new-callback-id () @@ -128,7 +128,7 @@ (let ((z (assoc x *callback-name-alist*))) (unless z (error "No such Callback: ~S" x)) (values (or (third z) - (setf (third z) (string-to-char* (second z)))) + (setf (third z) (second z))) (fourth z)))) (defmethod spread-callback-data (widget data (type (eql :activate))) diff --git a/tk/foreign-obj.lisp b/tk/foreign-obj.lisp index 3c5a6a858ce078b32d71ef6fc3369ee45ebbc2a3..434d09ad61b2c1039230e225d6cb82ca116b34dd 100644 --- a/tk/foreign-obj.lisp +++ b/tk/foreign-obj.lisp @@ -20,23 +20,27 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: foreign-obj.lisp,v 1.9 92/04/21 16:12:19 cer Exp Locker: cer $ +;; $fiHeader: foreign-obj.lisp,v 1.10 92/05/07 13:10:48 cer Exp Locker: cer $ (in-package :tk) -;;; There should be multiple mappings: -;;; Xid -> object -;;; Address -> object - (defvar *address->object-mapping* (make-hash-table :test 'equal)) -(defvar *xid->object-mapping* (make-hash-table :test 'equal)) + +(defclass display (ff:foreign-pointer) + ((context :initarg :context :reader display-context) + (xid->object-mapping :initform (make-hash-table :test #'equal) + :fixed-index 0))) + +(defmacro display-xid->object-mapping (object) + `(locally (declare (optimize (speed 3) (safety 0))) + (excl::slot-value-using-class-name 'display ,object 'xid->object-mapping))) + +(defun find-object-from-xid (handle display &optional (errorp t)) + (find-object-from-handle handle (display-xid->object-mapping display) errorp)) (defun find-object-from-address (handle &optional (errorp t)) (find-object-from-handle handle *address->object-mapping* errorp)) -(defun find-object-from-xid (handle &optional (errorp t)) - (find-object-from-handle handle *xid->object-mapping* errorp)) - (defun find-object-from-handle (handle table errorp) (cond ((gethash handle table)) (errorp @@ -50,12 +54,12 @@ (remhash handle *address->object-mapping*) (setf (ff:foreign-pointer-address object) 0)) -(defun register-xid (object &optional (handle (foreign-pointer-address object))) - (setf (gethash handle *xid->object-mapping*) object) +(defun register-xid (object display &optional (handle (foreign-pointer-address object))) + (setf (gethash handle (display-xid->object-mapping display)) object) object) -(defun unregister-xid (object &optional (handle (foreign-pointer-address object))) - (remhash handle *xid->object-mapping*) +(defun unregister-xid (object display &optional (handle (foreign-pointer-address object))) + (remhash handle (display-xid->object-mapping display)) object) (defun intern-object-address (handle class &rest initargs) @@ -70,9 +74,9 @@ *address->object-mapping* handle)) -(defun intern-object-xid (handle class &rest initargs) +(defun intern-object-xid (handle class display &rest initargs) (apply #'intern-object-1 - *xid->object-mapping* + (display-xid->object-mapping display) handle class initargs)) diff --git a/tk/foreign.lisp b/tk/foreign.lisp index 3eb05c3482bc629387f2badb0bfb4c667fa52365..f8e0a867ad25acc5d8619a383bdf96cedb4cb7a4 100644 --- a/tk/foreign.lisp +++ b/tk/foreign.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: foreign.lisp,v 1.9 92/04/15 11:44:43 cer Exp Locker: cer $ +;; $fiHeader: foreign.lisp,v 1.10 92/04/21 20:27:30 cer Exp $ (in-package :tk) @@ -75,10 +75,6 @@ (error "cannot open the display: ~A" host) d))) -(defclass display (ff:foreign-pointer) - ((context :initarg :context :reader display-context))) - - (defmethod initialize-instance :after ((d display) &rest args &key display &allow-other-keys) diff --git a/tk/gcontext.lisp b/tk/gcontext.lisp index 7b9de41ade1b1850dc6252f6528253a0fefe4f25..11e1ad827a088d32f07859d7a7d1e2bc4ea3ff01 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.13 92/04/28 09:25:02 cer Exp Locker: cer $ +;; $fiHeader: gcontext.lisp,v 1.14 92/05/12 18:24:17 cer Exp Locker: cer $ (in-package :tk) @@ -114,9 +114,8 @@ (define-gc-writer ,name ,encoder ,@args) ',name))) - (defclass gcontext (display-object) - ()) + ((cached-clip-mask :initform nil))) (defmethod initialize-instance :after ((gcontext gcontext) &key @@ -216,8 +215,12 @@ (nth x '(:solid :tiled :stippled :opaque-stippled))) (defun encode-fill-style (x) - (or (position x '(:solid :tiled :stippled :opaque-stippled)) - (error "~s is not a fill style" x))) + (declare (optimize (speed 3) (safety 0))) + (ecase x + (:solid 0) + (:tiled 1) + (:stippled 2) + (:opaque-stippled 3))) (defmethod (setf gcontext-fill-style) (nv (gc gcontext)) (x11:xsetfillstyle @@ -241,14 +244,21 @@ (define-gc-accessor cap-style (encode-cap-style decode-cap-style)) (defun encode-cap-style (x) - (or (position x '(:not-last :butt :round :projecting)) - (error "~s is not a cap style" x))) + (declare (optimize (speed 3) (safety 0))) + (ecase x + (:not-last 0) + (:butt 1) + (:round 2) + (:projecting 3))) (define-gc-accessor join-style (encode-join-style decode-join-style)) (defun encode-join-style (x) - (or (position x '(:miter :round :bevel)) - (error "~s is not a join-style" x))) + (declare (optimize (speed 3) (safety 0))) + (ecase x + (:miter 0) + (:round 1) + (:bevel 2))) (define-gc-accessor subwindow-mode (encode-enum decode-enum) '(:clip-by-children :include-inferiors)) @@ -306,21 +316,19 @@ (defmethod (setf gcontext-clip-mask) ((nv cons) (gc gcontext)) - (destructuring-bind - (x y width height) nv - (let ((r (x11:make-xrectangle))) - (setf (x11:xrectangle-x r) x - (x11:xrectangle-y r) y - (x11:xrectangle-width r) width - (x11:xrectangle-height r) height) - (x11:xsetcliprectangles - (object-display gc) - gc - 0 ; clip-x-origin - 0 ; clip-y-origin - r - 1 - x11:unsorted)))) + (let ((r (x11:make-xrectangle))) + (setf (x11:xrectangle-x r) (first nv) + (x11:xrectangle-y r) (second nv) + (x11:xrectangle-width r) (third nv) + (x11:xrectangle-height r) (fourth nv)) + (x11:xsetcliprectangles + (object-display gc) + gc + 0 ; clip-x-origin + 0 ; clip-y-origin + r + 1 + x11:unsorted))) (defmethod (setf gcontext-clip-mask) ((nv (eql :nowhere)) (gc gcontext)) (x11:xsetcliprectangles @@ -332,11 +340,21 @@ 0 x11:unsorted)) +(defmethod (setf gcontext-clip-mask) :around (nv (gc gcontext)) + (with-slots (cached-clip-mask) gc + (unless (or (eq cached-clip-mask nv) + (equal cached-clip-mask nv)) + (call-next-method) + (setf cached-clip-mask nv)))) + (define-gc-accessor line-style (encode-line-style decode-style)) (defun encode-line-style (x) - (or (position x '(:solid :dash :double-dash)) - (error "~S is not a valid line-style" x))) + (declare (optimize (speed 3) (safety 0))) + (ecase x + (:solid 0) + (:dash 1) + (:double-dash 2))) (defmethod (setf gcontext-dashes) (nv (gc gcontext)) (multiple-value-bind (n v) @@ -352,7 +370,7 @@ (defun encode-dashes (nv) (declare (optimize (speed 3) (safety 0))) (let* ((n (length nv)) - (v (make-array n :element-type '(unsigned-byte 8)))) + (v (excl:make-static-array n :element-type '(unsigned-byte 8)))) (declare (fixnum n) (type (simple-array (unsigned-byte 8) (*)) v)) (etypecase nv @@ -386,15 +404,18 @@ (declare (special gc)) (if (= x #16rffffffff) (error "cannot decode font") - (let ((font (find-object-from-xid x nil))) + (let* ((display (object-display gc)) + (font (find-object-from-xid x display nil))) (or font - (query-font (object-display gc) x))))) + (query-font display x))))) -(defun decode-pixmap (x) +(defun decode-pixmap (x) + (declare (special gc)) (and (/= #16rffffffff x) (intern-object-xid x - 'pixmap))) + 'pixmap + (object-display gc)))) (defun decode-clip-mask (x) x) (defun decode-enum (x y) diff --git a/tk/graphics.lisp b/tk/graphics.lisp index 8472c13a7097d22a1f73148c4aadff1d3b744902..24892bbbe02caf157f08c0d851718a66ae8324cb 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.6 92/03/24 19:36:10 cer Exp $ +;; $fiHeader: graphics.lisp,v 1.7 92/04/15 11:44:45 cer Exp $ (in-package :tk) @@ -127,6 +127,7 @@ y width height))) +#+ignore (defun text-extents (font sequence &key (start 0) end translate) (unless end (setq end (length sequence))) (with-ref-par ((direction 0) @@ -153,10 +154,7 @@ ; something-else )))) - - - - +#+ignore (defun text-width (font sequence &key (start 0) end translate) (unless end (setq end (length sequence))) (x11:xtextwidth font @@ -189,14 +187,6 @@ (defun draw-string (drawable gc x y string &optional (start 0) end) (unless start (setq start 0)) (unless end (setq end (length string))) - (x11::xdrawstring - (object-display drawable) - drawable - gc - x y - (+ start (string-to-char* string)) - (- end start)) - #+ignore (x11:lisp-xdrawstring (object-display drawable) drawable diff --git a/tk/load-xm.lisp b/tk/load-xm.lisp index 2da445027594580691fb3382f99548273e732b09..bdab8e7da78ecbd0316e2f3d3e4db770bcab61b4 100644 --- a/tk/load-xm.lisp +++ b/tk/load-xm.lisp @@ -20,16 +20,23 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: load-xm.lisp,v 1.10 92/04/03 12:04:00 cer Exp $ +;; $fiHeader: load-xm.lisp,v 1.11 92/05/07 13:10:51 cer Exp Locker: cer $ (in-package :tk) + + ;;;; (defvar *libx11-pathname* "/x11/R4/src/mit/lib/X/libX_d.a") (defvar *libxm-pathname* "/x11/motif-1.1/lib/Xm/libXm.a") (defvar *libxt-pathname* "/x11/R4/src/mit/lib/Xt/libXt_d.a") (defun load-from-xm () + (unless (ff:get-entry-point (ff:convert-to-lang "XmCreateMyDrawingArea")) + (load "MyDrawingA.o" + :system-libraries (list *libxm-pathname* *libxt-pathname* + x11::*libx11-pathname*) + :print t)) (x11::load-undefined-symbols-from-library "stub-motif.o" (x11::symbols-from-file diff --git a/tk/macros.lisp b/tk/macros.lisp index 1548d2c8a629abf471cc80fa57468efd0059d010..71ef44caf3a9c8ccc3168f99ad24e8a5166f4634 100644 --- a/tk/macros.lisp +++ b/tk/macros.lisp @@ -20,12 +20,11 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: macros.lisp,v 1.8 92/03/09 17:40:46 cer Exp $ +;; $fiHeader: macros.lisp,v 1.9 92/03/30 17:51:41 cer Exp $ (in-package :tk) -(defvar *temp-with-ref-par* nil) -(defparameter *temp-with-ref-par-p* t) +(defvar *with-ref-par-resource* nil) (defmacro with-ref-par (bindings &body body) (if (null bindings) @@ -34,11 +33,17 @@ ((var value &optional (type :signed-long)) &rest more-bindings) bindings (let ((val (gensym))) `(let ((,val ,value) - (,var (or (and *temp-with-ref-par-p* (pop *temp-with-ref-par*)) + (,var (or (pop *with-ref-par-resource*) (make-array 1 :element-type '(unsigned-byte 32))))) (declare (type (simple-array (unsigned-byte 32) (1)) ,var)) (setf (aref ,var 0) ,val) (multiple-value-prog1 (with-ref-par ,more-bindings ,@body) - (when *temp-with-ref-par-p* - (push ,var *temp-with-ref-par*)))))))) + (push ,var *with-ref-par-resource*))))))) + + +(defmacro object-display (object) + `(locally (declare (optimize (speed 3) (safety 0))) + (excl::slot-value-using-class-name 'display-object ,object + 'display))) + diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp index 5803a31f9973fa4b5cc80958945ef3519cf21b2d..d9660d49a8f987cccccadb1cf2527b79b37a3527 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.15 92/04/21 20:27:34 cer Exp Locker: cer $ +;; $fiHeader: make-classes.lisp,v 1.16 92/05/07 13:10:52 cer Exp Locker: cer $ (in-package :tk) @@ -62,11 +62,6 @@ -(defclass display-object (ff:foreign-pointer) - ((display :initarg :display - :reader object-display - :fixed-index 0))) - (defclass xt-root-class (display-object) ((events :initform nil :accessor widget-event-handler-data) (callbacks :initform nil :accessor widget-callback-data) diff --git a/tk/meta-tk.lisp b/tk/meta-tk.lisp index 4cd5d7fa5b21d0bfcfc283fb51395d0a154d67b1..533c86f33bb5efb0b4e864134c3c81e36a84113e 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.6 92/03/09 17:40:49 cer Exp $ +;; $fiHeader: meta-tk.lisp,v 1.7 92/03/30 17:51:45 cer Exp $ (in-package :tk) @@ -40,7 +40,13 @@ :reader class-direct-resources) (constraint-resources :initform nil :initarg :direct-constraints - :reader class-direct-constraint-resources))) + :reader class-direct-constraint-resources) + (get-values-cache :initform (make-hash-table :test #'equal) + :type hash-table + :reader class-get-values-cache) + (set-values-cache :initform (make-hash-table :test #'equal) + :type hash-table + :reader class-set-values-cache))) (defmethod class-handle ((class xt-class)) (unless (clos::class-finalized-p class) diff --git a/tk/pkg.lisp b/tk/pkg.lisp index 208d6fb5251027e1ea93f0a69e655fdc4d98c99b..cbd9cce13879338f3eb4130d3ba703a0e2cd77c7 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.7 92/03/30 17:51:47 cer Exp $ +;; $fiHeader: pkg.lisp,v 1.8 92/04/21 20:27:39 cer Exp $ (defpackage :tk ;;-- No we really need @@ -30,11 +30,9 @@ (:import-from :excl #:if*) (:export #:initialize-motif-toolkit - #:xm-drawing-area #:widget-parent #:manage-child #:get-values - #:xm-dialog-shell #:top-level-shell #:popup #:manage-child diff --git a/tk/resources.lisp b/tk/resources.lisp index 2df817e74e2ffaced9fbc21954139f19ab797689..259acd0df3b7f1d4c4fc2fe21b4cfa0d302c999a 100644 --- a/tk/resources.lisp +++ b/tk/resources.lisp @@ -1,4 +1,4 @@ -;; -*- mode: common-lisp; package: tk -*- +; -*- mode: common-lisp; package: tk -*- ;; ;; -[]- ;; @@ -20,113 +20,28 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: resources.lisp,v 1.19 92/05/06 15:37:08 cer Exp Locker: cer $ +;; $fiHeader: resources.lisp,v 1.20 92/05/07 13:10:59 cer Exp Locker: cer $ (in-package :tk) (defmacro define-enumerated-resource (type elements) `(progn - (defmethod convert-resource-out ((parent t) (type (eql ',type)) value) + (defmethod convert-resource-out (parent (type (eql ',type)) value) + (declare (ignore parent)) (or (position value ',elements) (error "cannot convert ~S to type ~S" value ',type))) - (defmethod convert-resource-in ((parent t) (type (eql ',type)) value) - (declare (ignorable parent)) - (setq value (ash value -24)) + (defmethod resource-type-get-memref-type ((type (eql ',type))) + :unsigned-byte) + (defmethod convert-resource-in (parent (type (eql ',type)) value) + (declare (ignore parent)) (elt ',elements value)))) - - -(defun set-values (widget &rest values) - (let ((arglist (make-arglist-for-class (class-of widget) widget values))) - (xt_set_values widget - arglist - (truncate (length arglist) 2)))) - - -(defun make-arglist-for-class (class parent args) - (do ((new-args nil) - (resources-1 (class-resources class)) - (resources-2 (and parent (class-constraint-resources - (class-of parent)))) - keyword - value) - ((null args) - (make-array (length new-args) - :element-type '(signed-byte 32) - :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)))) - (when resource - (push (resource-original-name resource) new-args) - (push (convert-resource-out parent (resource-type resource) value) - new-args))))) - - -(defmethod convert-resource-out (parent type value) - (cerror "Try again" "cannot convert-out resource for ~S,~S,~S" parent type value) - (convert-resource-out parent type value)) - -(defmethod convert-resource-out :around (parent type value) - (declare (optimize (speed 3)) - (ignore parent type value)) - (let ((result (call-next-method))) - (if (integerp result) - result - (ff:foreign-pointer-address result)))) - -(defmethod convert-resource-out ((parent t) (type (eql 'xm-string)) value) - (xm_string_create_l_to_r (string-to-char* value) (string-to-char* ""))) - -(defmethod convert-resource-out ((parent t) (type (eql 'orientation)) value) - (ecase value - (:vertical 1) - (:horizontal 2))) - -(defun get-values (widget &rest resources) - (let* ((class (class-of widget)) - (class-resources (class-resources class)) - (arglist nil) - rds) - - ;;-- This class resource - ;;-- Accumulate resources into a resource allocated vector - (dolist (r resources) - (let ((resource (find r class-resources :key #'resource-name))) - (unless resource - (error "No such resource ~S for class ~S widget ~S" - r class widget)) - ;;--- Need to resource allocate this - (push resource rds) - (push (resource-original-name resource) arglist) - (push (make-x-arglist) arglist))) - - ;;-- We ought to be ashamed of ourselves for using coerce - ;;-- This also ought to be resource allocated - (setq arglist (coerce (nreverse arglist) '(vector (signed-byte 32)))) - (xt_get_values widget - arglist - (truncate (length arglist) 2)) - ;;--- Perhaps this list should be a vector that is resource - ;;-- allocated. - (do ((rs (nreverse rds) (cdr rs)) - (i 1 (+ i 2)) - values) - ((null rs) - (values-list (nreverse values))) - (push - (convert-resource-in - widget - (resource-type (car rs)) - (x-arglist (aref arglist i) 0)) - values)))) - - (defmethod convert-resource-in (class type value) (cerror "Try again" "cannot convert-in resource for ~S,~S,~S" class type value) (convert-resource-in class type value)) + + (defconstant xm_string_default_char_set "") (defmethod convert-resource-in (class (type (eql 'xm-string)) value) @@ -138,6 +53,7 @@ (xm_string_get_l_to_r value xm_string_default_char_set string) (char*-to-string (aref string 0))))) + (define-enumerated-resource separator-type (:no-line :single-line :double-line @@ -145,230 +61,36 @@ :double-dashed-line :shadow-etched-in :shadow-etched-out)) - -(defmethod convert-resource-out ((parent t) (type (eql 'menu-widget)) value) - value) - -(defmethod convert-resource-out ((parent t) (type (eql 'horizontal-dimension)) value) - (check-type value integer) - value) - -(defmethod convert-resource-out ((parent t) (type (eql 'horizontal-int)) value) - (check-type value integer) - value) - - -(defmethod convert-resource-out ((parent t) (type (eql 'vertical-dimension)) value) - value) - -(defmethod convert-resource-out ((parent t) (type (eql 'vertical-int)) value) - value) - -(defmethod convert-resource-out ((parent t) (type (eql 'visual-policy)) value) - (ecase value - (:constant 1))) - (define-enumerated-resource scrolling-policy (:automatic :application-defined)) - - -(defmethod convert-resource-out ((parent t) (type (eql 'scroll-bar-display-policy)) value) - (ecase value - (:static 0))) - - -#+ignore -(defmethod convert-resource-out ((parent t) (type (eql 'packing)) value) - (ecase value - (:pack-column 2))) - -(defmethod convert-resource-out ((parent t) (type (eql 'short)) value) - value) - -(defmethod convert-resource-out ((parent t) (type (eql 'label-type)) value) - (ecase value - (:pixmap 1) - (:string 2))) - - -(defmethod convert-resource-out ((parent t) (type (eql 'alignment)) value) - (ecase value - (:center 1) - (:beginning 0) - (:end 2))) - -(defmethod convert-resource-out ((parent t) (type (eql 'prim-foreground-pixmap)) value) - (convert-pixmap-out parent value)) - -(defmethod convert-resource-out ((parent t) (type (eql 'gadget-pixmap)) value) - (convert-pixmap-out parent value)) - -(defmethod convert-resource-out ((parent t) (type (eql 'pixmap)) value) - (convert-pixmap-out parent value)) - -(defmethod convert-resource-out ((parent t) (type (eql 'bitmap)) value) - (convert-pixmap-out parent value)) - - -(defun convert-pixmap-out (parent value) - (etypecase value - (pixmap value) - (string - (let* ((display (widget-display parent)) - (screen (x11:xdefaultscreenofdisplay display)) - (white (x11::xwhitepixel display 0)) - (black (x11::xblackpixel display 0))) - (xm_get_pixmap screen (string-to-char* value) white black))))) - - -(defmethod convert-resource-out ((parent t) (type (eql 'boolean)) value) - (if value 1 0)) - -(defmethod convert-resource-out ((parent t) (type (eql 'string)) value) - (string-to-char* value)) - (define-enumerated-resource dialog-style (:modeless :primary-application-modal :full-application-modal :system-modal)) -(defmethod convert-resource-out ((parent t) (type (eql 'font-struct)) value) - (make-instance 'font - :display (widget-display parent) - :name value)) - - -(defmethod convert-resource-in ((parent t) (type (eql 'string)) value) - (unless (zerop value) - (char*-to-string value))) - -(defmethod convert-resource-in ((parent t) (type (eql 'boolean)) - value) - (not (zerop (ash value -24)))) - -(defmethod convert-resource-in ((parent t) (type (eql 'cardinal)) value) - value) - -;; We have to do this because we pass a pointer to :unsigned-long but -;; the actual type is :short -(defmethod convert-resource-in ((parent t) (type (eql 'vertical-dimension)) value) - (ash value -16)) - -(defmethod convert-resource-in ((parent t) (type (eql 'horizontal-dimension)) value) - (ash value -16)) - -(defmethod convert-resource-in ((parent t) (type (eql 'horizontal-position)) value) - (convert-16bit-resource-in value)) - -(defmethod convert-resource-in ((parent t) (type (eql 'vertical-position)) value) - (convert-16bit-resource-in value)) - -(defmethod convert-resource-out ((parent t) (type (eql 'pixel)) value) - (etypecase value - (integer value) - (color (allocate-color (default-colormap (widget-display parent)) - value)))) - - -(defmethod convert-resource-in ((parent t) (type (eql 'pixel)) value) - value) - -(defmethod convert-resource-out ((parent t) (type (eql 'horizontal-position)) value) - value) - -(defmethod convert-resource-out ((parent t) (type (eql 'vertical-position)) value) - value) - (define-enumerated-resource resize-policy (:none :grow :any)) -(defmethod convert-resource-in ((parent t) (type (eql 'int)) value) value) -(defmethod convert-resource-out ((parent t) (type (eql 'int)) value) value) - - (define-enumerated-resource indicator-type (nil :n-of-many :one-of-many)) - -(defmethod convert-resource-out ((parent t) (type (eql 'shell-vert-dim)) x) x) -(defmethod convert-resource-out ((parent t) (type (eql 'shell-vert-pos)) x) x) -(defmethod convert-resource-out ((parent t) (type (eql 'shell-horiz-dim)) x) x) -(defmethod convert-resource-out ((parent t) (type (eql 'shell-horiz-pos)) x) x) - -(defmethod convert-resource-in ((parent t) (type (eql 'shell-vert-dim)) x) x) -(defmethod convert-resource-in ((parent t) (type (eql 'shell-vert-pos)) x) x) -(defmethod convert-resource-in ((parent t) (type (eql 'shell-horiz-dim)) x) x) -(defmethod convert-resource-in ((parent t) (type (eql 'shell-horiz-pos)) x) x) - - (define-enumerated-resource delete-response (:destroy :unmap :do-nothing)) -(defmethod convert-resource-out ((parent t) (type (eql 'window)) x) - x) - - (define-enumerated-resource keyboard-focus-policy (:explicit :pointer)) +(define-enumerated-resource packing (:no-packing + :tight + :column + :none)) +(define-enumerated-resource edit-mode (:multi-line :single-line)) -(defmethod convert-resource-out ((parent t) (type (eql 'xm-background-pixmap)) value) - (etypecase value - (pixmap - (encode-pixmap value)))) - - - -(defmethod convert-resource-in ((widget t) (type (eql 'widget-list)) x) - (let ((r nil)) - (dotimes (i (widget-num-children widget)) - (push (convert-resource-in - widget 'widget (xt-widget-list x i)) - r)) - (nreverse r))) - - -(defmethod convert-resource-in ((widget t) (type (eql 'widget)) x) - (intern-widget x :display (widget-display widget))) - -(defmethod convert-resource-out ((widget t) (type (eql 'widget)) x) - x) - -;; Could not think of anywhere better! - - -(defun setup (&optional (hostspec "localhost:0")) - (let* ((context (create-application-context)) - (display (make-instance 'display - :host hostspec - :context context)) - (app (app-create-shell :display display - :widget-class 'application-shell))) - (values context display app))) - -(defun initialize-motif-toolkit (hostspec) - (setup hostspec)) - - -;;; ol resource - -(defmethod convert-resource-out ((parent t) (type (eql 'position)) value) - value) - -(defmethod convert-resource-in ((parent t) (type (eql 'position)) value) - (convert-16bit-resource-in value)) - -(defun convert-16bit-resource-in (value) - (let ((x (ash value -16))) - ;; 16bit signed value! - (if (>= x (ash 1 15)) - (- x (ash 1 16)) - x))) - -(defmethod convert-resource-out ((parent t) (type (eql 'dimension)) value) - value) +(define-enumerated-resource visual-policy (:variable :constant)) -(defmethod convert-resource-in ((parent t) (type (eql 'dimension)) value) - (ash value -16)) +(define-enumerated-resource scroll-bar-display-policy (:static :as-needed)) +(define-enumerated-resource selection-policy (:single-select + :multiple-select + :extended-select :browse-select)) ;; from OpenLook.h (defparameter *ol-defines* '( @@ -524,38 +246,308 @@ )) (defmethod convert-resource-in (parent (type (eql 'ol-define)) value) - (setq value (ash value -16)) + (declare (ignore parent)) (or (car (find value *ol-defines* :key #'second)) (call-next-method))) (defmethod convert-resource-out (parent (type (eql 'ol-define)) value) + (declare (ignore parent)) (or (second (find value *ol-defines* :key #'first)) (call-next-method))) + + + +;; Note that the current set-values implemenation only works for resources +;; that fit in a 32bit word. You were warned! + +(defun fill-sv-cache (class resources) + (let* ((len (length resources)) + (class-resources (class-resources class)) + (arglist (make-xt-arglist :number len)) + (rds nil) + (i 0)) + (dolist (r resources) + (let ((resource (find r class-resources :key #'resource-name :test #'eq))) + (unless resource + (error "No such resource ~S for widget of class ~S " + r class)) + (let ((type (resource-type resource))) + (push (list (resource-type-set-conversion-p type) + type) + rds)) + (setf (xt-arglist-name arglist i) (resource-original-name resource)) + (incf i))) + (setf (gethash resources (class-set-values-cache class)) + (list* arglist len (nreverse rds))))) + +(defun set-values (widget &rest resources-and-values) + (declare (optimize (speed 3)) + (dynamic-extent resources-and-values)) + (let ((resources nil) + (values nil)) + (do ((rvs resources-and-values (cddr rvs))) + ((null rvs)) + (push (car rvs) resources) + (push (cadr rvs) values)) + (setq resources (nreverse resources)) + (setq values (nreverse values)) + (excl::without-interrupts + ;; We don't really want anyone else to grab the same cache entry. + (let* ((class (class-of widget)) + (entry (gethash resources (class-set-values-cache class)))) + (declare (optimize (safety 0))) + (unless entry + (setf entry (fill-sv-cache class resources))) + + (destructuring-bind (arglist length &rest resource-descriptions) + entry + (do ((resdess resource-descriptions (cdr resdess)) + (i 0 (1+ i)) + (values values (cdr values))) + ((null resdess)) + (destructuring-bind (convert-p type) + (car resdess) + ;; Yuck -- the following should be handled somehow by cstructs... + (setf (sys:memref-int (xt-arglist arglist i) 4 0 :signed-long) + (if convert-p + (convert-resource-out widget type (car values)) + (car values))))) + (xt_set_values widget arglist length)))))) + +;; This is used by initialize-instance methods for widgets... +(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) + (make-array (length new-args) + :element-type '(signed-byte 32) + :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)))) + (when resource + (push (resource-original-name resource) new-args) + (let ((type (resource-type resource))) + (push + (if (resource-type-set-conversion-p type) + (convert-resource-out parent type value) + value) + new-args)))))) + + + + + +;; I would really prefer to define these as separate methods. However +;; that leads to a lot of code! +(defmethod resource-type-get-conversion-p (type) + (case type + (position nil) + (vertical-position nil) + (horizontal-position nil) + (shell-vert-pos nil) + (shell-horiz-pos nil) + (dimension nil) + (vertical-dimension nil) + (horizontal-dimension nil) + (shell-vert-dim nil) + (shell-horiz-dim nil) + (cardinal nil) + (pixel nil) + (int nil) + (t t))) + +(defmethod resource-type-set-conversion-p (type) + (case type + (position nil) + (vertical-position nil) + (horizontal-position nil) + (shell-vert-pos nil) + (shell-horiz-pos nil) + (dimension nil) + (vertical-dimension nil) + (vertical-int nil) + (horizontal-dimension nil) + (horizontal-int nil) + (shell-vert-dim nil) + (shell-horiz-dim nil) + (cardinal nil) + (pixel nil) + (short nil) + (int nil) + (t t))) +(defmethod resource-type-get-memref-type (type) + (case type + (position :signed-word) + (vertical-position :signed-word) + (horizontal-position :signed-word) + (shell-vert-pos :signed-word) + (shell-horiz-pos :signed-word) + (dimension :signed-word) + (vertical-dimension :signed-word) + (horizontal-dimension :signed-word) + (shell-vert-dim :signed-word) + (shell-horiz-dim :signed-word) + (int :signed-long) + (boolean :unsigned-byte) + (ol-define :unsigned-word) + (t :unsigned-long))) + + + +(defun fill-gv-cache (class resources) + (setq resources (copy-list resources)) ; So get-values can declare dynamic-extent + (let* ((len (length resources)) + (class-resources (class-resources class)) + (arglist (make-xt-arglist :number len)) + (rds nil) + (i 0)) + (dotimes (j len) + (setf (xt-arglist-value arglist j) (excl::malloc 8))) ; A crock... + (dolist (r resources) + (let ((resource (find r class-resources :key #'resource-name :test #'eq))) + (unless resource + (error "No such resource ~S for widget of class ~S " + r class)) + (let ((type (resource-type resource))) + (push (list (resource-type-get-memref-type type) + (resource-type-get-conversion-p type) + type) + rds)) + (setf (xt-arglist-name arglist i) (resource-original-name resource)) + (incf i))) + (setf (gethash resources (class-get-values-cache class)) + (list* arglist len (nreverse rds))))) + +(defun get-values (widget &rest resources) + (declare (optimize (speed 3)) + (dynamic-extent resources)) + (excl::without-interrupts + ;; We don't really want anyone else to grab the same cache entry. + (let* ((class (class-of widget)) + (entry (gethash resources (class-get-values-cache class)))) + (declare (optimize (safety 0))) + (unless entry + (setf entry (fill-gv-cache class resources))) + + (destructuring-bind (arglist length &rest resource-descriptions) + entry + (xt_get_values widget arglist length) + + (let ((i 0) + (values nil)) + (dolist (resource-desc resource-descriptions) + (destructuring-bind (get-memref-type convert-p type) + resource-desc + (let ((value (sys:memref-int (xt-arglist-value arglist i) 0 0 + get-memref-type))) + (incf i) + (if convert-p + (setq value (convert-resource-in widget type value))) + (push value values)))) + (values-list (nreverse values))))))) + + -(define-enumerated-resource packing (:no-packing - :tight - :column - :none)) +(defmethod convert-resource-out (parent type value) + (cerror "Try again" "cannot convert-out resource for ~S,~S,~S" parent type value) + (convert-resource-out parent type value)) +(defmethod convert-resource-out :around (parent type value) + (declare (optimize (speed 3)) + (ignore parent type value)) + (let ((result (call-next-method))) + (if (integerp result) + result + (ff:foreign-pointer-address result)))) -(define-enumerated-resource edit-mode (:multi-line :single-line)) +(defmethod convert-resource-out ((parent t) (type (eql 'xm-string)) value) + (xm_string_create_l_to_r (string-to-char* value) (string-to-char* ""))) +(defmethod convert-resource-out ((parent t) (type (eql 'orientation)) value) + (ecase value + (:vertical 1) + (:horizontal 2))) -;;; Accelerator table stuff +(defmethod convert-resource-out ((parent t) (type (eql 'menu-widget)) value) + value) -(defmethod convert-resource-in (parent (type (eql 'xt::accelerator-table)) - (value (eql 0))) - nil) +(defmethod convert-resource-out ((parent t) (type (eql 'label-type)) value) + (ecase value + (:pixmap 1) + (:string 2))) + +(defmethod convert-resource-out ((parent t) (type (eql 'alignment)) value) + (ecase value + (:center 1) + (:beginning 0) + (:end 2))) + +(defmethod convert-resource-out ((parent t) (type (eql 'prim-foreground-pixmap)) value) + (convert-pixmap-out parent value)) + +(defmethod convert-resource-out ((parent t) (type (eql 'gadget-pixmap)) value) + (convert-pixmap-out parent value)) + +(defmethod convert-resource-out ((parent t) (type (eql 'pixmap)) value) + (convert-pixmap-out parent value)) + +(defmethod convert-resource-out ((parent t) (type (eql 'bitmap)) value) + (convert-pixmap-out parent value)) + +(defun convert-pixmap-out (parent value) + (etypecase value + (pixmap value) + (string + (let* ((display (widget-display parent)) + (screen (x11:xdefaultscreenofdisplay display)) + (white (x11::xwhitepixel display 0)) + (black (x11::xblackpixel display 0))) + (xm_get_pixmap screen value white black))))) + +(defmethod convert-resource-out ((parent t) (type (eql 'boolean)) value) + (if value 1 0)) + +(defmethod convert-resource-out ((parent t) (type (eql 'string)) value) + (string-to-char* value)) + +(defmethod convert-resource-out ((parent t) (type (eql 'font-struct)) value) + (make-instance 'font + :display (widget-display parent) + :name value)) + +(defmethod convert-resource-out ((parent t) (type (eql 'pixel)) value) + (etypecase value + (integer value) + (color (allocate-color (default-colormap (widget-display parent)) + value)))) + +(defmethod convert-resource-out ((parent t) (type (eql 'window)) x) + x) + +(defmethod convert-resource-out ((parent t) (type (eql 'xm-background-pixmap)) value) + (etypecase value + (pixmap + (encode-pixmap value)))) +(defmethod convert-resource-out ((widget t) (type (eql 'widget)) x) + x) + +;;; Accelerator table stuff (defmethod convert-resource-out (parent (type (eql 'xt::accelerator-table)) (value (eql nil))) + (declare (ignore parent)) 0) -(define-enumerated-resource visual-policy (:variable :constant)) -(define-enumerated-resource scroll-bar-display-policy (:static :as-needed)) -(define-enumerated-resource selection-policy (:single-select :multiple-select :extended-select :browse-select)) + (defmethod convert-resource-out (parent (type (eql 'xm-string-table)) value) (if value @@ -566,10 +558,38 @@ (i 0 (1+ i))) ((null v) r) - (setf (x-arglist r i) + (setf (xt-arglist r i) (convert-resource-out parent 'xm-string (car v)))) 0)) + + +(defmethod convert-resource-in ((widget t) (type (eql 'widget-list)) x) + (let ((r nil)) + (dotimes (i (widget-num-children widget)) + (push (convert-resource-in + widget 'widget (xt-widget-list x i)) + r)) + (nreverse r))) + +(defmethod convert-resource-in ((parent t) (type (eql 'string)) value) + (unless (zerop value) + (char*-to-string value))) + +(defmethod convert-resource-in ((parent t) (type (eql 'boolean)) value) + (not (zerop value))) + +(defmethod convert-resource-in ((widget t) (type (eql 'widget)) x) + (intern-widget x :display (widget-display widget))) + +;;; Accelerator table stuff +(defmethod convert-resource-in (parent (type (eql 'xt::accelerator-table)) + (value (eql 0))) + (declare (ignore parent)) + nil) + + + ;;-- This is a problem cos we dont know the number of items (defmethod convert-resource-in (parent (type (eql 'xm-string-table)) value) @@ -585,3 +605,4 @@ (etypecase value ;;-- Should check to see if its registered (integer value))) + diff --git a/tk/widget.lisp b/tk/widget.lisp index ae12733e7bbe4c3a8a6517ccb3a2b1900893ed22..f7a26e83395bf28e03b118e06e6a3f9cac26ab33 100644 --- a/tk/widget.lisp +++ b/tk/widget.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: widget.lisp,v 1.17 92/04/21 16:12:25 cer Exp Locker: cer $ +;; $fiHeader: widget.lisp,v 1.18 92/04/21 20:27:42 cer Exp $ (in-package :tk) @@ -61,7 +61,7 @@ (let* ((class (find-class-maybe widget-class)) (handle (class-handle class)) (arglist (make-arglist-for-class class parent args))) - (funcall fn (string-to-char* name ) + (funcall fn name handle parent arglist @@ -74,15 +74,11 @@ (xt_manage_child child)) (defun unmanage-child (child) - (unmanage_child child)) + (xt_unmanage_child child)) (defun is-managed-p (widget) (not (zerop (xt_is_managed widget)))) - -(defun unmanage-child (child) - (xt_unmanage_child child)) - (defun manage-children (children) (xt_manage_children (map '(simple-array (signed-byte 32)) #'ff:foreign-pointer-address @@ -126,7 +122,8 @@ (error "Invalid window id ~D for ~S" id widget)) (intern-object-xid id - 'window + 'window + (widget-display widget) :display (widget-display widget))))))))) (defun make-clx-window (display widget) @@ -163,7 +160,7 @@ (apply (car cleanup) (cdr cleanup))) ;;--- When we start using gadgets things will be fun! (let ((w (widget-window widget nil t))) - (when w (unregister-xid w))) + (when w (unregister-xid w (object-display widget)))) (unintern-widget widget)) (defun intern-widget (widget-address &rest args) @@ -247,3 +244,19 @@ (defun set-sensitive (widget value) (xtsetsensitive widget (if value 1 0))) + + +;; Could not think of anywhere better! + +(defun setup (&optional (hostspec "localhost:0")) + (let* ((context (create-application-context)) + (display (make-instance 'display + :host hostspec + :context context)) + (app (app-create-shell :display display + :widget-class 'application-shell))) + (values context display app))) + +(defun initialize-motif-toolkit (hostspec) + (setup hostspec)) + diff --git a/tk/xlib.lisp b/tk/xlib.lisp index 7ae9eb6c5795a519fb79733289d04db5c25a5191..9cb872e61e4f1caaa6e07e080181a17d85417fde 100644 --- a/tk/xlib.lisp +++ b/tk/xlib.lisp @@ -20,80 +20,131 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xlib.lisp,v 1.15 92/04/21 16:12:27 cer Exp Locker: cer $ +;; $fiHeader: xlib.lisp,v 1.16 92/04/21 20:27:43 cer Exp $ (in-package :tk) ;;; Pathetic clos interface to Xlib -(defclass screen (display-object) ()) - -#+obsolete -(defun screen-gcontext (screen) - (let ((gc (x-screen-gc screen))) - (or (find-object-from-address gc nil) - (register-address - (make-instance 'gcontext - :display (object-display screen) - :foreign-address gc))))) - - +(defclass display-object (ff:foreign-pointer) + ((display :initarg :display + :fixed-index 0))) +(defclass screen (display-object) ()) (defclass drawable (display-object) ()) (defclass window (drawable) ()) -;; Ugh. This should be part of a general purpose mechanism -(defmethod drawable-depth ((window window)) - (let ((attrs (x11:make-xwindowattributes))) - (x11:xgetwindowattributes (object-display window) - window - attrs) - (x11:xwindowattributes-depth attrs))) +(eval-when (compile load eval) + (defconstant *window-set-attributes-bit-mask* + '(background-pixmap background-pixel border-pixmap border-pixel + bit-gravity win-gravity backing-store backing-planes backing-pixel + override-redirect save-under event-mask do-not-propogate-mask + colormap cursor)) + ;; Not really supported yet: + (defconstant *window-configure-bit-mask* + '(x y width height border-width sibling stacking-mode))) + +(eval-when (compile eval) + (defmacro define-window-reader (name &optional decoder &rest args) + `(defmethod ,(intern (format nil "~A-~A" 'window name)) ((window window)) + ,(let ((body + `(let ((attrs (x11:make-xwindowattributes))) + (x11:xgetwindowattributes (object-display window) + window + attrs) + (,(intern (format nil "~a-~a" 'xwindowattributes name) :x11) + attrs)))) + (if decoder + `(,decoder ,body ,@args) + body)))) + (defmacro define-window-writer (name &optional encoder &rest args) + `(progn + (defmethod (setf ,(intern (format nil "~A-~A" 'window name))) + (nv (window window)) + (let ((attrs (x11::make-xsetwindowattributes))) + (setf (,(intern (format nil "~a-~a" 'xsetwindowattributes name) :x11) + attrs) + ,(if encoder + `(,encoder nv ,@args) + `nv)) + (x11:xchangewindowattributes + (object-display window) + window + ,(ash 1 (or (position name *window-set-attributes-bit-mask*) + (error "Cannot find ~S in window attributes" name))) + attrs) + nv)))) + (defmacro define-window-accessor (name (&optional encoder decoder) &rest args) + `(progn + (define-window-reader ,name ,decoder ,@args) + (define-window-writer ,name ,encoder ,@args) + ',name))) + +(define-window-accessor backing-store (encode-backing-store decode-backing-store)) + +(defun encode-backing-store (x) + (declare (optimize (speed 3) (safety 0))) + (ecase x + ((t :always) 2) + (:when-mapped 1) + ((nil :not-useful) 0))) -(defmethod (setf drawable-save-under) (nv (window window)) - (let ((attrs (x11:make-xsetwindowattributes))) - (setf (x11:xsetwindowattributes-save-under attrs) (if nv 1 0)) - (x11:xchangewindowattributes (object-display window) - window - x11::cwsaveunder ;; - attrs) - nv)) - -(defmethod drawable-save-under ((window window)) - (let ((attrs (x11:make-xwindowattributes))) - (x11:xgetwindowattributes (object-display window) - window - attrs) - (not (zerop (x11:xwindowattributes-save-under attrs))))) +(defun decode-backing-store (x) + (declare (optimize (speed 3) (safety 0))) + (ecase x + (2 :always) + (1 :when-mapped) + (0 :not-useful))) + +(defun encode-save-under (x) + (declare (optimize (speed 3) (safety 0))) + (ecase x + ((t :on) 1) + ((nil :off) 0))) + +(defun decode-save-under (x) + (declare (optimize (speed 3) (safety 0))) + (ecase x + (1 t) + (0 nil))) +(define-window-accessor save-under (encode-save-under decode-save-under)) -(defmethod (setf drawable-backing-store) (nv (window window)) - (let ((attrs (x11:make-xsetwindowattributes))) - (setf (x11:xsetwindowattributes-backing-store attrs) (if nv 1 0)) - (x11:xchangewindowattributes (object-display window) - window - x11::cwbackingstore ;; - attrs) - nv)) +;;--- Something else should be here. -(defmethod drawable-backing-store ((window window)) +(defmethod window-depth ((window window)) (let ((attrs (x11:make-xwindowattributes))) (x11:xgetwindowattributes (object-display window) window attrs) - (not (zerop (x11:xwindowattributes-backing-store attrs))))) + (x11:xwindowattributes-depth attrs))) + +(defmethod drawable-width ((window window)) + (window-width window)) +(defmethod drawable-height ((window window)) + (window-height window)) +(defmethod drawable-depth ((window window)) + (window-depth window)) (defclass pixmap (drawable) ((width :initarg :width :reader pixmap-width) (height :initarg :height :reader pixmap-height) - (depth :initarg :depth :reader drawable-depth))) + (depth :initarg :depth :reader pixmap-depth))) + +(defmethod drawable-width ((pixmap pixmap)) + (pixmap-width pixmap)) +(defmethod drawable-height ((pixmap pixmap)) + (pixmap-height pixmap)) +(defmethod drawable-depth ((pixmap pixmap)) + (pixmap-depth pixmap)) (defun destroy-pixmap (pixmap) - (unregister-xid pixmap) - (x11:xfreepixmap (object-display pixmap) pixmap)) + (let ((display (object-display pixmap))) + (unregister-xid pixmap display) + (x11:xfreepixmap display pixmap))) (defmethod initialize-instance :after ((p pixmap) &key foreign-address width height depth drawable) @@ -107,7 +158,7 @@ width height depth)) - (register-xid p)))) + (register-xid p display)))) (defun-c-callable x-error-handler ((display :unsigned-long) (x :unsigned-long)) (error "x-error:~S" @@ -119,9 +170,9 @@ (defun get-error-text (code display-handle) - (let ((s (string-to-char* (make-string 1000)))) + (let ((s (make-string 1000))) (x11::xgeterrortext display-handle code s 1000) - (char*-to-string s))) + s)) (defun setup-error-handlers () (x11:xseterrorhandler (register-function 'x-error-handler)) @@ -135,6 +186,7 @@ (intern-object-xid (x11:xdefaultrootwindow display) 'window + display :display display)) (defmethod display-screen-number (display) @@ -148,6 +200,7 @@ (x11:xdefaultcolormap display screen) 'colormap + display :display display)) @@ -177,7 +230,7 @@ (if (zerop (x11:xlookupcolor (object-display colormap) colormap - (string-to-char* color-name) + color-name exact closest)) (error "Could not find ~S in colormap ~S" color-name colormap) @@ -245,10 +298,12 @@ (intern-object-xid (aref root 0) 'window + display :display display) (intern-object-xid (aref child 0) 'window + display :display display) (aref root-x 0) (aref root-y 0) diff --git a/tk/xm-classes.lisp b/tk/xm-classes.lisp index 74f6e479cc4739efd4cdac0e2c1e1fa500e3e77f..8304e732dd453d2302e7975edfb08a3f609d4479 100644 --- a/tk/xm-classes.lisp +++ b/tk/xm-classes.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-classes.lisp,v 1.3 92/03/30 17:51:54 cer Exp $ +;; $fiHeader: xm-classes.lisp,v 1.4 92/04/15 11:44:56 cer Exp $ (provide :climxm) @@ -76,4 +76,7 @@ "_xmTextFieldWidgetClass" "_xmTextWidgetClass" "_xmToggleButtonGadgetClass" - "_xmToggleButtonWidgetClass")) + "_xmToggleButtonWidgetClass" + + "_xmMyDrawingAreaWidgetClass" + )) diff --git a/tk/xm-defs.lisp b/tk/xm-defs.lisp index 51e0454299fb874e1ca38b662c35ac69d41542e6..756d9db8fa96f75bd8a6e4da86502eeeb2b4d405 100644 --- a/tk/xm-defs.lisp +++ b/tk/xm-defs.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-defs.lisp,v 1.3 92/04/28 09:25:07 cer Exp Locker: cer $ +;; $fiHeader: xm-defs.lisp,v 1.4 92/05/06 15:37:10 cer Exp Locker: cer $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -28,7 +28,7 @@ (in-package :tk) -(def-c-type (xm-proto-callback-info :no-defuns) :struct +(def-c-type (xm-proto-callback-info :no-defuns :in-foreign-space) :struct (handle :int) (data :int)) diff --git a/tk/xm-protocols.lisp b/tk/xm-protocols.lisp index d26f77b1622df5c04c4b34d30deaa45d0231c853..94705362e4f743d5e11b8ca51156040f35c0a63d 100644 --- a/tk/xm-protocols.lisp +++ b/tk/xm-protocols.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-protocols.lisp,v 1.6 92/04/21 20:27:48 cer Exp Locker: cer $ +;; $fiHeader: xm-protocols.lisp,v 1.7 92/04/28 09:25:10 cer Exp Locker: cer $ (in-package :tk) @@ -83,7 +83,7 @@ (defun xm-intern-atom (shell name &optional only-if-exists) (xm_intern_atom (object-display shell) - (string-to-char* (string name)) + (string name) (if only-if-exists 1 0))) diff --git a/tk/xt-defs.lisp b/tk/xt-defs.lisp index c9cbeb6f6182d1ecb83f8819aed11063f07a863b..26b6e7596f65f458999ba54582707097524fe247 100644 --- a/tk/xt-defs.lisp +++ b/tk/xt-defs.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-defs.lisp,v 1.1 92/04/21 16:40:03 cer Exp Locker: cer $ +;; $fiHeader: xt-defs.lisp,v 1.2 92/04/21 20:27:50 cer Exp $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -139,7 +139,13 @@ (def-c-type (class-array :no-defuns) 1 :unsigned-long) -(def-c-type (x-arglist :in-foreign-space :no-defuns) 1 :unsigned-long) +(def-c-type (xt-arg-val :no-defuns) * :void) + +(def-c-type (xt-arg :in-foreign-space :no-defuns) :struct + (name * :char) + (value xt-arg-val)) + +(def-c-type (xt-arglist :in-foreign-space :no-defuns) 1 xt-arg) (def-c-type (xt-widget-list :no-defuns) 1 * xt-widget) diff --git a/utils/lisp-utilities.lisp b/utils/lisp-utilities.lisp index 475b190db61f1ec2d1c818bbcf7eb66b334b23f4..5ff7cbca68dd7a4c567b880942cc8168b87714e6 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.8 92/04/15 11:45:31 cer Exp $ +;; $fiHeader: lisp-utilities.lisp,v 1.9 92/05/07 13:11:38 cer Exp Locker: cer $ (in-package :clim-utils) @@ -123,6 +123,14 @@ ,@(mapcar #'(lambda (x) `(setq ,x (fix-coordinate ,x))) coords))) +;; Assume that the value is a fixnum and that the result is a fixnum. +(defmacro fast-abs (int) + (let ((val (gensym))) + `(let ((,val ,int)) + (declare (fixnum ,val)) + (the fixnum (if (< ,val 0) (the fixnum (- 0 ,val)) ,val))))) + + ;; COORDINATE-PAIRS is a list of pairs of coordinates. ;; The coordinates must be of type COORDINATE (defmacro translate-coordinates (x-delta y-delta &body coordinate-pairs) @@ -136,34 +144,44 @@ (the coordinate (+ ,(second pts) ,y-delta))) forms)) (nreverse forms))))) +;; +;; Note that this macro evaluates its arguments multiple times. +;; (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)) + "There must be an even number of elements in ~S" positions) + (let ((forms nil) + (nx (gensym)) + (ny (gensym))) (loop (when (null positions) (return `(progn ,@(nreverse forms)))) (let* ((x (pop positions)) (y (pop positions))) - (push `(multiple-value-setq (,x ,y) - (multiple-value-bind (nx ny) - (transform-position ,transform ,x ,y) - (values (fix-coordinate nx) (fix-coordinate ny)))) + (push `(multiple-value-bind (,nx ,ny) + (transform-position ,transform ,x ,y) + (setq ,x (fix-coordinate ,nx) + ,y (fix-coordinate ,ny))) forms))))) +;; +;; Note that this macro evaluates its arguments multiple times. +;; (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)) + (let ((forms nil) + (nx (gensym)) + (ny (gensym))) (loop (when (null positions) (return `(progn ,@(nreverse forms)))) (let* ((x (pop positions)) (y (pop positions))) - (push `(multiple-value-setq (,x ,y) - (multiple-value-bind (nx ny) - (transform-distance ,transform ,x ,y) - (values (fix-coordinate nx) (fix-coordinate ny)))) + (push `(multiple-value-bind (,nx ,ny) + (transform-distance ,transform ,x ,y) + (setq ,x (fix-coordinate ,nx) + ,y (fix-coordinate ,ny))) forms))))) diff --git a/utils/packages.lisp b/utils/packages.lisp index f2f10d513e10e17451c322d1bcfc19e35d38b1cd..14b42b3157e18ff20800e1e27ff17b1083f0882a 100644 --- a/utils/packages.lisp +++ b/utils/packages.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: packages.lisp,v 1.14 92/05/06 15:37:27 cer Exp Locker: cer $ +;; $fiHeader: packages.lisp,v 1.15 92/05/07 13:11:40 cer Exp Locker: cer $ (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user) @@ -3082,6 +3082,7 @@ doseq dovector evacuate-list + fast-abs find-class-that-works fintern flatten-arglist diff --git a/xlib/load-xlib.lisp b/xlib/load-xlib.lisp index 57171f45b2f69b76dae84225af634023cd6eed4a..fdc7b073178a703759a5257a69ccb550a23b6f5b 100644 --- a/xlib/load-xlib.lisp +++ b/xlib/load-xlib.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: load-xlib.lisp,v 1.1 92/03/24 19:43:50 cer Exp Locker: cer $ +;; $fiHeader: load-xlib.lisp,v 1.2 92/03/30 17:52:17 cer Exp $ (in-package :x11) @@ -50,6 +50,8 @@ (defvar *libx11-pathname* "/x11/R4/src/mit/lib/X/libX_d.a") +(unless (ff:get-entry-point (ff:convert-to-lang "lisp_XDrawString")) + (load "xlibsupport.o" :system-libraries (list *libx11-pathname*) :print t)) (x11::load-undefined-symbols-from-library "stub-x.o" (x11::symbols-from-file "misc/undefinedsymbols") diff --git a/xlib/xlib-funs.lisp b/xlib/xlib-funs.lisp index dc3ea8a530be0280bd1b93bcf11cadb10214dad8..756ee9b124553676cb6ca34cb95e1de59476d07e 100644 --- a/xlib/xlib-funs.lisp +++ b/xlib/xlib-funs.lisp @@ -45,7 +45,7 @@ ;; OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION ;; WITH THE USE OR PERFORMANCE OF THIS OBJECT CODE. -;;; $fiHeader: xlib-funs.lisp,v 1.3 92/03/30 17:52:19 cer Exp $ +;;; $fiHeader: xlib-funs.lisp,v 1.5 92/04/21 20:28:07 cer Exp $ (in-package :x11) @@ -805,6 +805,7 @@ (def-exported-foreign-function (xrefreshkeyboardmapping (:return-type int) (:name "_XRefreshKeyboardMapping")) (event (:pointer xmappingevent))) +#+ignore (def-exported-foreign-function (xusekeymap (:return-type int) (:name "_XUseKeymap")) (filename (:pointer char)))