diff --git a/Makefile b/Makefile index 5f0537b766356794df85979691bfeb026e6de05d..aded3456a128ac372b328a480a772c02be6cdf25 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -# $fiHeader: Makefile,v 1.21 92/04/10 14:27:40 cer Exp Locker: cer $ +# $fiHeader: Makefile,v 1.22 92/04/15 11:48:32 cer Exp Locker: cer $ # # Makefile for CLIM 2.0 # @@ -26,9 +26,9 @@ 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 +SRC_FILES = */*.lisp *.lisp Makefile */Makefile misc/make-stub-file \ + misc/undefinedsymbols misc/undefinedsymbols.olit \ + misc/undefinedsymbols.motif misc/undefinedsymbols.xt DEST=/dev/null @@ -72,7 +72,12 @@ FCLIMOBJS= `pwd`/stub-motif.o `pwd`/stub-olit.o `pwd`/stub-x.o `pwd`/stub-xt.o # # "Compile time objects" -- these go into clim-debug.fasl # -DEBUG-OBJS = xlib/ffi.fasl xlib/xlib-defs.fasl xlib/xlib-funs.fasl xlib/x11-keysyms.fasl xlib/load-xlib.fasl xlib/last.fasl +DEBUG-OBJS = xlib/ffi.fasl xlib/xlib-defs.fasl xlib/xlib-funs.fasl \ + xlib/x11-keysyms.fasl xlib/load-xlib.fasl xlib/last.fasl \ + tk/xt-defs.fasl tk/xm-defs.fasl + +# This should be in the clim-debug file but it seems a pain to have to compile it up +# tk/ol-defs.fasl # # "Load time objects" -- these go into clim.fasl @@ -183,7 +188,6 @@ XT-TK-OBJS = xlib/load-xlib.fasl \ tk/font.fasl \ tk/gcontext.fasl \ tk/graphics.fasl \ - tk/xtk.fasl \ tk/meta-tk.fasl \ tk/make-classes.fasl \ tk/foreign.fasl \ @@ -208,6 +212,7 @@ XM-TK-OBJS = tk/xm-classes.fasl \ OL-CLIM-OBJS = tk/ol-classes.fasl \ tk/load-ol.fasl \ tk/xt-funs.fasl \ + tk/ol-funs.fasl \ tk/ol-init.fasl \ tk/ol-callbacks.fasl \ tk/make-widget.fasl @@ -264,8 +269,10 @@ compile-ol: $(CLIMOBJS) FORCE # Concatenation -cat-xm: climg.fasl climxm.fasl clim-debug.fasl -cat-ol: climg.fasl climol.fasl clim-debug.fasl +cat: cat-xm cat-ol +cat-g: climg.fasl clim-debug.fasl +cat-xm: cat-g climxm.fasl +cat-ol: cat-g climol.fasl climg.fasl : $(GENERIC-OBJS) $(XT-OBJS) $(CAT) $(GENERIC-OBJS) $(XT-OBJS) > $(TMP)/clim.fasl_`whoami` @@ -303,6 +310,7 @@ clim-xm: FORCE (load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch $(MV) $(TMP)/clim.temp_`whoami` $(CLIM) ls -lt $(CLIM) >> Clim-sizes.n + size $(CLIM) >> Clim-sizes.n ls -lt $(CLIM) clim-ol: FORCE @@ -314,6 +322,7 @@ clim-ol: FORCE (load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch $(MV) $(TMP)/clim.temp_`whoami` $(CLIM) ls -lt $(CLIM) >> Clim-sizes.n + size $(CLIM) >> Clim-sizes.n ls -lt $(CLIM) @@ -323,6 +332,7 @@ clim-small: FORCE (load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch $(MV) $(TMP)/clim.temp_`whoami` $(CLIM-SMALL) ls -lt $(CLIM-SMALL) >> Clim-sizes.n + size $(CLIM) >> Clim-sizes.n ls -lt $(CLIM-SMALL) # Training @@ -336,7 +346,9 @@ train : FORCE # Misc clean: - find $(DIRS) -name "*.fasl" -print | xargs rm -f ; rm -f clim*.fasl clim-debug.fasl + find $(DIRS) -name "*.fasl" -print | xargs rm -f ; rm -f $(CLIMFASLS) \ + $(CLIMOBJS) slim slim-small + cheapclean: find $(CHEAP_CLEAN) -name "*.fasl" -print | xargs rm -f @@ -410,9 +422,9 @@ stub-xt.c : $(XT_UNDEFS) misc/make-stub-file FRC : xm-composer : xm-dcl - cd /usr/composer2 ; make CL=/vapor/usr/tech/cer/cl/src/dcl rebuild-c2 + cd /usr/composer2 ; make CL=$(CL) rebuild-c2 ol-composer : ol-dcl - cd /usr/composer2 ; make CL=/vapor/usr/tech/cer/cl/src/dcl rebuild-c2 + cd /usr/composer2 ; make CL=$(CL) rebuild-c2 diff --git a/misc/compile-1.lisp b/misc/compile-1.lisp index d2b03f4e9581fc8e9f58bccd8ae9db84f76cf0fd..670f4741122f96523bbd5f9b1ba2425256503f0a 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.1 92/03/24 19:45:40 cer Exp Locker: cer $ +;; $fiHeader: compile-1.lisp,v 1.2 92/04/10 14:27:44 cer Exp Locker: cer $ (in-package :user) @@ -33,6 +33,17 @@ (setf (sys:gsgc-switch :print) t) (setf (sys:gsgc-switch :stats) t) +(setq comp:generate-call-count-code-switch + (named-function |(> debug 1)| + (lambda (safety size speed debug) + (declare (ignore safety size speed)) + (> debug 1)))) +(setq comp:declared-fixnums-remain-fixnums-switch + (named-function |(> speed 2)| + (lambda (safety size speed debug) + (declare (ignore safety size debug)) + (> speed 2)))) + (setq *compile-print* nil) (unless (find-package 'clim-defsystem) @@ -43,7 +54,7 @@ (defun compile-it (sys) - (unless (errorset (clim-defsys::find-system sys)) + (unless (ignore-errors (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 c0a77598108d326aba4d31f451de3e6e59c4e915..3376e01a539b915e02fe8e04f8b79b3c5b9cf3f0 100644 --- a/misc/dev-load-1.lisp +++ b/misc/dev-load-1.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: dev-load-1.lisp,v 1.2 92/04/10 14:27:45 cer Exp Locker: cer $ +;; $fiHeader: dev-load-1.lisp,v 1.3 92/04/15 11:48:34 cer Exp Locker: cer $ (excl::free (excl::malloc 131072)) @@ -40,6 +40,7 @@ (let ((*load-source-file-info* t) (*load-xref-info* nil) (excl:*global-gc-behavior* nil)) + #-ignore (ecase sys (motif-clim (load "climg.fasl") @@ -48,7 +49,12 @@ (openlook-clim (load "climg.fasl") (load "climol.fasl") - (load "clim-debug.fasl"))))) + (load "clim-debug.fasl"))) + #+ignore + (defsys::load-system sys))) + + #+ignore + (defsys:update-system sys) ;;-- What would be good is to mark the files in the system as having ;;-- been loaded diff --git a/misc/load-xm.lisp b/misc/load-xm.lisp index b104f0d655f3e63908c5cae7b93ad80f18d84836..82cf58ad51f23f3652bec2dd3444ff25b9d231b0 100644 --- a/misc/load-xm.lisp +++ b/misc/load-xm.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: load-xm.lisp,v 1.1 92/02/16 20:31:30 cer Exp $ +;; $fiHeader: load-xm.lisp,v 1.2 92/02/24 13:09:54 cer Exp $ (excl::free (excl::malloc 131072)) @@ -32,4 +32,5 @@ (*load-xref-info* nil) (excl:*global-gc-behavior* nil)) (let ((*enable-package-locked-errors* nil)) - (load "clim.fasl")))) + (load "climg.fasl") + (load "climxm.fasl")))) diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp index e0128018f918cad54a5e37f896ef8d3181472245..98ed6b5b7ee0643f6cef56457ad4cb0b76ef376c 100644 --- a/silica/db-scroll.lisp +++ b/silica/db-scroll.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-scroll.lisp,v 1.14 92/04/15 11:45:04 cer Exp Locker: cer $ +;; $fiHeader: db-scroll.lisp,v 1.15 92/04/21 16:12:37 cer Exp Locker: cer $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright(c) 1991, 1992 International Lisp Associates. @@ -307,12 +307,11 @@ (let ((region (viewport-viewport-region vp))) ;;---- we should make the sheet-region bigger at this point ;; perhaps we do a union of the sheet-region and the viewport - (with-sheet-medium (medium vp) - (draw-rectangle* medium - 0 0 - (bounding-rectangle-width region) - (bounding-rectangle-height region) - :ink +background-ink+ :filled t)) + (with-sheet-medium (medium stream) + (multiple-value-call #'draw-rectangle* + medium + (bounding-rectangle* region) + :ink +background-ink+ :filled t)) (replay (stream-output-history stream) stream region))))))))) diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp index 6d51331f3b378e4ebb3b8456a0287de96a687b39..bfe22afbe0d88decb30e734cc0c3ef175953a9ea 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.12 92/04/10 14:27:13 cer Exp Locker: cer $ +;; $fiHeader: sysdcl.lisp,v 1.13 92/04/15 11:47:38 cer Exp Locker: cer $ (in-package #-ANSI-90 "USER" #+ANSI-90 :cl-user) @@ -433,6 +433,7 @@ o :needed-systems (clim-standalone) :load-before-compile (xlib)) ;; General stuff ("pkg") + ("xt-defs") ; Used to be 'xtk'. ("foreign-obj") ("macros") ;; Xlib stuff @@ -442,8 +443,6 @@ o :needed-systems (clim-standalone) ("graphics") ;; Toolkit stuff - ;; ("load-xt") - ("xtk") ("meta-tk") ("make-classes") ("foreign") @@ -461,9 +460,10 @@ o :needed-systems (clim-standalone) :needed-systems (xt-tk) :load-before-compile (xt-tk)) ;; Motif specific stuff + ("xm-defs") + ("xm-classes") ("load-xm") - ;;--- This is really in tk but because of the loading - ("xt-funs") + ("xt-funs") ;;--- This is really in tk but because of the loading ("xm-funs") ("xm-classes") ("xm-init") @@ -483,9 +483,11 @@ o :needed-systems (clim-standalone) :needed-systems (xt-tk) :load-before-compile (xt-tk)) ;; OpenLook specific stuff - ("load-ol") - ("xt-funs") + ("ol-defs") ("ol-classes") + ("load-ol") + ("xt-funs") ;;--- This is really in tk but because of the loading + ("ol-funs") ("ol-init") ("ol-callbacks") #+ignore("ol-examples") diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp index f03fa8c58b266526f4223043d3d0f65780cefd16..40db8d26ad8e628f4692faf2ae04a546f0350ae8 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.8 92/04/10 14:27:47 cer Exp Locker: cer $ +;; $fiHeader: ol-gadgets.lisp,v 1.9 92/04/15 11:48:38 cer Exp Locker: cer $ (in-package :xm-silica) @@ -136,8 +136,9 @@ :button4-motion :button5-motion :button-motion + :exposure ) - 0 + 1 'sheet-mirror-event-handler sheet)) diff --git a/tk-silica/pkg.lisp b/tk-silica/pkg.lisp index b15de6dcd906766b5c1e67e568ff5dbd9315fedf..db95a33cb8f611ec6d01e0da3566420433c8aa16 100644 --- a/tk-silica/pkg.lisp +++ b/tk-silica/pkg.lisp @@ -18,9 +18,11 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: pkg.lisp,v 1.3 92/01/31 14:56:21 cer Exp $ +;; $fiHeader: pkg.lisp,v 1.4 92/02/24 13:06:14 cer Exp $ -(defpackage :xm-silica - (:use clim-lisp clim-utils clim silica tk)) +(defpackage :tk-silica + (:nicknames :xm-silica) + (:use clim-lisp clim-utils clim silica tk) + (:import-from :excl #:if*)) diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index 8392f14aad5b788a7aab995944ee9c929851dd08..74c06d537611455f7b71331714e7c7ddc576d319 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.12 92/04/10 14:27:49 cer Exp Locker: cer $ +;; $fiHeader: xm-frames.lisp,v 1.13 92/04/21 16:13:26 cer Exp Locker: cer $ (in-package :xm-silica) @@ -316,5 +316,5 @@ (tk::set-values shell :icon-name name)) (when pixmap (tk::set-values shell :icon-pixmap (decode-pixmap pixmap))) - (when mask-pixmap - (tk::set-values shell :clip-mask (decode-pixmap mask-pixmap)))))))) + (when clip-mask + (tk::set-values shell :clip-mask (decode-pixmap clip-mask)))))))) diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index fd9aec4a998f7b95559e1ab87df420e5dd40a3c4..7682a8ef97700d0fc51f24715846eea452f08fb6 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.22 92/04/15 11:48:40 cer Exp Locker: cer $ +;; $fiHeader: xm-gadgets.lisp,v 1.23 92/04/21 16:13:27 cer Exp Locker: cer $ (in-package :xm-silica) @@ -157,8 +157,9 @@ :button4-motion :button5-motion :button-motion + :exposure ) - 0 + 1 'sheet-mirror-event-handler sheet)) @@ -424,7 +425,7 @@ :button-press :button-release ) - 0 + 1 'sheet-mirror-event-handler sheet)) @@ -818,6 +819,7 @@ (frame-top-level-sheet frame)) (title "Notify user") documentation + exit-boxes (name title)) (let ((dialog (make-instance (ecase style (:inform 'tk::xm-information-dialog) @@ -831,8 +833,8 @@ )) (result nil)) (multiple-value-bind - (help-button) - (get-message-box-child dialog :help) + (ok-button cancel-button help-button) + (get-message-box-child dialog :ok :cancel :help) (flet ((set-it (widget r) (declare (ignore widget)) (setq result (list r))) @@ -844,9 +846,21 @@ :associated-window associated-window))) (tk::add-callback dialog :ok-callback #'set-it t) (tk::add-callback dialog :cancel-callback #'set-it nil) - (if documentation - (tk::add-callback help-button :activate-callback #'display-help) - (xt::set-sensitive help-button nil)) + + (flet ((set-button-set (name button) + (let ((x (assoc name exit-boxes))) + (cond ((and x (null (second x))) + (tk::unmanage-child button)) + ((second x) + (tk::set-values button :label-string (second x))))))) + (set-button-state :ok ok-button) + (set-button-state :cancel cancel-button) + (set-button-state :help help-button) + + (if documentation + (tk::add-callback help-button :activate-callback #'display-help) + (xt::set-sensitive help-button nil))) + (unwind-protect (progn (tk::manage-child dialog) diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp index 305ec3bcb2c08e02ac676a73afc4af2cb31453fe..9a1cdebdc709988af3c9322f438d0ccbb2c0616d 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.14 92/04/15 11:48:43 cer Exp Locker: cer $ +;; $fiHeader: xm-silica.lisp,v 1.15 92/04/21 16:13:30 cer Exp Locker: cer $ (in-package :xm-silica) @@ -31,6 +31,7 @@ (defmethod find-port-type ((type (eql ':motif))) 'motif-port) + (defmethod change-widget-geometry ((parent tk::xm-drawing-area) child &rest args &key x y width height) diff --git a/tk-silica/xt-cursor.lisp b/tk-silica/xt-cursor.lisp index e0a35c283cda82ecd3e86f0f6fe34b789a2bc70b..e90de9366bbebdcc6d42b8710a790880843d1b4a 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: xm-cursor.lisp,v 1.3 92/03/04 16:20:33 cer Exp Locker: cer $ +;; $fiHeader: xt-cursor.lisp,v 1.4 92/04/03 12:04:55 cer Exp Locker: cer $ (in-package :xm-silica) @@ -65,11 +65,9 @@ port mirror))) (xt::realize-widget gadget) (let ((window (tk::widget-window gadget))) - (setf (tk::drawable-save-under window) t - (xt::drawable-backing-store window) t)) + (setf (tk::drawable-save-under window) t)) ;;--- This really should be done somewhere else but where?????? (let ((window (tk::widget-window (sheet-mirror sheet)))) - (setf (tk::drawable-save-under window) t - (xt::drawable-backing-store window) t)) + (setf (xt::drawable-backing-store window) t)) gadget))))) diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index 477aa7df85cd9043fbb624178858ecf52411aa73..abb9260eeee14781cbdf675073be7d999dc558a5 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -1,4 +1,4 @@ -U;; -*- mode: common-lisp; package: xm-silica -*- +U;; -*- mode: common-lisp; package: tk-silica -*- ;; ;; -[]- ;; @@ -20,9 +20,9 @@ U;; -*- mode: common-lisp; package: xm-silica -*- ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-graphics.lisp,v 1.16 92/04/15 11:48:57 cer Exp Locker: cer $ +;; $fiHeader: xt-graphics.lisp,v 1.17 92/04/21 16:13:36 cer Exp Locker: cer $ -(in-package :xm-silica) +(in-package :tk-silica) (defclass xt-medium (medium) ((foreground-gcontext :reader medium-foreground-gcontext :initform nil) @@ -30,8 +30,8 @@ U;; -*- mode: common-lisp; package: xm-silica -*- (flipping-gcontext :reader medium-flipping-gcontext :initform nil) (drawable :initform nil) (color-p) - (ink-table :initform (make-hash-table)) - (stipple-gcontext :initform nil) ; These don't belong here. + (ink-table :initform (make-hash-table :test #'equal)) + (tile-gcontext :initform nil) ; The following don't belong here. (white-pixel :initform 0) (black-pixel :initform 1))) @@ -53,7 +53,7 @@ U;; -*- mode: common-lisp; package: xm-silica -*- (defmethod engraft-medium :after ((medium xt-medium) (port xt-port) sheet) (with-slots (foreground-gcontext background-gcontext flipping-gcontext color-p - drawable stipple-gcontext white-pixel black-pixel) + drawable tile-gcontext white-pixel black-pixel) medium (setf (medium-sheet medium) sheet) (when (and drawable @@ -75,7 +75,7 @@ U;; -*- mode: common-lisp; package: xm-silica -*- (setf color-p (color-medium-p medium)) (setf white-pixel (x11:xwhitepixel display screen)) (setf black-pixel (x11:xblackpixel display screen)) - (setf stipple-gcontext (make-instance 'tk::gcontext + (setf tile-gcontext (make-instance 'tk::gcontext :drawable drawable :foreground black-pixel :background white-pixel)) @@ -84,7 +84,7 @@ U;; -*- mode: common-lisp; package: xm-silica -*- (defmethod degraft-medium :after ((medium xt-medium) (port xt-port) sheet) (declare (ignore sheet)) (with-slots - (foreground-gcontext background-gcontext flipping-gcontext stipple-gcontext + (foreground-gcontext background-gcontext flipping-gcontext tile-gcontext drawable) medium (setf drawable nil @@ -96,7 +96,7 @@ U;; -*- mode: common-lisp; package: xm-silica -*- (loose-gc foreground-gcontext) (loose-gc background-gcontext) (loose-gc flipping-gcontext) - (loose-gc stipple-gcontext)))) + (loose-gc tile-gcontext)))) (defparameter *use-color* t) ; For debugging monochrome (defun color-medium-p (medium) @@ -140,11 +140,6 @@ U;; -*- mode: common-lisp; package: xm-silica -*- ;;; Colors and their monochrome imposters ;;; Much of this is taken from CLX-IMPLEMENTATION -(defun make-stipple-image (height width patterns) - (make-instance 'tk::image :width width :height height - :data (clim-internals::make-stipple-array height width patterns) - :depth 1)) - (defvar *luminance-stipples* (mapcar #'(lambda (entry) (cons (first entry) (apply #'make-stipple-image (second entry)))) @@ -212,6 +207,9 @@ U;; -*- mode: common-lisp; package: xm-silica -*- (defgeneric decode-ink (ink medium)) +(defmethod decode-ink ((ink (eql +everywhere+)) medium) + (slot-value medium 'foreground-gcontext)) + (defmethod decode-ink ((ink (eql +foreground-ink+)) medium) (slot-value medium 'foreground-gcontext)) @@ -222,19 +220,18 @@ U;; -*- mode: common-lisp; package: xm-silica -*- (slot-value stream 'flipping-gcontext)) (defmethod decode-ink ((ink color) (medium xt-medium)) - (with-slots (ink-table sheet stipple-gcontext white-pixel black-pixel drawable - color-p) + (with-slots (ink-table sheet tile-gcontext white-pixel black-pixel drawable + color-p ink-table) medium - (let ((drawable (or drawable - (tk::display-root-window (port-display (port sheet))))) - (ink-table (slot-value medium 'ink-table))) - (or (gethash ink ink-table) - (let ((new-gc (make-instance 'tk::gcontext :drawable drawable))) - (cond (color-p - (setf (tk::gcontext-foreground new-gc) - (decode-color medium ink))) - (t - (multiple-value-bind (r g b) (color-rgb ink) + (or (gethash ink ink-table) + (let ((drawable (or drawable + (tk::display-root-window (port-display (port sheet))))) + (new-gc (make-instance 'tk::gcontext :drawable drawable))) + (cond (color-p + (setf (tk::gcontext-foreground new-gc) + (decode-color medium ink))) + (t + (multiple-value-bind (r g b) (color-rgb ink) ;; The luminance formula isn't really right. XXX (let* ((luminance (color-luminosity r g b)) (color (decode-luminance luminance t))) @@ -244,16 +241,43 @@ U;; -*- mode: common-lisp; package: xm-silica -*- ((eq color 0) (setf (tk::gcontext-fill-style new-gc) :solid (tk::gcontext-foreground new-gc) white-pixel)) - (t ; color is an image + (t ; color is an image (setf (tk::gcontext-fill-style new-gc) :tiled) (let ((pixmap (make-instance 'tk::pixmap :drawable drawable :width (tk::image-width color) :height (tk::image-height color) :depth (tk::drawable-depth drawable)))) - (tk::put-image pixmap stipple-gcontext color) + (tk::put-image pixmap tile-gcontext color) (setf (tk::gcontext-tile new-gc) pixmap)))))))) - (setf (gethash ink ink-table) new-gc)))))) + (setf (gethash ink ink-table) new-gc))))) + +(defmethod decode-ink ((ink (eql +nowhere+)) medium) + (decode-ink-opacity ink medium)) + +(defmethod decode-ink ((ink standard-opacity) medium) + (decode-ink-opacity ink medium)) + +(defmethod decode-ink-opacity (opacity medium) + (with-slots (ink-table sheet tile-gcontext white-pixel black-pixel drawable + foreground-gcontext color-p ink-table) + medium + (let ((key (cons opacity foreground-gcontext))) + (or (gethash key ink-table) + (unless (eq :solid (tk::gcontext-fill-style foreground-gcontext)) + (warn "opacities may only be use with solid colors ~ +and on color servers, unless using white or black") + (return-from decode-ink-opacity foreground-gcontext)) + (let* ((port (port sheet)) + (display (port-display port)) + (drawable (or drawable (tk::display-root-window display))) + (new-gc (make-instance 'tk::gcontext :drawable drawable))) + + (x11:xcopygc display foreground-gcontext -1 new-gc) + (setf (tk::gcontext-stipple new-gc) (decode-opacity opacity port) + (tk::gcontext-fill-style new-gc) :stippled) + (setf (gethash key ink-table) new-gc)))))) + (defmethod decode-ink ((ink contrasting-ink) stream) (decode-ink (make-color-for-contrasting-ink ink) stream)) @@ -354,11 +378,12 @@ U;; -*- mode: common-lisp; package: xm-silica -*- (fix-coordinate (- c a)) (fix-coordinate (- d b))) (setf (tk::gcontext-clip-mask gc) x)))))) - (when (eq (tk::gcontext-fill-style gc) :tiled) + (when (member (tk::gcontext-fill-style gc) '(:tiled :stippled) :test #'eq) (setf (tk::gcontext-ts-x-origin gc) x-origin (tk::gcontext-ts-y-origin gc) y-origin)) gc)) +#+ignore (defmethod decode-ink :around ((ink t) (medium xt-medium)) (let ((gc (call-next-method))) gc)) @@ -473,21 +498,19 @@ U;; -*- mode: common-lisp; package: xm-silica -*- (port-draw-transformed-rectangle* port sheet medium x1 y1 x2 y2 filled)))) -(ff::def-c-type (xpoint-array :in-foreign-space) 2 x11::xpoint) - (defmethod port-draw-polygon* ((port xt-port) sheet medium list-of-x-and-ys closed filled) (let* ((transform (sheet-device-transformation sheet)) (npoints (/ (length list-of-x-and-ys) 2)) - (points (excl::malloc ;; BUG BUG BUG - (* 4 (cond ((and closed (not filled)) - (incf npoints)) - (t npoints))))) + (points (xt::make-xpoint-array :number (cond ((and closed (not filled)) + (incf npoints)) + (t npoints)))) (window (medium-drawable medium)) ;; These really are fixnums, since we're fixing coordinates below (minx most-positive-fixnum) - (miny most-positive-fixnum)) + (miny most-positive-fixnum) + ink) (do ((ps list-of-x-and-ys (cddr ps)) (i 0 (1+ i)) r) @@ -498,21 +521,22 @@ U;; -*- mode: common-lisp; package: xm-silica -*- (convert-to-device-coordinates transform x y) (minf minx x) (minf miny y) - (setf (xpoint-array-x points i) x - (xpoint-array-y points i) y))) + (setf (tk::xpoint-array-x points i) x + (tk::xpoint-array-y points i) y))) (when (and closed (not filled)) - (setf (xpoint-array-x points (- npoints 1)) (xpoint-array-x points 0) - (xpoint-array-y points (- npoints 1)) (xpoint-array-y points 0))) + (setf (tk::xpoint-array-x points (- npoints 1)) (tk::xpoint-array-x points 0) + (tk::xpoint-array-y points (- npoints 1)) (tk::xpoint-array-y points 0))) + (setq ink + (adjust-ink medium (decode-ink (medium-ink medium) medium) + (medium-ink medium) + (medium-line-style medium) + minx miny)) (when (medium-drawable medium) (if filled (x11:xfillpolygon (tk::object-display window) window - (adjust-ink medium - (decode-ink (medium-ink medium) medium) - (medium-ink medium) - (medium-line-style medium) - minx miny) + ink points npoints x11:complex @@ -520,11 +544,7 @@ U;; -*- mode: common-lisp; package: xm-silica -*- (x11:xdrawlines (tk::object-display window) window - (adjust-ink medium - (decode-ink (medium-ink medium) medium) - (medium-ink medium) - (medium-line-style medium) - minx miny) + ink points npoints x11:coordmodeorigin))))) @@ -644,5 +664,37 @@ U;; -*- mode: common-lisp; package: xm-silica -*- (height (- from-bottom from-top)) (copy-gc (port-copy-gc port))) (when (and from-drawable to-drawable) - (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 + (setq seq-no (x11:xnextrequest (port-display port))) + (tk::copy-area from-drawable copy-gc from-left from-top + width height to-drawable to-left to-top)) + (let ((event + (tk::get-event-matching-sequence-and-types + to-drawable seq-no + '(:graphics-expose :no-expose)))) + (case (tk::event-type event) + (:no-expose + nil) + (:graphics-expose + (loop + (let* ((minx (x11::xexposeevent-x event)) + (miny (x11::xexposeevent-y event)) + (width (x11::xexposeevent-width event)) + (height (x11::xexposeevent-height event)) + (maxx (+ minx width)) + (maxy (+ miny height))) + (dispatch-repaint + to-sheet + (make-instance 'window-repaint-event + :native-region (make-bounding-rectangle minx miny maxx maxy) + :region (untransform-region + (sheet-native-transformation to-sheet) + (make-bounding-rectangle minx miny maxx maxy)) + :sheet to-sheet))) + (setq event (tk::get-event-matching-sequence-and-types + to-drawable seq-no '(:graphics-expose) + :block nil)) + (unless event + (return)))))))))))))) diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index 2c516896be56705b9f1d40e2d2c105a9929fbbf7..13d4bb5737f66eaf55a68953f13a7b8f5320133c 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.19 92/04/15 11:49:06 cer Exp Locker: cer $ +;; $fiHeader: xt-silica.lisp,v 1.20 92/04/21 16:13:39 cer Exp Locker: cer $ (in-package :xm-silica) @@ -29,8 +29,11 @@ (display :reader port-display) (context :reader port-context) (copy-gc :initform nil) + (opacities :initform nil) (type :allocation :class :initform :xt :reader port-type) + (event-lock :initform (clim-sys:make-lock "port event lock") + :reader port-event-lock) (menu-cache :initform nil :accessor port-menu-cache)) @@ -42,8 +45,23 @@ (or copy-gc (setf copy-gc (make-instance 'tk::gcontext - :display display - :foreign-address (x11:screen-default-gc (x11:xdefaultscreenofdisplay (port-display port)))))))) + :display display + :graphics-exposures :on + :foreign-address (x11:screen-default-gc + (x11:xdefaultscreenofdisplay display))))))) + + + +(defmethod restart-port ((port xt-port)) + (let ((process (silica::port-process port))) + (when process + (clim-sys:destroy-process process))) + (setf (silica::port-process port) + (mp:process-run-restartable-function + (list :name (format nil "CLIM Event Dispatcher for ~A" + (port-server-path port)) + :priority 1000) + #'silica::port-event-loop port))) (defmacro destructure-x-server-path ((&key display) path &body body) ;;-- Of course the port ends up with an unspecified server-path. @@ -134,7 +152,8 @@ :name *xt-fallback-font*))) ;;; Perhaps we should just grab the first font we can find. (t - (error "Unable to determine default font")))))) + (error "Unable to determine default font"))))) + (setup-opacities port display)) (defparameter *xt-logical-size-alist* '((:tiny 6) @@ -150,7 +169,105 @@ (standardize-text-style-1 port style character-set *xt-logical-size-alist*)) +(defun make-stipple-image (height width patterns) + (make-instance 'tk::image :width width :height height + :data (clim-internals::make-stipple-array height width patterns) + :depth 1)) + +(defvar *opacity-stipples* + (mapcar #'(lambda (entry) + (cons (first entry) + (apply #'make-stipple-image (second entry)))) + '((+nowhere+ (1 1 (#b0))) + (0.05 (8 06 (#b1000000000000000 + #b0000001000000000 + #b0000000000001000 + #b0010000000000000 + #b0000000010000000 + #b0000000000000010 + #b0000100000000000 + #b0000000000100000))) + (0.1 (8 8 (#b10000000 + #b00010000 + #b00000010 + #b01000000 + #b00001000 + #b00000001 + #b00100000 + #b00000100))) + (0.2 (4 4 (#b1000 + #b0010 + #b0100 + #b0001))) + (0.3 (3 3 (#b100 + #b010 + #b001))) + (0.4 (2 2 (#b10 + #b01))) + (0.6 (3 3 (#b011 + #b101 + #b110))) + (0.7 (4 4 (#b0111 + #b1101 + #b1011 + #b1110))) + (0.8 (8 8 (#b01111111 + #b11101111 + #b11111101 + #b10111111 + #b11110111 + #b11111110 + #b11011111 + #b11111011))) + (0.9 (8 06 (#b0111111111111111 + #b1111110111111111 + #b1111111111110111 + #b1101111111111111 + #b1111111101111111 + #b1111111111111101 + #b1111011111111111 + #b1111111111011111))) + (+everywhere+ (1 1 (#b1)))))) + + +(defun setup-opacities (port display) + (let ((opacities nil) + (root (tk::display-root-window display)) + gc) + (dolist (ls *opacity-stipples*) + (let ((pixmap (make-instance 'tk::pixmap + :drawable root + :width (tk::image-width (cdr ls)) + :height (tk::image-height (cdr ls)) + :depth 1))) + (unless gc + (setq gc (make-instance 'tk::gcontext :drawable pixmap + :foreground 1 :background 0))) + (tk::put-image pixmap gc (cdr ls)) + (push (cons (car ls) pixmap) opacities))) + (when gc + (tk::free-gcontext gc)) + (setf (slot-value port 'opacities) (nreverse opacities)))) + +;; +;; Takes an opacity, and returns a clip mask (pixmap) for that opacity. +;; +(defun decode-opacity (opacity port) + (let ((pops (slot-value port 'opacities))) + (cond ((eq opacity +nowhere+) + (cdar pops)) + ((eq opacity +everywhere+) + (cdar (last pops))) + (t + (let ((lastpop (cdar pops)) + (value (opacity-value opacity))) + (dolist (pop (cdr pops) lastpop) + (if (< value (car pop)) + (return lastpop)) + (setq lastpop (cdr pop)))))))) + + (defmethod destroy-mirror ((port xt-port) sheet) ;;-- I dont think that we should do this. (tk::destroy-widget (sheet-direct-mirror sheet))) @@ -166,7 +283,7 @@ (initialize-mirror port sheet widget) widget)))) -(defmethod initialize-mirror (port sheet widget) +(defmethod initialize-mirror ((port xt-port) sheet widget) (add-sheet-callbacks port sheet widget)) (defmethod add-sheet-callbacks ((port xt-port) sheet (widget t)) @@ -178,9 +295,12 @@ (declare (ignore same-p root child root-x root-y)) (let ((modifiers (logand #16rff mask)) (button (ash mask -8))) + #+ignore + (format excl:*initial-terminal-io* "Got event ~s~%" (tk::event-type event)) (let ((clim-event (ecase (tk::event-type event) - ((:map-notify :unmap-notify) + ((:map-notify :unmap-notify :selection-clear :selection-request + :selection-notify :client-message :mapping-notify) nil) (:configure-notify (sheet-mirror-resized-callback @@ -204,7 +324,6 @@ (state->modifiers (x11::xkeyevent-state event) nil)))) - (:key-release (multiple-value-bind (character keysym) (lookup-character-and-keysym sheet widget event) @@ -216,7 +335,6 @@ (state->modifiers (x11::xkeyevent-state event) nil)))) - (:button-press (make-instance 'pointer-button-press-event :sheet sheet @@ -300,6 +418,9 @@ (height (x11::xexposeevent-height event)) (maxx (+ minx width)) (maxy (+ miny height))) + #+ignore + (format excl:*initial-terminal-io* "Got expose event ~s~%" + (tk::event-type event)) (dispatch-repaint sheet (make-instance 'window-repaint-event @@ -540,10 +661,23 @@ (list target-left target-top w h) (list nx ny nw nh))))))) -(defmethod process-next-event (port &key wait-function timeout) - (tk::process-one-event (port-context port) - :wait-function wait-function - :timeout timeout)) +(defmacro with-port-event-lock ((port) &body body) + `(clim-sys:with-lock-held ((port-event-lock ,port)) + ,@body)) + +(defmethod process-next-event ((port xt-port) &key wait-function timeout) + (with-slots (context event-lock) port + (multiple-value-bind (mask reason) + (tk::wait-for-event context + :wait-function wait-function + :timeout timeout) + (clim-sys:with-lock-held (event-lock) + ;; Make sure there is still an event ready, so we don't block in C. + (multiple-value-setq (mask reason) + (tk::wait-for-event context + :wait-function wait-function + :timeout timeout)) + (tk::process-one-event context mask reason))))) (defmethod port-force-output ((port xt-port)) ;;--- move to tk @@ -592,10 +726,6 @@ (defmethod text-style-descent ((text-style standard-text-style) (port xt-port)) (tk::font-descent (text-style-mapping port text-style))) -#+ignore -(ff::defforeign 'xtsetkeyboardfocus - :entry-point "_XtSetKeyboardFocus") - (defmethod stream-set-input-focus (stream) nil) @@ -786,9 +916,8 @@ (defun lookup-character-and-keysym (sheet mirror event) (declare (ignore sheet mirror)) - (multiple-value-bind (ignore character keysym) + (multiple-value-bind (character keysym) (tk::lookup-string event) - (declare (ignore ignore)) (setq character (and (= (length character) 1) (aref character 0))) ;;--- Map the asci control-characters into the common lisp ;;--- control characters except where they are special! diff --git a/tk/callbacks.lisp b/tk/callbacks.lisp index e90d18d0c05b79eed61d6bc881ed7a3271de7a0e..541ca7e00f39fd2836f6ca28b7fd0232c126d878 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.8 92/03/09 17:40:32 cer Exp Locker: cer $ +;; $fiHeader: callbacks.lisp,v 1.9 92/03/30 17:51:25 cer Exp $ (in-package :tk) @@ -57,7 +57,7 @@ (multiple-value-bind (name type) (convert-callback-name callback-name) - (add_callback + (xt_add_callback widget name *callback-handler-address* @@ -131,20 +131,9 @@ (setf (third z) (string-to-char* (second z)))) (fourth z)))) - -(def-c-type (x-push-button-callback-struct :in-foreign-space) :struct - (reason :int) - (event * x11:xevent) - (click-count :int)) - (defmethod spread-callback-data (widget data (type (eql :activate))) (x-push-button-callback-struct-click-count data)) -(def-c-type (x-drawing-area-callback :in-foreign-space) :struct - (reason :int) - (event * x11:xevent) - (window x11:window)) - (defmethod spread-callback-data (widget call-data (type (eql 'drawing-area))) (values (x-drawing-area-callback-window call-data) (x-drawing-area-callback-event call-data))) diff --git a/tk/convenience.lisp b/tk/convenience.lisp index eb95c716717b2770307a87348dd475580458dc26..426ff780eeaa9e9a7e4a6d42e6e19721bd0f8fa8 100644 --- a/tk/convenience.lisp +++ b/tk/convenience.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: convenience.lisp,v 1.6 92/03/30 17:51:29 cer Exp Locker: cer $ +;; $fiHeader: convenience.lisp,v 1.7 92/04/21 16:12:18 cer Exp Locker: cer $ (in-package :tk) @@ -51,7 +51,7 @@ arglist (truncate (length arglist) 2)))) (when managed - (manage_child o)) + (xt_manage_child o)) o))))) (define-convenience-class xm-menu-bar (xm-row-column) "_XmCreateMenuBar") diff --git a/tk/event.lisp b/tk/event.lisp index 759f10f9c145a6654c8201a0971512f126957806..a66e382a88ef634a43e9e5b472a34e5341f45835 100644 --- a/tk/event.lisp +++ b/tk/event.lisp @@ -20,58 +20,102 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: event.lisp,v 1.7 92/03/30 17:51:31 cer Exp $ +;; $fiHeader: event.lisp,v 1.8 92/04/15 11:44:40 cer Exp Locker: cer $ (in-package :tk) (defun simple-event-loop (context) - (loop - (process-one-event context))) + (loop + (multiple-value-bind (mask reason) + (wait-for-event context) + (process-one-event context mask reason)))) (defconstant *xt-im-xevent* 1) (defconstant *xt-im-timer* 2) (defconstant *xt-im-alternate-input* 4) (defconstant *xt-im-all* (logior *xt-im-xevent* *xt-im-timer* *xt-im-alternate-input*)) -(defun process-one-event (context &key timeout wait-function) - (let (mask +(defun wait-for-event (context &key timeout wait-function) + (let ((mask 0) (fds (mapcar #'(lambda (display) (x11::display-fd display)) (application-context-displays context))) - reason) + (reason nil)) + (declare (fixnum mask)) - (unwind-protect - (progn (mapc #'multiprocessing::mpwatchfor fds) - (flet ((wait-function () - (or (plusp (setq mask (app-pending context))) - (and wait-function - (funcall wait-function) - (setq reason :wait))))) - (if timeout - (multiprocessing:process-wait-with-timeout - "Waiting for toolkit" - timeout - #'wait-function) - (mp::process-wait - "Waiting for toolkit" - #'wait-function)))) - (mapc #'multiprocessing::mpunwatchfor fds)) - (cond ((plusp mask) - (app-process-event - context - ;; Because of a feature in the OLIT toolkit we need to - ;; give preference to events rather than timer events - (if (logtest mask *xt-im-xevent*) *xt-im-xevent* mask)) - t) - (reason :wait-function) - (t :timeout)))) - - -(defun app-pending (context) - (app_pending context)) - -(defun app-process-event (context mask) - (app_process_event context mask)) + (flet ((wait-function (fd) + (declare (ignore fd)) + (or (plusp (setq mask (xt_app_pending context))) + (and wait-function + (funcall wait-function) + (setq reason :wait))))) + (mp:wait-for-input-available fds :wait-function #'wait-function + :timeout timeout)) + (values mask reason))) + +(defun process-one-event (context mask reason) + (cond ((plusp mask) + (xt_app_process_event + context + ;; Because of a feature in the OLIT toolkit we need to + ;; give preference to events rather than timer events + (if (logtest mask *xt-im-xevent*) *xt-im-xevent* mask)) + t) + (reason :wait-function) + (t :timeout))) + +(defun-c-callable match-event-sequence-and-types ((display :unsigned-long) + (event :unsigned-long) + (arg :unsigned-long)) + ;; Arg points to a n element (unsigned-byte 32) vector, where the first + ;; element is the display, the second is the sequence number, and + ;; the other elements are the event types to be matched (null terminated). + (let ((desired-display (sys:memref-int arg 0 0 :unsigned-long)) + (desired-sequence (sys:memref-int arg 4 0 :unsigned-long)) + (event-type (x11:xevent-type event))) + (if (and (eql desired-display display) + (eql desired-sequence (x11:xanyevent-serial event)) + (do* ((i 8 (+ i 4)) + (desired-type (sys:memref-int arg i 0 :unsigned-long) + (sys:memref-int arg i 0 :unsigned-long))) + ((zerop desired-type) nil) + (if (eql desired-type event-type) + (return t)))) + 1 + 0))) + + +(defparameter *match-event-sequence-and-types-address* + (register-function 'match-event-sequence-and-types)) + +(defun get-event-matching-sequence-and-types (display-object seq-no types + &key (block t)) + (unless (consp types) + (setq types (list types))) + (let ((display (object-display display-object)) + (data (make-array (+ 3 (length types)) + :element-type '(unsigned-byte 32))) + (i 2) + (resulting-event (x11:make-xevent))) + (declare (type (simple-array (unsigned-byte 32) (*)) data) + (fixnum i)) + (setf (aref data 0) (ff:foreign-pointer-address display)) + (setf (aref data 1) seq-no) + (dolist (type types) + (setf (aref data i) (position type tk::*event-types*)) + (incf i)) + (setf (aref data i) 0) + (cond (block + (x11:xifevent display resulting-event + *match-event-sequence-and-types-address* data) + resulting-event) + ((zerop (x11:xcheckifevent display resulting-event + *match-event-sequence-and-types-address* + data)) + nil) + (t + resulting-event)))) + (defvar *event* nil) @@ -93,7 +137,7 @@ (defvar *event-handler-address* (register-function 'event-handler)) (defun add-event-handler (widget events maskable function &rest args) - (add_event_handler + (xt_add_event_handler widget (encode-event-mask events) maskable diff --git a/tk/font.lisp b/tk/font.lisp index e936c9cc93ced2c4498b7070d995d92492e43a90..dbf4ac054fd5b3dc21ba3836367650d47872af9b 100644 --- a/tk/font.lisp +++ b/tk/font.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: font.lisp,v 1.8 92/03/30 17:51:32 cer Exp $ +;; $fiHeader: font.lisp,v 1.9 92/04/15 11:44:42 cer Exp Locker: cer $ (in-package :tk) @@ -47,8 +47,6 @@ :display display :foreign-address h))) -(def-c-type (xcharstruct-vector :in-foreign-space) 1 x11:xcharstruct) - (defmethod font-width (font) (x11::xfontstruct-max-bounds-width font)) @@ -79,8 +77,6 @@ (x11:xfontstruct-per-char font) (- index min))))) -(def-c-type (xfontname-list :in-foreign-space) 1 * :char) - (defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list)) (with-ref-par ((n 0)) (let* ((names (x11:xlistfonts display @@ -94,8 +90,6 @@ (setf (elt seq i) (char*-to-string (xfontname-list names i)))) (x11::xfreefontnames names))))) -(def-c-type (xfontstruct-array :in-foreign-space) 1 x11::xfontstruct) - (defun list-font-names-with-info (display pattern &key (max-fonts 65535) (result-type 'list)) (with-ref-par ((n 0) (fonts 0)) diff --git a/tk/foreign.lisp b/tk/foreign.lisp index d5ffe848cfe445c9978beb696978b2531a0721bf..3eb05c3482bc629387f2badb0bfb4c667fa52365 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.8 92/04/03 12:03:57 cer Exp Locker: cer $ +;; $fiHeader: foreign.lisp,v 1.9 92/04/15 11:44:43 cer Exp Locker: cer $ (in-package :tk) @@ -40,12 +40,12 @@ (register-function 'toolkit-warning-handler)) (defmethod initialize-instance :after ((c application-context) &key context) - (let ((context (or context (create_application_context)))) + (let ((context (or context (xt_create_application_context)))) (setf (foreign-pointer-address c) context) - (app_set_error_handler + (xt_app_set_error_handler context *error-handler-function-address*) - (app_set_warning_handler + (xt_app_set_warning_handler context *warning-handler-function-address*))) @@ -61,7 +61,7 @@ (argc 0) (argv 0)) (let ((d (with-ref-par ((argc argc)) - (open_display context + (xt_open_display context (if host host 0) diff --git a/tk/gcontext.lisp b/tk/gcontext.lisp index bd2854ae3f663a98d94ff4e016c7813d0bd36b20..cea65e4c22d2683f1daac2a36c1adad05b0ba3db 100644 --- a/tk/gcontext.lisp +++ b/tk/gcontext.lisp @@ -20,66 +20,104 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: gcontext.lisp,v 1.10 92/04/15 11:44:44 cer Exp Locker: cer $ +;; $fiHeader: gcontext.lisp,v 1.11 92/04/21 16:12:21 cer Exp Locker: cer $ (in-package :tk) (eval-when (compile load eval) - (defconstant *gcontext-components* - '((function :int) - (plane-mask :unsigned-long) - (foreground :unsigned-long) - (background :unsigned-long) - (line-width :int) - (line-style :int) - (cap-style :int) - (join-style :int) - (fill-style :int) - (fill-rule :int) - (arc-mode :int) - (tile :pixmap) - (stipple :pixmap) - (ts-x-origin :int) - (ts-y-origin :int) - (font x-font) - (subwindow-mode :int) - (exposures :boolean) - (clip-x-origin :int) - (clip-y-origin :int) - (clip-mask :pixmap) - (dash-offset :int) - (dashes :char))) - - (defconstant *gcontext-bit-mask* - '(function plane-mask foreground background - line-width line-style cap-style join-style fill-style - fill-rule tile stipple ts-x-origin ts-y-origin font subwindow-mode - exposures clip-x-origin clip-y-origin clip-mask dash-offset dashes - arc-mode))) - - -(eval-when (compile load eval) - (defun gcontext-component-to-slot-definition (x) - (destructuring-bind - (name c-type) x - `(,name :reader ,(intern (format nil "~A-~A" 'gcontext name))))) + #+ignore + (defconstant *gcontext-components* + '((function :int) + (plane-mask :unsigned-long) + (foreground :unsigned-long) + (background :unsigned-long) + (line-width :int) + (line-style :int) + (cap-style :int) + (join-style :int) + (fill-style :int) + (fill-rule :int) + (arc-mode :int) + (tile :pixmap) + (stipple :pixmap) + (ts-x-origin :int) + (ts-y-origin :int) + (font x-font) + (subwindow-mode :int) + (graphics-exposures :boolean) + (clip-x-origin :int) + (clip-y-origin :int) + (clip-mask :pixmap) + (dash-offset :int) + (dashes :char))) + + + (defconstant *gcontext-bit-mask* + '(function plane-mask foreground background + line-width line-style cap-style join-style fill-style + fill-rule tile stipple ts-x-origin ts-y-origin font subwindow-mode + graphics-exposures clip-x-origin clip-y-origin clip-mask dash-offset dashes + arc-mode))) + + +(eval-when (compile eval) + #+ignore + (defun gcontext-component-to-slot-definition (x) + (destructuring-bind + (name c-type) x + (declare (ignore c-type)) + `(,name :reader ,(intern (format nil "~A-~A" 'gcontext name))))) - (defun gcontext-component-to-writer (x) - (destructuring-bind - (name c-type) x - `(defmethod (setf ,(intern (format nil "~A-~A" 'gcontext name))) - (nv gc) - (set-gcontext-component - gc - ,(intern (symbol-name name) :keyword) - nv) - (setf (slot-value gc ',name) nv))))) + #+ignore + (defun gcontext-component-to-writer (x) + (destructuring-bind + (name c-type) x + (declare (ignore c-type)) + `(defmethod (setf ,(intern (format nil "~A-~A" 'gcontext name))) + (nv gc) + (set-gcontext-component + gc + ,(intern (symbol-name name) :keyword) + nv) + (setf (slot-value gc ',name) nv)))) + + (defmacro define-gc-writer (name encoder &rest args) + `(progn + (defmethod (setf ,(intern (format nil "~A-~A" 'gcontext name))) + (nv (gc gcontext)) + (let ((gc-values (x11::make-xgcvalues))) + (setf (,(intern (format nil "~A~A" + 'xgcvalues- + name) + :x11) + gc-values) + (,encoder nv ,@args)) + + (x11:xchangegc + (object-display gc) + gc + ,(ash 1 (or (position name *gcontext-bit-mask*) + (error "Cannot find ~S in gcontext components" name))) + gc-values) + nv)))) + + (defmacro define-gc-reader (name decoder &rest args) + `(defmethod ,(intern (format nil "~A-~A" 'gcontext name)) ((gc gcontext)) + (,decoder + (,(intern (format nil "~A~A" '_xgc-values- name) :x11) + gc) + ,@args))) + + (defmacro define-gc-accessor (name (encoder decoder) &rest args) + `(progn + (define-gc-reader ,name ,decoder ,@args) + (define-gc-writer ,name ,encoder ,@args) + ',name))) (defclass gcontext (display-object) ()) - (defmethod initialize-instance :after ((gcontext gcontext) &key foreign-address @@ -89,14 +127,17 @@ cap-style join-style fill-style fill-rule arc-mode tile stipple ts-x ts-y font subwindow-mode - exposures clip-x-origin clip-y-origin + graphics-exposures clip-x-origin clip-y-origin clip-mask clip-ordering dash-offset dashes) (unless foreign-address - (setf foreign-address (x11::xcreategc display drawable 0 0) - (foreign-pointer-address gcontext) foreign-address - (slot-value gcontext 'display) (object-display drawable)) + (unless drawable + (error ":drawable must be specified when creating gcontext")) + (let ((display (object-display drawable))) + (setf foreign-address (x11::xcreategc display drawable 0 0) + (foreign-pointer-address gcontext) foreign-address + (slot-value gcontext 'display) display)) (register-address gcontext foreign-address)) ;;; Set the ones that are specified @@ -118,7 +159,7 @@ (when ts-y (setf (gcontext-ts-y gcontext) ts-y)) (when font (setf (gcontext-font gcontext) font)) (when subwindow-mode (setf (gcontext-subwindow-mode gcontext) subwindow-mode)) - (when exposures (setf (gcontext-exposures gcontext) exposures)) + (when graphics-exposures (setf (gcontext-graphics-exposures gcontext) graphics-exposures)) (when clip-x-origin (setf (gcontext-clip-x-origin gcontext) clip-x-origin)) (when clip-y-origin (setf (gcontext-clip-y-origin gcontext) clip-y-origin)) (when clip-mask (setf (gcontext-clip-mask gcontext clip-ordering) clip-mask)) @@ -127,7 +168,6 @@ gcontext) - (defun free-gcontext (gc) (x11:xfreegc (object-display gc) @@ -137,38 +177,7 @@ (defun lispify-function-name (name) (intern (substitute #\_ #\- (symbol-name (lispify-tk-name name))))) -(defmacro define-gc-writer (name encoder &rest args) - `(progn - (defmethod (setf ,(intern (format nil "~A-~A" 'gcontext name))) - (nv (gc gcontext)) - (let ((gc-values (x11::make-xgcvalues))) - (setf (,(intern (format nil "~A~A" - 'xgcvalues- - name) - :x11) - gc-values) - (,encoder nv ,@args)) - - (x11:xchangegc - (object-display gc) - gc - ,(ash 1 (or (position name *gcontext-bit-mask*) - (error "Cannot find ~S in gcontext components" name))) - gc-values) - nv)))) - -(defmacro define-gc-reader (name decoder &rest args) - `(defmethod ,(intern (format nil "~A-~A" 'gcontext name)) ((gc gcontext)) - (,decoder - (,(intern (format nil "~A~A" '_xgc-values- name) :x11) - gc) - ,@args))) - -(defmacro define-gc-accessor (name (encoder decoder) &rest args) - `(progn - (define-gc-reader ,name ,decoder ,@args) - (define-gc-writer ,name ,encoder ,@args) - ',name)) + ;;; Accessors for the gc @@ -243,7 +252,8 @@ (define-gc-accessor subwindow-mode (encode-enum decode-enum) '(:clip-by-children :include-inferiors)) -(define-gc-accessor exposures (encode-enum decode-enum) '(:off :on)) + +(define-gc-accessor graphics-exposures (encode-enum decode-enum) '(:off :on)) (define-gc-accessor clip-x-origin (encode-int16 decode-int16)) (define-gc-accessor clip-y-origin (encode-int16 decode-int16)) @@ -322,33 +332,33 @@ (error "~S is not a valid line-style" x))) (defmethod (setf gcontext-dashes) (nv (gc gcontext)) - (multiple-value-bind - (n v) + (multiple-value-bind (n v) (encode-dashes nv) (x11:xsetdashes (object-display gc) gc 0 v - n) - (excl::free v))) + n))) (defun encode-dashes (nv) - (let (n v) + (declare (optimize (speed 3) (safety 0))) + (let* ((n (length nv)) + (v (make-array n :element-type '(unsigned-byte 8)))) + (declare (fixnum n) + (type (simple-array (unsigned-byte 8) (*)) v)) (etypecase nv - (list - (setq n (length nv)) - (setq v (excl::malloc n)) + (list (let ((i 0)) + (declare (fixnum i)) (dolist (x nv) - (setf (sys::memref-int v i 0 :unsigned-byte) x) + (declare (type (unsigned-byte 8) x)) + (setf (aref v i) x) (incf i)))) (vector - (setq n (length nv)) - (setq v (excl::malloc n)) (dotimes (i n) - (setf (sys::memref-int v i 0 :unsigned-byte) (aref nv i))))) + (setf (aref v i) (the (unsigned-byte 8) (aref nv i)))))) (values n v))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -366,11 +376,12 @@ (defun decode-card16 (x) x) (defun decode-font (x) + (declare (special gc)) (if (= x #16rffffffff) (error "cannot decode font") (let ((font (find-object-from-xid x nil))) (or font - (query-font display x))))) + (query-font (object-display gc) x))))) (defun decode-pixmap (x) (and (/= #16rffffffff x) @@ -411,18 +422,14 @@ *gcontext-bit-mask* :test #'string=)) r))))) - `(let ((,tgc (allocate-temp-gc gc))) - (x11:xcopygc (object-display gc) - gc - ,bits - ,tgc) + `(let* ((,tgc (allocate-temp-gc gc)) + (.gc. ,gc) + (.display. (object-display .gc.))) + (x11:xcopygc .display. .gc. ,bits ,tgc) (unwind-protect (progn ,@(nreverse setfs) ,@body) - (x11:xcopygc (object-display gc) - ,tgc - ,bits - gc) + (x11:xcopygc .display. ,tgc ,bits .gc.) (deallocate-temp-gc ,tgc))))) (defun allocate-temp-gc (gc) @@ -430,6 +437,8 @@ :drawable (display-root-window (object-display gc)))) (defun deallocate-temp-gc (gc) + (x11:xfreegc (object-display gc) gc) + (setf (ff:foreign-pointer-address gc) 0) nil) #| @@ -437,13 +446,11 @@ (print gc)) |# +(defun decode-pixel (x) x) + (defmethod encode-pixel ((x integer)) x) -(defun decode-pixel (x) x) (defmethod encode-pixel ((x color)) - (allocate-color (default-colormap display 0) x)) - - - - + (declare (special gc)) + (allocate-color (default-colormap (object-display gc) 0) x)) diff --git a/tk/init.lisp b/tk/init.lisp index 401118689c0b588fbb8373a032be91017ea4ed28..d3ece19a63a7f5600ee83f8f09280467c6a48a7e 100644 --- a/tk/init.lisp +++ b/tk/init.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: init.lisp,v 1.3 92/01/31 14:54:45 cer Exp $ +;; $fiHeader: init.lisp,v 1.4 92/02/24 13:03:05 cer Exp $ (in-package :tk) @@ -28,6 +28,6 @@ (defvar *done* nil) (unless *done* (insert_classes) - (toolkit-initialize) + (xt_toolkit_initialize) (make-classes) (setq *done* t)) diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp index dee05f8f875e53713c9791c93aad9b91bd3689fb..e01f193a5aa0d7ee1d473db3c23fd578be306ac4 100644 --- a/tk/make-classes.lisp +++ b/tk/make-classes.lisp @@ -20,22 +20,16 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: make-classes.lisp,v 1.13 92/04/15 11:44:47 cer Exp Locker: cer $ +;; $fiHeader: make-classes.lisp,v 1.14 92/04/21 16:12:22 cer Exp Locker: cer $ (in-package :tk) -#+obsolete -(ff:defforeign 'insert_classes :return-type :fixnum) - - (defun get-entry-point-value (x) (let ((xx (make-array 1 :element-type '(unsigned-byte 32)))) (unless (zerop (get-entry-points (vector x) xx)) (error "Cannot find the entry-point for: ~S" x)) (aref xx 0))) -(def-c-type (class-array :in-foreign-space) 1 :unsigned-long) - (defun get-foreign-variable-value (x) (class-array (get-entry-point-value x) 0)) @@ -60,10 +54,10 @@ r))) (defun get-resource-list (class) - (get-resource-list-internal class #'get-resource-list-1 'resource)) + (get-resource-list-internal class #'xt_get_resource_list 'resource)) (defun get-constraint-resource-list (class) - (get-resource-list-internal class #'get-constraint-resource-list-1 + (get-resource-list-internal class #'xt_get_constraint_resource_list 'constraint-resource)) @@ -134,7 +128,7 @@ (dolist (class-ep classes) (format excl:*initial-terminal-io* ";; Initializing class ~s~%" class-ep) (let ((h (get-foreign-variable-value class-ep))) - (initialize-widget-class h) + (xt_initialize_widget_class h) (push (list h (get-resource-list h) (get-constraint-resource-list h)) @@ -154,10 +148,10 @@ (let ((class (clos::ensure-class (lispify-class-name (widget-class-name handle)) - :direct-superclasses (list (if (zerop (xtk-class-superclass handle)) + :direct-superclasses (list (if (zerop (xt-class-superclass handle)) 'xt-root-class (lispify-class-name (widget-class-name - (xtk-class-superclass handle))))) + (xt-class-superclass handle))))) :direct-slots nil :metaclass 'xt-class :direct-resources direct-resources @@ -204,7 +198,7 @@ (defun widget-class-name (h) - (char*-to-string (xtk-class-name h))) + (char*-to-string (xt-class-name h))) (defun lispify-class-name (x) (let ((name (lispify-tk-name x))) diff --git a/tk/ol-callbacks.lisp b/tk/ol-callbacks.lisp index 2d0d904c9107fac30f1c72de563099c6b83a7238..05e867dc2ab83c57880012c47e4ce9504c783e89 100644 --- a/tk/ol-callbacks.lisp +++ b/tk/ol-callbacks.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-callbacks.lisp,v 1.4 92/02/24 13:03:34 cer Exp Locker: cer $ +;; $fiHeader: ol-callbacks.lisp,v 1.5 92/03/09 17:40:50 cer Exp $ (in-package :tk) @@ -39,21 +39,6 @@ (:dnd_animate 7) )) -(def-c-type (ol-callback-struct :in-foreign-space) :struct - (reason :int)) - -(def-c-type (ol-expose-callback-struct :in-foreign-space) :struct - (reason :int) - (event * x11:xevent)) - - -(def-c-type (ol-resize-callback-struct :in-foreign-space) :struct - (reason :int) - (x xt-position) - (y xt-position) - (width xt-dimension) - (height xt-dimension)) - (defun find-ol-callback-reason (call-data) (or (car (find (tk::ol-callback-struct-reason call-data) *ol-callback-reasons* diff --git a/tk/ol-defs.lisp b/tk/ol-defs.lisp index 9155388866275e536456644cdb5adafb8c763aba..edbd52472fe25383d6cf13bf7bf0fa1f0c83681a 100644 --- a/tk/ol-defs.lisp +++ b/tk/ol-defs.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-init.lisp,v 1.8 92/03/24 19:36:17 cer Exp $ +;; $fiHeader: ol-defs.lisp,v 1.1 92/04/21 16:40:05 cer Exp Locker: cer $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. diff --git a/tk/ol-funs.lisp b/tk/ol-funs.lisp index b9844b2464fad7299f4ed26ab0e644adce204ef6..038ae3dd45fb14241679f970dc2341d5b51e3778 100644 --- a/tk/ol-funs.lisp +++ b/tk/ol-funs.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-init.lisp,v 1.8 92/03/24 19:36:17 cer Exp $ +;; $fiHeader: ol-funs.lisp,v 1.1 92/04/21 16:40:06 cer Exp Locker: cer $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. diff --git a/tk/ol-init.lisp b/tk/ol-init.lisp index 5f2b2ccf33450c10f39c6b64aad1698c946896f3..2c0107a086d9ce0c80be035699e5d8691399077c 100644 --- a/tk/ol-init.lisp +++ b/tk/ol-init.lisp @@ -20,13 +20,11 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-init.lisp,v 1.9 92/04/03 12:04:05 cer Exp Locker: cer $ +;; $fiHeader: ol-init.lisp,v 1.10 92/04/10 14:26:16 cer Exp Locker: cer $ (in-package :tk) -(defforeign 'ol_toolkit_initialize :entry-point "_OlToolkitInitialize") - (defun ol-initialize () (ol_toolkit_initialize)) @@ -49,18 +47,6 @@ (char*-to-string message))) -(defforeign 'ol_set_warning_handler - :entry-point "_OlSetWarningHandler") - -(defforeign 'ol_set_error_handler - :entry-point "_OlSetErrorHandler") - -(defforeign 'ol_set_va_display_error_msg_handler - :entry-point "_OlSetVaDisplayErrorMsgHandler") - -(defforeign 'ol_set_va_display_warning_msg_handler - :entry-point "_OlSetVaDisplayWarningMsgHandler") - (ol_set_warning_handler (register-function 'ol-warning-handler)) (ol_set_va_display_warning_msg_handler (register-function 'ol-warning-va-handler)) (ol_set_error_handler (register-function 'ol-error-handler)) diff --git a/tk/pkg.lisp b/tk/pkg.lisp index 8d1fd7aa468afde347554d5693b77406968d367e..208d6fb5251027e1ea93f0a69e655fdc4d98c99b 100644 --- a/tk/pkg.lisp +++ b/tk/pkg.lisp @@ -20,13 +20,14 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: pkg.lisp,v 1.6 92/03/09 17:40:55 cer Exp Locker: cer $ +;; $fiHeader: pkg.lisp,v 1.7 92/03/30 17:51:47 cer Exp $ (defpackage :tk ;;-- No we really need ;; to use the x11 package? (:use :common-lisp :ff #+ignore :x11) (:nicknames :xt) + (:import-from :excl #:if*) (:export #:initialize-motif-toolkit #:xm-drawing-area diff --git a/tk/resources.lisp b/tk/resources.lisp index 0c78151206b21010c0e45b3847d7991ba0dd1c26..f678d423965191db09e6899021cfef31ce05efc5 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.15 92/04/15 11:44:49 cer Exp Locker: cer $ +;; $fiHeader: resources.lisp,v 1.16 92/04/21 16:12:23 cer Exp Locker: cer $ (in-package :tk) @@ -30,13 +30,15 @@ (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)) (elt ',elements value)))) + (defun set-values (widget &rest values) (let ((arglist (make-arglist-for-class (class-of widget) widget values))) - (set_values widget + (xt_set_values widget arglist (truncate (length arglist) 2)))) @@ -75,15 +77,13 @@ (ff:foreign-pointer-address result)))) (defmethod convert-resource-out ((parent t) (type (eql 'xm-string)) value) - (string_create_l_to_r (string-to-char* value) (string-to-char* ""))) + (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))) -(def-c-type (x-arglist :in-foreign-space) 1 :unsigned-long) - (defun get-values (widget &rest resources) (let* ((class (class-of widget)) (class-resources (class-resources class)) @@ -107,8 +107,7 @@ ;;-- This also ought to be resource allocated (setq arglist (coerce (nreverse arglist) '(vector (signed-byte 32)))) - - (get_values widget + (xt_get_values widget arglist (truncate (length arglist) 2)) @@ -136,7 +135,7 @@ (defmethod convert-resource-in (class (type (eql 'xm-string)) value) (and (not (zerop value)) (with-ref-par ((string 0)) - (string_get_l_to_r value xm_string_default_char_set string) + (xm_string_get_l_to_r value xm_string_default_char_set string) (char*-to-string (sys:memref-int (foreign-pointer-address string) 0 0 :signed-long))))) @@ -223,7 +222,8 @@ (screen (x11:xdefaultscreenofdisplay display)) (white (x11::xwhitepixel display 0)) (black (x11::xblackpixel display 0))) - (get_pixmap screen (string-to-char* value) black white))))) + (xm_get_pixmap screen (string-to-char* value) white black))))) + (defmethod convert-resource-out ((parent t) (type (eql 'boolean)) value) (if value 1 0)) @@ -320,13 +320,11 @@ -(def-c-type (xtk-widget-list :in-foreign-space) 1 * xtk-widget) - (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 (xtk-widget-list x i)) + widget 'widget (xt-widget-list x i)) r)) (nreverse r))) @@ -341,15 +339,16 @@ (defun setup (&optional (hostspec "localhost:0")) - (setq context (create-application-context)) - (setq display (make-instance 'display - :host hostspec - :context context)) - (setq app (app-create-shell :display display :widget-class 'application-shell))) + (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) - (values context display app)) + (setup hostspec)) ;;; ol resource diff --git a/tk/widget.lisp b/tk/widget.lisp index 65ec6171a1072b2e13c35eb2e9c5f72fe2d57d17..ae12733e7bbe4c3a8a6517ccb3a2b1900893ed22 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.16 92/04/15 11:44:53 cer Exp Locker: cer $ +;; $fiHeader: widget.lisp,v 1.17 92/04/21 16:12:25 cer Exp Locker: cer $ (in-package :tk) @@ -37,23 +37,23 @@ (apply #'make-instance class :foreign-address - (app_create_shell application-name - application-class - handle - display - arglist - (truncate (length arglist) 2)) + (xt_app_create_shell application-name + application-class + handle + display + arglist + (truncate (length arglist) 2)) :display display args)))) (defun create-widget (name widget-class parent &rest args) (apply #'create-widget-1 - #'create_widget name widget-class parent + #'xt_create_widget name widget-class parent args)) (defun create-managed-widget (name widget-class parent &rest args) (apply #'create-widget-1 - #'create_managed_widget name widget-class parent + #'xt_create_managed_widget name widget-class parent args)) @@ -68,10 +68,10 @@ (truncate (length arglist) 2)))) (defun realize-widget (widget) - (realize_widget widget)) + (xt_realize_widget widget)) (defun manage-child (child) - (manage_child child)) + (xt_manage_child child)) (defun unmanage-child (child) (unmanage_child child)) @@ -79,26 +79,32 @@ (defun is-managed-p (widget) (not (zerop (xt_is_managed widget)))) + +(defun unmanage-child (child) + (xt_unmanage_child child)) + (defun manage-children (children) - (manage_children (map '(simple-array (signed-byte 32)) + (xt_manage_children (map '(simple-array (signed-byte 32)) #'ff:foreign-pointer-address children) (length children))) (defun destroy-widget (widget) - (destroy_widget widget)) + (xt_destroy_widget widget)) (defun popup (shell) - (_popup shell 0)) + (xt_popup shell + 0)) + (defun popdown (shell) - (_popdown shell)) + (xt_popdown shell)) (defun create-popup-shell (name widget-class parent &rest args) (let* ((class (find-class-maybe widget-class)) (handle (class-handle class)) (arglist (make-arglist-for-class class parent args))) - (create_popup_shell + (xt_create_popup_shell (string-to-char* name) handle parent @@ -129,7 +135,7 @@ (defun widget-class-of (x) (intern-widget-class - (xtk-widget-widget-class x))) + (xt-widget-widget-class x))) (defun intern-widget-class (class) (find-object-from-address class)) @@ -184,19 +190,6 @@ (let ((x (xt_parent widget))) (and (not (zerop x)) (intern-widget x)))) -(def-c-type xt-geometry-mask :unsigned-int) -(def-c-type xt-position :short) -(def-c-type xt-dimension :unsigned-short) - -(def-c-type (xt-widget-geometry :in-foreign-space) :struct - (request-mode xt-geometry-mask) - (x xt-position) - (y xt-position) - (width xt-dimension) - (height xt-dimension) - (border-width xt-dimension) - (sibling xtk-widget) - (stack-mode :int)) (defconstant xt-geometry-yes 0) (defconstant xt-geometry-no 1) diff --git a/tk/xlib.lisp b/tk/xlib.lisp index 1421cfa52613d2bbaa7f80c597a2481b0994281b..7ae9eb6c5795a519fb79733289d04db5c25a5191 100644 --- a/tk/xlib.lisp +++ b/tk/xlib.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xlib.lisp,v 1.14 92/04/15 11:44:54 cer Exp Locker: cer $ +;; $fiHeader: xlib.lisp,v 1.15 92/04/21 16:12:27 cer Exp Locker: cer $ (in-package :tk) @@ -155,7 +155,7 @@ (defmethod initialize-instance :after ((x color) &key foreign-address red green blue) (unless foreign-address - (setq foreign-address (x11::make-xcolor)) + (setq foreign-address (x11::make-xcolor :in-foreign-space t)) (setf (x11::xcolor-red foreign-address) red (x11:xcolor-green foreign-address) green (x11:xcolor-blue foreign-address) blue @@ -172,8 +172,8 @@ (x11:xcolor-blue cm))))) (defun lookup-color (colormap color-name) - (let ((exact (x11::make-xcolor)) - (closest (x11::make-xcolor))) + (let ((exact (x11::make-xcolor :in-foreign-space t)) + (closest (x11::make-xcolor :in-foreign-space t))) (if (zerop (x11:xlookupcolor (object-display colormap) colormap @@ -185,7 +185,8 @@ (make-instance 'color :foreign-address closest))))) (defun allocate-color (colormap x) - (let ((y (x11::make-xcolor))) + (let ((y (x11::make-xcolor :in-foreign-space t)) + (x x)) (setf (x11:xcolor-red y) (x11:xcolor-red x) (x11:xcolor-green y) (x11:xcolor-green x) (x11:xcolor-blue y) (x11:xcolor-blue x)) @@ -344,25 +345,25 @@ (error "cannot encode event-mask ~S" mask)))))) -(warn "remove me") +(defvar *lookup-string-buffers* nil) (defun lookup-string (event) - (let ((buffer (string-to-char* (load-time-value (make-string 4 :initial-element #\null))))) - ;;-- Before anyone goes changing this again they need to remember - ;;-- that buffer needs to be zeroed before hand - (with-ref-par - ((keysym 0)) - (values - (x11:xlookupstring - event - buffer - 2 - keysym - 0) - (prog1 - (char*-to-string buffer) - (excl::free buffer)) - (aref keysym 0))))) + (declare (optimize (speed 3) (safety 0))) + (let ((buffer (or (pop *lookup-string-buffers*) + (excl::malloc 256)))) + (declare (type (unsigned-byte 32) buffer)) + (with-ref-par ((keysym 0)) + (let* ((nchars (x11:xlookupstring event buffer 256 keysym 0)) + (result (make-string nchars))) + (declare (fixnum nchars) + (simple-string result)) + (dotimes (i nchars) + (declare (fixnum i)) + (setf (schar result i) + (code-char (sys:memref-int buffer 0 i :unsigned-byte)))) + (push buffer *lookup-string-buffers*) + (values result + (aref keysym 0)))))) (defclass image (ff:foreign-pointer) ((width :reader image-width :initarg :width) diff --git a/tk/xm-defs.lisp b/tk/xm-defs.lisp index 85214ff85b994869c61b3f4b01697e52a6bf2420..73bdfb6d9b3247c35aa52a6287d317b2d40b325d 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-funs.lisp,v 1.1 92/03/30 17:58:42 cer Exp $ +;; $fiHeader: xm-defs.lisp,v 1.1 92/04/21 16:40:04 cer Exp Locker: cer $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. diff --git a/tk/xm-font-list.lisp b/tk/xm-font-list.lisp index 6624f05219a8696f293a127fb24880859cee314b..756646180da32acec1b79f4c2e9d22b2a3dbea3c 100644 --- a/tk/xm-font-list.lisp +++ b/tk/xm-font-list.lisp @@ -20,25 +20,10 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-font-list.lisp,v 1.5 92/03/09 17:41:05 cer Exp $ +;; $fiHeader: xm-font-list.lisp,v 1.6 92/03/30 17:51:55 cer Exp $ (in-package :tk) -(defforeign 'xm_font_list_init_font_context - :entry-point "_XmFontListInitFontContext") - -(defforeign 'xm_font_list_free_font_context - :entry-point "_XmFontListFreeFontContext") - - -(defforeign 'xm_font_list_get_next_font - :entry-point "_XmFontListGetNextFont") - -(defforeign 'xm_font_list_create - :entry-point "_XmFontListCreate") - - - (defmethod convert-resource-out (parent (type (eql 'font-list)) value) (declare (ignore parent)) (when (atom value) diff --git a/tk/xm-funs.lisp b/tk/xm-funs.lisp index 3aaf2ac711c02e2986dc062229dc3eea173e0dba..2d5ea2fbc093932dcd153980a768de84eadcddf6 100644 --- a/tk/xm-funs.lisp +++ b/tk/xm-funs.lisp @@ -20,20 +20,49 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-funs.lisp,v 1.1 92/03/30 17:58:42 cer Exp Locker: cer $ +;; $fiHeader: xm-funs.lisp,v 1.2 92/04/21 16:12:29 cer Exp Locker: cer $ + +;; +;; This file contains compile time only code -- put in clim-debug.fasl. +;; (in-package :tk) -(defforeign 'string_create_l_to_r +(defforeign 'xm_string_create_l_to_r :entry-point "_XmStringCreateLtoR" :return-type :integer) -(defforeign 'string_get_l_to_r +(defforeign 'xm_string_get_l_to_r :entry-point "_XmStringGetLtoR" :return-type :integer) -(defforeign 'get_pixmap +(defforeign 'xm_get_pixmap :entry-point "_XmGetPixmap") +(defforeign 'xm_font_list_init_font_context + :entry-point "_XmFontListInitFontContext") + +(defforeign 'xm_font_list_free_font_context + :entry-point "_XmFontListFreeFontContext") + +(defforeign 'xm_font_list_get_next_font + :entry-point "_XmFontListGetNextFont") + +(defforeign 'xm_font_list_create + :entry-point "_XmFontListCreate") + +(defforeign 'xm_add_protocol_callback + :entry-point "_XmAddProtocolCallback") + +(defforeign 'xm_intern_atom + :entry-point "_XmInternAtom") + +(defforeign 'xm_main_window_set_area :entry-point + "_XmMainWindowSetAreas") + +(ff:defforeign 'xm_process_traversal + :entry-point "_XmProcessTraversal") + (defforeign 'xm-message-box-get-child :entry-point "_XmMessageBoxGetChild") + diff --git a/tk/xm-protocols.lisp b/tk/xm-protocols.lisp index 759a50ff515e7342305b6265e916672f1909cea8..ee17b10b7fbd89d15b026d5856ea2a424725f14f 100644 --- a/tk/xm-protocols.lisp +++ b/tk/xm-protocols.lisp @@ -20,25 +20,10 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-protocols.lisp,v 1.4 92/02/24 13:04:05 cer Exp Locker: cer $ +;; $fiHeader: xm-protocols.lisp,v 1.5 92/03/09 17:41:09 cer Exp $ (in-package :tk) -(defforeign 'xm_add_protocol_callback - :entry-point "_XmAddProtocolCallback") - -(defforeign 'xm_intern_atom - :entry-point "_XmInternAtom") - -(def-c-type (proto-callback-info :in-foreign-space) :struct - (handle :int) - (data :int)) - -(def-c-type (protocol :in-foreign-space) :struct - (object * :char) - (ext * :char) - (protocol * :char)) - (defun-c-callable protocol-callback-handler ((something-weird-widget :unsigned-long) (x :unsigned-long) (call-data @@ -49,13 +34,13 @@ #+ignore (print (list something-weird-widget - (protocol-object something-weird-widget) - (protocol-ext something-weird-widget) - (protocol-protocol something-weird-widget) - (proto-callback-info-handle x))) + (xm-protocol-object something-weird-widget) + (xm-protocol-ext something-weird-widget) + (xm-protocol-protocol something-weird-widget) + (xm-proto-callback-info-handle x))) - (callback-handler-1 (proto-callback-info-handle x) - (proto-callback-info-data x) + (callback-handler-1 (xm-proto-callback-info-handle x) + (xm-proto-callback-info-data x) call-data)) (defvar *protocol-callback-handler-address* (register-function 'protocol-callback-handler)) @@ -71,9 +56,9 @@ (if (integerp property) property (xm-intern-atom shell property)) (if (integerp protocol) protocol (xm-intern-atom shell protocol)) *protocol-callback-handler-address* - (let ((x (make-proto-callback-info))) - (setf (proto-callback-info-handle x) shell - (proto-callback-info-data x) + (let ((x (make-xm-proto-callback-info))) + (setf (xm-proto-callback-info-handle x) shell + (xm-proto-callback-info-data x) (caar (push (list (new-callback-id) (cons function args) type) (widget-callback-data shell)))) diff --git a/tk/xm-widgets.lisp b/tk/xm-widgets.lisp index b2476a1646119a8ac68f0956a9f229e3c7428db5..56146cdf73b61ea3e54aa89ec2fc33bf9d60ca1d 100644 --- a/tk/xm-widgets.lisp +++ b/tk/xm-widgets.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-widgets.lisp,v 1.4 92/01/31 14:55:20 cer Exp $ +;; $fiHeader: xm-widgets.lisp,v 1.5 92/02/24 13:04:08 cer Exp $ (in-package :tk) @@ -44,9 +44,6 @@ (remf :name args) (apply #'create-popup-shell name (class-of w) parent args)) -(defforeign 'xm_main_window_set_area :entry-point - "_XmMainWindowSetAreas") - (tk::add-resource-to-class (find-class 'vendor-shell) (make-instance 'resource :name :delete-response diff --git a/tk/xt-defs.lisp b/tk/xt-defs.lisp index 5604c3b0c13b4973fe38d44f687be7ad538d0d36..c9cbeb6f6182d1ecb83f8819aed11063f07a863b 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,v 1.7 92/03/30 17:51:58 cer Exp $ +;; $fiHeader: xt-defs.lisp,v 1.1 92/04/21 16:40:03 cer Exp Locker: cer $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. diff --git a/tk/xt-funs.lisp b/tk/xt-funs.lisp index bf9465287c9c803c47ed04634fd7f115ea27b016..158312311cb7d1f7c53035ec815a699ed149f5d2 100644 --- a/tk/xt-funs.lisp +++ b/tk/xt-funs.lisp @@ -20,66 +20,106 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-funs.lisp,v 1.1 92/03/30 17:58:40 cer Exp Locker: cer $ +;; $fiHeader: xt-funs.lisp,v 1.2 92/04/10 14:26:20 cer Exp Locker: cer $ +;; +;; This file contains compile time only code -- put in clim-debug.fasl. +;; (in-package :xt) -(defforeign 'quark_to_string - :entry-point "_XrmQuarkToString") +(defforeign 'xt_get_resource_list :entry-point "_XtGetResourceList") +(defforeign 'xt_get_constraint_resource_list :entry-point "_XtGetConstraintResourceList") -(defforeign 'get-resource-list-1 :entry-point "_XtGetResourceList") -(defforeign 'get-constraint-resource-list-1 :entry-point "_XtGetConstraintResourceList") +(defforeign 'xt_initialize_widget_class :entry-point "_XtInitializeWidgetClass") -(defforeign 'initialize-widget-class :entry-point "_XtInitializeWidgetClass") +(defforeign 'xt_free + :arguments '(ff:foreign-address) + :call-direct t + :callback nil + :arg-checking nil + :return-type :void + :entry-point "_XtFree") -(defforeign 'xt_free :entry-point "_XtFree") - -(defforeign 'toolkit-initialize +(defforeign 'xt_toolkit_initialize :entry-point "_XtToolkitInitialize") -(defforeign 'create_application_context +(defforeign 'xt_create_application_context :entry-point "_XtCreateApplicationContext") -(defforeign 'app_set_error_handler +(defforeign 'xt_app_set_error_handler :entry-point "_XtAppSetErrorHandler") -(defforeign 'app_set_warning_handler +(defforeign 'xt_app_set_warning_handler :entry-point "_XtAppSetWarningHandler") -(defforeign 'open_display +(defforeign 'xt_open_display :entry-point "_XtOpenDisplay") -(defforeign 'app_create_shell +(defforeign 'xt_app_create_shell :entry-point "_XtAppCreateShell") ;;;; -(defforeign 'create_widget :entry-point "_XtCreateWidget") -(defforeign 'create_managed_widget :entry-point "_XtCreateManagedWidget") -(defforeign 'realize_widget :entry-point "_XtRealizeWidget") -(defforeign 'manage_child :entry-point "_XtManageChild") +(defforeign 'xt_create_widget :entry-point "_XtCreateWidget") +(defforeign 'xt_create_managed_widget + :arguments '(simple-string ff:foreign-address ff:foreign-address + ff:foreign-address fixnum) + :call-direct t + :callback t + :arg-checking nil + :return-type :unsigned-integer + :entry-point "_XtCreateManagedWidget") + +(defforeign 'xt_realize_widget :entry-point "_XtRealizeWidget") +(defforeign 'xt_manage_child :entry-point "_XtManageChild") (defforeign 'xt_is_managed :entry-point "_XtIsManaged") -(defforeign 'unmanage_child :entry-point "_XtUnmanageChild") -(defforeign 'manage_children :entry-point "_XtManageChildren") -(defforeign 'destroy_widget :entry-point "_XtDestroyWidget") -(defforeign 'create_popup_shell :entry-point "_XtCreatePopupShell") -(defforeign '_popup :entry-point "_XtPopup") -(defforeign '_popdown :entry-point "_XtPopdown") +(defforeign 'xt_unmanage_child :entry-point "_XtUnmanageChild") +(defforeign 'xt_manage_children :entry-point "_XtManageChildren") +(defforeign 'xt_destroy_widget :entry-point "_XtDestroyWidget") +(defforeign 'xt_create_popup_shell :entry-point "_XtCreatePopupShell") +(defforeign 'xt_popup :entry-point "_XtPopup") +(defforeign 'xt_popdown :entry-point "_XtPopdown") (defforeign 'xt_window :entry-point "_XtWindow") (defforeign 'xt_parent :entry-point "_XtParent") (defforeign 'xt_query_geometry :entry-point "_XtQueryGeometry") (defforeign 'xt_configure_widget :entry-point "_XtConfigureWidget") -(defforeign 'set_values :entry-point "_XtSetValues") -(defforeign 'get_values :entry-point "_XtGetValues") - -(defforeign 'app_pending :return-type :fixnum :entry-point "_XtAppPending") -(defforeign 'app_process_event :entry-point "_XtAppProcessEvent") -(defforeign 'add_event_handler :entry-point "_XtAddEventHandler") +(defforeign 'xt_set_values + :arguments '(ff:foreign-address ff:foreign-address fixnum) + :call-direct t + :callback t + :arg-checking nil + :return-type :void + :entry-point "_XtSetValues") +(defforeign 'xt_get_values + :arguments '(ff:foreign-address ff:foreign-address fixnum) + :call-direct t + :callback t + :arg-checking nil + :return-type :void + :entry-point "_XtGetValues") + + +(defforeign 'xt_app_pending + :arguments '(ff:foreign-address) + :call-direct t + ;; Maybe callback can be safely set to nil... + :callback t + :arg-checking nil + :return-type :fixnum + :entry-point "_XtAppPending") +(defforeign 'xt_app_process_event + :arguments '(ff:foreign-address fixnum) + :call-direct t + :callback t + :arg-checking nil + :return-type :void + :entry-point "_XtAppProcessEvent") +(defforeign 'xt_add_event_handler :entry-point "_XtAddEventHandler") (defforeign 'xt_build_event_mask :entry-point "_XtBuildEventMask") -(defforeign 'add_callback :entry-point "_XtAddCallback") +(defforeign 'xt_add_callback :entry-point "_XtAddCallback") (defforeign 'xt_has_callbacks :entry-point "_XtHasCallbacks") (ff::defforeign 'xtsetsensitive :entry-point "_XtSetSensitive") diff --git a/tk/xt-init.lisp b/tk/xt-init.lisp index b31e57162d7d4507b58146d719bf5930464f6b8b..183007cdb1484fceeda4db78642790fa01199bd2 100644 --- a/tk/xt-init.lisp +++ b/tk/xt-init.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-init.lisp,v 1.3 92/03/24 19:36:21 cer Exp Locker: cer $ +;; $fiHeader: xt-init.lisp,v 1.4 92/04/03 12:04:09 cer Exp Locker: cer $ (in-package :tk) @@ -29,5 +29,6 @@ (defun xt-initialize () (unless *xt-done* - (toolkit-initialize) + (xt_toolkit_initialize) + (define-toolkit-classes *intrinsic-classes*) (setq *xt-done* t))) diff --git a/utils/processes.lisp b/utils/processes.lisp index 4fd9758676f0d394dca352524915c3b79665c0a0..f76c9ffc6d76e562e5adc2a36105122475d93a51 100644 --- a/utils/processes.lisp +++ b/utils/processes.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: processes.lisp,v 1.2 92/01/31 15:07:26 cer Exp $ +;; $fiHeader: processes.lisp,v 1.3 92/02/24 13:05:49 cer Exp $ (in-package :clim-utils) @@ -37,9 +37,9 @@ ) (defun make-lock (&optional (lock-name "a CLIM lock")) - #-(or Genera Minima) (declare (ignore lock-name)) + #-(or Genera Minima Allegro) (declare (ignore lock-name)) #{ - Allegro (mp::make-process-lock) + Allegro (mp::make-process-lock :name lock-name) lispworks (mp::make-lock) Lucid nil CCL-2 nil diff --git a/xlib/ffi.lisp b/xlib/ffi.lisp index 8afdd297587a5ba5a90308da25501530f2c747a5..0adf11d1472b53a5d51d9d5c43d8f7a12d05fda8 100644 --- a/xlib/ffi.lisp +++ b/xlib/ffi.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ffi.lisp,v 1.9 92/03/30 17:52:16 cer Exp $ +;; $fiHeader: ffi.lisp,v 1.10 92/04/15 11:45:43 cer Exp Locker: cer $ (in-package :x11) @@ -53,37 +53,42 @@ (defun fintern (control &rest args) (intern (apply #'format nil control args))) -(defmacro def-exported-foreign-struct (name &rest slots) - `(progn - (eval-when (eval load compile) - (export '(,name - ,(fintern "~A~A" 'make- name) - ,@(mapcar #'(lambda (x) - (fintern "~A-~A" name (car x))) - slots)))) - ,(flet ((foo-slot (slot) - (destructuring-bind - (name &key type) slot - `(,name ,@(trans-slot-type type))))) - (if (notany #'(lambda (s) (member :overlays (cdr s))) slots) - `(ff::def-c-type (,name :in-foreign-space :no-defuns) - ,@(mapcar #'foo-slot slots)) - (destructuring-bind - ((first-slot-name . first-options) . other-slots) slots - (if (and (null (member :overlays first-options)) - (every #'(lambda (slot) - t - #+ignore - (eq (getf (cdr slot) :overlays) - first-slot-name)) - other-slots)) - `(ff::def-c-type (,name :in-foreign-space :no-defuns) :union - ,@(mapcar #'(lambda (slot) - (setq slot (copy-list slot)) - (remf (cdr slot) :overlays) - (foo-slot slot)) - slots)) - (error ":overlays used in a way we cannot handle"))))))) +(defmacro def-exported-foreign-struct (name-and-options &rest slots) + (let (name (options nil)) + (if (atom name-and-options) + (setq name name-and-options) + (setq name (car name-and-options) + options (cdr name-and-options))) + `(progn + (eval-when (eval load compile) + (export '(,name + ,(fintern "~A~A" 'make- name) + ,@(mapcar #'(lambda (x) + (fintern "~A-~A" name (car x))) + slots)))) + ,(flet ((foo-slot (slot) + (destructuring-bind + (name &key type) slot + `(,name ,@(trans-slot-type type))))) + (if (notany #'(lambda (s) (member :overlays (cdr s))) slots) + `(ff::def-c-type (,name :no-defuns ,@options) + ,@(mapcar #'foo-slot slots)) + (destructuring-bind + ((first-slot-name . first-options) . other-slots) slots + (if (and (null (member :overlays first-options)) + (every #'(lambda (slot) + t + #+ignore + (eq (getf (cdr slot) :overlays) + first-slot-name)) + other-slots)) + `(ff::def-c-type (,name :no-defuns ,@options) :union + ,@(mapcar #'(lambda (slot) + (setq slot (copy-list slot)) + (remf (cdr slot) :overlays) + (foo-slot slot)) + slots)) + (error ":overlays used in a way we cannot handle")))))))) (defun trans-slot-type (type) diff --git a/xlib/x11-keysyms.lisp b/xlib/x11-keysyms.lisp index b6457aa0685f5d449e5e7832403b4bcb96eb1812..ec3a272197807a2f80833ae59d28ffd0213e462d 100644 --- a/xlib/x11-keysyms.lisp +++ b/xlib/x11-keysyms.lisp @@ -18,24 +18,31 @@ ;; Commercial Software developed at private expense as specified in FAR ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. -;; -;;; -;;; Unpublished--all rights reserved under the copyright laws of the United -;;; States. Sun considers its source code as an unpublished, proprietary trade -;;; secret, and it is available only under strict license provisions. This -;;; copyright notice is placed here only to protect Sun in the event the source -;;; is deemed a published work. Disassembly, decompilation, or other means of -;;; reducing the object code to human readable form is prohibited by the -;;; license agreement under which this code is provided to the user or -;;; company in possession of this copy. -;;; -;;; RESTRICTED RIGHTS LEGEND: Use, duplication, or disclosure by the Government -;;; is subject to restrictions as set forth in subparagraph (c) (1)(ii) of the -;;; Rights in Technical Data and Computer Software Clause at DFARS 252.227-7013 -;;; (Oct. 1988) and FAR 52.227-19(c) (June 1987) Sun Microsystems, Inc. 2550 -;;; Garcia Avenue, Mountain View, California 94043. -;; $fiHeader: x11-keysyms.lisp,v 1.4 92/02/16 20:55:26 cer Exp $ +;; (c) Copyright 1989, 1990, 1991 Sun Microsystems, Inc. Sun design +;; patents pending in the U.S. and foreign countries. OPEN LOOK is a +;; registered trademark of USL. Used by written permission of the owners. +;; +;; (c) Copyright Bigelow & Holmes 1986, 1985. Lucida is a registered +;; trademark of Bigelow & Holmes. Permission to use the Lucida +;; trademark is hereby granted only in association with the images +;; and fonts described in this file. +;; +;; SUN MICROSYSTEMS, INC., USL, AND BIGELOW & HOLMES +;; MAKE NO REPRESENTATIONS ABOUT THE SUITABILITY OF +;; THIS SOURCE OR OBJECT CODE FOR ANY PURPOSE. IT IS PROVIDED "AS IS" +;; WITHOUT EXPRESS OR IMPLIED WARRANTY OF ANY KIND. +;; SUN MICROSYSTEMS, INC., USL AND BIGELOW & HOLMES, +;; SEVERALLY AND INDIVIDUALLY, DISCLAIM ALL WARRANTIES +;; WITH REGARD TO THIS CODE, INCLUDING ALL IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +;; PARTICULAR PURPOSE. IN NO EVENT SHALL SUN MICROSYSTEMS, +;; INC., USL OR BIGELOW & HOLMES BE LIABLE FOR ANY +;; SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, +;; OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA +;; OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE +;; OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION +;; WITH THE USE OR PERFORMANCE OF THIS OBJECT CODE. ;;;@(#)x11-keysym.lisp 1.3 11/29/90 diff --git a/xlib/xlib-defs.lisp b/xlib/xlib-defs.lisp index 991c384fc64922a5e08430c6b3adf646f3c12afa..c475517dd41c8dd13baa3d4475f8c777b3163219 100644 --- a/xlib/xlib-defs.lisp +++ b/xlib/xlib-defs.lisp @@ -1,5 +1,5 @@ ;; -*- mode: common-lisp; package: x11 -*- -;; (c) Copyright 1990 Sun Microsystems, Inc. All Rights Reserved. +;;; (c) Copyright 1990 Sun Microsystems, Inc. All Rights Reserved. ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved. @@ -21,6 +21,31 @@ ;; ;;; $fiHeader: xlib-defs.lisp,v 1.1 92/03/06 17:06:59 cer Exp $ +;; (c) Copyright 1989, 1990, 1991 Sun Microsystems, Inc. Sun design +;; patents pending in the U.S. and foreign countries. OPEN LOOK is a +;; registered trademark of USL. Used by written permission of the owners. +;; +;; (c) Copyright Bigelow & Holmes 1986, 1985. Lucida is a registered +;; trademark of Bigelow & Holmes. Permission to use the Lucida +;; trademark is hereby granted only in association with the images +;; and fonts described in this file. +;; +;; SUN MICROSYSTEMS, INC., USL, AND BIGELOW & HOLMES +;; MAKE NO REPRESENTATIONS ABOUT THE SUITABILITY OF +;; THIS SOURCE OR OBJECT CODE FOR ANY PURPOSE. IT IS PROVIDED "AS IS" +;; WITHOUT EXPRESS OR IMPLIED WARRANTY OF ANY KIND. +;; SUN MICROSYSTEMS, INC., USL AND BIGELOW & HOLMES, +;; SEVERALLY AND INDIVIDUALLY, DISCLAIM ALL WARRANTIES +;; WITH REGARD TO THIS CODE, INCLUDING ALL IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +;; PARTICULAR PURPOSE. IN NO EVENT SHALL SUN MICROSYSTEMS, +;; INC., USL OR BIGELOW & HOLMES BE LIABLE FOR ANY +;; SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, +;; OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA +;; OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE +;; OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION +;; WITH THE USE OR PERFORMANCE OF THIS OBJECT CODE. + (in-package :x11) ;;; This is a Lucid Common Lisp Foreign Function Interface for Xlib. It was generated @@ -1278,7 +1303,7 @@ (display :type (:pointer display)) (window :type window)) -(def-exported-foreign-struct xevent +(def-exported-foreign-struct (xevent :no-substruct-accessors) (type :type int) (xany :type xanyevent :overlays type) (xkey :type xkeyevent :overlays xany) diff --git a/xlib/xlib-funs.lisp b/xlib/xlib-funs.lisp index 5d77f694724a6b64814297af7f2ebe40a21b2d39..dc3ea8a530be0280bd1b93bcf11cadb10214dad8 100644 --- a/xlib/xlib-funs.lisp +++ b/xlib/xlib-funs.lisp @@ -1,5 +1,5 @@ ;; -*- mode: common-lisp; package: x11 -*- -;; (c) Copyright 1990 Sun Microsystems, Inc. All Rights Reserved. +;;; (c) Copyright 1990 Sun Microsystems, Inc. All Rights Reserved. ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved. @@ -19,6 +19,32 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; + +;; (c) Copyright 1989, 1990, 1991 Sun Microsystems, Inc. Sun design +;; patents pending in the U.S. and foreign countries. OPEN LOOK is a +;; registered trademark of USL. Used by written permission of the owners. +;; +;; (c) Copyright Bigelow & Holmes 1986, 1985. Lucida is a registered +;; trademark of Bigelow & Holmes. Permission to use the Lucida +;; trademark is hereby granted only in association with the images +;; and fonts described in this file. +;; +;; SUN MICROSYSTEMS, INC., USL, AND BIGELOW & HOLMES +;; MAKE NO REPRESENTATIONS ABOUT THE SUITABILITY OF +;; THIS SOURCE OR OBJECT CODE FOR ANY PURPOSE. IT IS PROVIDED "AS IS" +;; WITHOUT EXPRESS OR IMPLIED WARRANTY OF ANY KIND. +;; SUN MICROSYSTEMS, INC., USL AND BIGELOW & HOLMES, +;; SEVERALLY AND INDIVIDUALLY, DISCLAIM ALL WARRANTIES +;; WITH REGARD TO THIS CODE, INCLUDING ALL IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +;; PARTICULAR PURPOSE. IN NO EVENT SHALL SUN MICROSYSTEMS, +;; INC., USL OR BIGELOW & HOLMES BE LIABLE FOR ANY +;; SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, +;; OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA +;; OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE +;; 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 $ (in-package :x11) @@ -156,8 +182,8 @@ (def-exported-foreign-function (xcheckifevent (:return-type int) (:name "_XCheckIfEvent")) (dpy (:pointer display)) - (predicate (:pointer :pointer)) (event (:pointer xevent)) + (predicate (:pointer :pointer)) (arg (:pointer char))) (def-exported-foreign-function (xcheckmaskevent (:return-type int) (:name "_XCheckMaskEvent")) @@ -694,8 +720,8 @@ (def-exported-foreign-function (xifevent (:return-type int) (:name "_XIfEvent")) (dpy (:pointer display)) - (predicate (:pointer :pointer)) (event (:pointer xevent)) + (predicate (:pointer :pointer)) (arg (:pointer char))) (def-exported-foreign-function (xinitextension (:return-type (:pointer xextcodes)) (:name "_XInitExtension"))