diff --git a/Makefile b/Makefile index 56074e451c21a2f8ee07d4a2863379dac279e589..feb8411534694592499e10698b775b48a5371427 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -# $fiHeader: Makefile,v 1.40 92/07/27 19:30:11 cer Exp Locker: cer $ +# $fiHeader: Makefile,v 1.41 92/08/18 17:26:27 cer Exp Locker: cer $ # # Makefile for CLIM 2.0 # @@ -33,11 +33,14 @@ LOAD_XREF_INFO=nil # Lisp optimization for compiling SPEED = 3 SAFETY = 1 +# This next should be set to 1 for distribution +DEBUG = 2 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 +PREMALLOCS = '-m 401408' # Name of dumped lisp CLIM = ./slim @@ -59,7 +62,8 @@ TMP = /usr/tmp SRC_FILES = */*.lisp *.lisp Makefile misc/make-stub-file \ misc/undefinedsymbols misc/undefinedsymbols.olit \ misc/undefinedsymbols.motif misc/undefinedsymbols.xt \ - xlib/xlibsupport.c misc/MyDrawingA*.[hc] misc/olsupport.c + xlib/xlibsupport.c misc/MyDrawingA*.[hc] misc/olsupport.c \ + misc/clos-preload.cl DEST=/dev/null @@ -73,29 +77,36 @@ XLIB= /x11/R4/sun4-lib/libX11$(DEBUGLIB).a XTLIB=/x11/R4/sun4-lib/libXt$(DEBUGLIB).a XLIBS= $(XTLIB) $(XLIB) -OLCOPYLIB=/usr/tech/cer/stuff/clim-2.0/tk/lib2/ +OLCOPYLIB=/usr/tech/cer/stuff/clim-2.0/tk/lib2 OLXLIBS=$(OLCOPYLIB)/libXt.a $(OLCOPYLIB)/libX11.a LIBXOL=$(OLCOPYLIB)/libXol.a # This has to be kept consistent with xlib.lisp - UNDEFS=misc/undefinedsymbols +# This should be the same as load-xt XT_UNDEFS=misc/undefinedsymbols.xt # This should be the same as load-xm - XM_UNDEFS=misc/undefinedsymbols.motif # This should be the same as load-ol - 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 xlibsupport.o MyDrawingA.o \ - olsupport.o +CLIMOBJS= clim-motif.o clim-olit.o stub-xt.o stub-x.o xlibsupport.o MyDrawingA.o \ + olsupport.o -FCLIMOBJS= `pwd`/stub-motif.o `pwd`/stub-olit.o `pwd`/stub-x.o `pwd`/stub-xt.o `pwd`/xlibsupport.o `pwd`/MyDrawingA.o `pwd`/olsupport.o +# These are linked into the distribution +FCLIMOBJS= `pwd`/clim-motif.o `pwd`/clim-olit.o `pwd`/stub-xt.o `pwd`/stub-x.o \ + `pwd`/xlibsupport.o `pwd`/MyDrawingA.o `pwd`/olsupport.o + +# These are built into xm-dcl and ol-dcl. +COMPOSEROBJS= /scm/4.1/sparc/src/code/excldep.o /scm/4.1/sparc/src/code/socket.o \ + /scm/4.1/sparc/src/code/gc_cursor.o \ + /scm/4.1/sparc/src/code/unixsocket.o \ + /scm/4.1/sparc/src/code/io.o /scm/4.1/sparc/src/code/exclio.o \ + /scm/4.1/sparc/src/code/RunStatus.o MALLOCOBJS = # Uncomment to enable malloc debugging. @@ -111,11 +122,10 @@ MALLOCOBJS = # "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 \ - tk/xt-defs.fasl tk/xm-defs.fasl - -# This should be there also -# tk/ol-defs.fasl + xlib/x11-keysyms.fasl xlib/last.fasl \ + tk/xt-defs.fasl tk/xm-defs.fasl tk/xt-funs.fasl tk/xm-funs.fasl +# These should be there also +# tk/ol-defs.fasl tk/ol-funs.fasl # @@ -219,12 +229,13 @@ CLIM-STANDALONE-OBJS = clim/gestures.fasl \ clim/item-list-manager.fasl \ clim/stream-trampolines.fasl -XLIB-CLIM-OBJS = xlib/pkg.fasl +XLIB-CLIM-OBJS = xlib/pkg.fasl xlib/load-xlib.fasl -# Is this the correct place to put this load-xm?? -XT-TK-OBJS = xlib/load-xlib.fasl \ - tk/pkg.fasl \ +LOAD-XM-OBJS= tk/load-xm.fasl +LOAD-OL-OBJS= tk/load-ol.fasl + +XT-TK-OBJS = tk/pkg.fasl \ tk/foreign-obj.fasl \ tk/macros.fasl \ tk/xlib.fasl \ @@ -242,9 +253,6 @@ XT-TK-OBJS = xlib/load-xlib.fasl \ tk/xt-init.fasl XM-TK-OBJS = tk/xm-classes.fasl \ - tk/load-xm.fasl \ - tk/xt-funs.fasl \ - tk/xm-funs.fasl \ tk/xm-callbacks.fasl \ tk/xm-init.fasl \ tk/xm-widgets.fasl \ @@ -254,9 +262,6 @@ XM-TK-OBJS = tk/xm-classes.fasl \ tk/make-widget.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-widgets.fasl \ tk/ol-callbacks.fasl \ @@ -323,6 +328,7 @@ ALL_SRC = utils/excl-verification.lisp \ silica/medium.lisp \ silica/framem.lisp \ silica/graphics.lisp \ + silica/pixmaps.lisp \ silica/std-sheet.lisp \ silica/layout.lisp \ silica/db-layout.lisp \ @@ -357,6 +363,7 @@ ALL_SRC = utils/excl-verification.lisp \ clim/incremental-redisplay.lisp \ clim/coordinate-sorted-set.lisp \ clim/window-stream.lisp \ + clim/pixmap-streams.lisp \ clim/ptypes1.lisp \ clim/completer.lisp \ clim/presentations.lisp \ @@ -379,11 +386,11 @@ ALL_SRC = utils/excl-verification.lisp \ clim/command-processor.lisp \ clim/basic-translators.lisp \ clim/frames.lisp \ + clim/default-frame.lisp \ clim/noting-progress.lisp \ clim/menus.lisp \ clim/accept-values.lisp \ clim/drag-and-drop.lisp \ - clim/pixmap-streams.lisp \ clim/item-list-manager.lisp \ clim/stream-trampolines.lisp \ xlib/pkg.lisp \ @@ -393,6 +400,8 @@ ALL_SRC = utils/excl-verification.lisp \ xlib/xlib-funs.lisp \ xlib/x11-keysyms.lisp \ xlib/last.lisp \ + tk/load-xm.lisp \ + tk/load-ol.lisp \ tk/pkg.lisp \ tk/macros.lisp \ tk/xt-defs.lisp \ @@ -410,7 +419,6 @@ ALL_SRC = utils/excl-verification.lisp \ tk/callbacks.lisp \ tk/xt-classes.lisp \ tk/xt-init.lisp \ - tk/load-xm.lisp \ tk/xm-defs.lisp \ tk/xm-classes.lisp \ tk/xm-callbacks.lisp \ @@ -437,7 +445,6 @@ ALL_SRC = utils/excl-verification.lisp \ tk-silica/xt-cursor.lisp \ tk-silica/xt-pixmaps.lisp \ tk/ol-defs.lisp \ - tk/load-ol.lisp \ tk/ol-funs.lisp \ tk/ol-classes.lisp \ tk/ol-init.lisp \ @@ -450,9 +457,8 @@ ALL_SRC = utils/excl-verification.lisp \ GENERIC-OBJS= $(CLIM-UTILS-OBJS) $(CLIM-SILICA-OBJS) $(CLIM-STANDALONE-OBJS) -XT-OBJS= $(XLIB-CLIM-OBJS) $(XT-TK-OBJS) -MOTIF-OBJS = $(XM-TK-OBJS) $(MOTIF-CLIM-OBJS) -OPENLOOK-OBJS = $(OL-CLIM-OBJS) $(OPENLOOK-CLIM-OBJS) +MOTIF-OBJS = $(LOAD-XM-OBJS) $(XT-TK-OBJS) $(XM-TK-OBJS) $(MOTIF-CLIM-OBJS) +OPENLOOK-OBJS = $(LOAD-OL-OBJS) $(XT-TK-OBJS) $(OL-CLIM-OBJS) $(OPENLOOK-CLIM-OBJS) default: all-xm @@ -471,7 +477,7 @@ compile-xm: $(CLIMOBJS) FORCE (setf excl:*record-source-file-info* $(RECORD_SOURCE_FILE_INFO)) \ (setf excl:*record-xref-info* $(RECORD_XREF_INFO)) \ (setf excl:*load-xref-info* $(LOAD_XREF_INFO)) \ - (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ + (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)) (debug $(DEBUG)))) \ (load \"misc/compile-xm.lisp\")" | $(CL) $(CLOPTS) -batch echo CLIM-XM compiled!!!! @@ -483,7 +489,7 @@ compile-ol: $(CLIMOBJS) FORCE (setf excl:*load-xref-info* $(LOAD_XREF_INFO)) \ (setq *ignore-package-name-case* t) \ (set-case-mode :case-insensitive-lower) \ - (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ + (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)) (debug $(DEBUG)))) \ (load \"misc/compile-ol.lisp\")" | $(CL) $(CLOPTS) -batch echo CLIM-OL compiled!!!! @@ -494,20 +500,20 @@ 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` +climg.fasl : $(GENERIC-OBJS) $(XLIB-CLIM-OBJS) + $(CAT) $(GENERIC-OBJS) $(XLIB-CLIM-OBJS) > $(TMP)/clim.fasl_`whoami` $(MV) $(TMP)/clim.fasl_`whoami` climg.fasl ls -lt climg.fasl >> Clim-sizes.n ls -lt climg.fasl -climxm.fasl : $(MOTIF-OBJS) - $(CAT) $(MOTIF-OBJS) > $(TMP)/clim.fasl_`whoami` +climxm.fasl : $(MOTIF-OBJS) $(XLIB-CLIM-OBJS) + $(CAT) $(MOTIF-OBJS) > $(TMP)/clim.fasl_`whoami` $(MV) $(TMP)/clim.fasl_`whoami` climxm.fasl ls -lt climxm.fasl >> Clim-sizes.n ls -lt climxm.fasl climol.fasl : $(OPENLOOK-OBJS) - $(CAT) $(OPENLOOK-OBJS) > $(TMP)/clim.fasl_`whoami` + $(CAT) $(OPENLOOK-OBJS) > $(TMP)/clim.fasl_`whoami` $(MV) $(TMP)/clim.fasl_`whoami` climol.fasl ls -lt climol.fasl >> Clim-sizes.n ls -lt climol.fasl @@ -536,22 +542,20 @@ clim-xm: FORCE (load \"misc/dev-load-xm.lisp\") \ (load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch $(MV) $(TMP)/clim.temp_`whoami` $(CLIM) - ls -lt $(CLIM) >> Clim-sizes.n + ls -lLt $(CLIM) >> Clim-sizes.n size $(CLIM) >> Clim-sizes.n - ls -lt $(CLIM) + ls -lLt $(CLIM) echo CLIM-XM built!!!! clim-ol: FORCE - -$(RM) $(CLIM) +# -$(RM) $(CLIM) $(ECHO) " \ - (setq *ignore-package-name-case* t) \ - (set-case-mode :case-insensitive-lower) \ (load \"misc/dev-load-ol.lisp\") \ (load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch $(MV) $(TMP)/clim.temp_`whoami` $(CLIM) - ls -lt $(CLIM) >> Clim-sizes.n + ls -lLt $(CLIM) >> Clim-sizes.n size $(CLIM) >> Clim-sizes.n - ls -lt $(CLIM) + ls -lLt $(CLIM) echo CLIM-OL built!!!! clim-small: FORCE @@ -586,10 +590,13 @@ cheapclean: tags: $(TAGS) $(ALL_SRC) +wc: + wc $(ALL_SRC) + swm-tape: tar cf $(DEVICE) `find $(PUBDIRS) '(' -name "*.cl" -o -name "*.lisp" ')' -print` -dist: +dist: FORCE tar -cf - $(SRC_FILES) | compress > Dist/src.tar.Z rcscheck: @@ -607,14 +614,15 @@ makeclimolfasls : compile-ol cat-ol install_clim : cp $(CLIMOBJS) $(CLIMFASLS) $(DEST) -# Link in the libraries with standard names +# Link in the libraries & distribution object files with standard names -link-motif-libraries : - ln -s $(MOTIFLIB) $(DEST)/libXm.a +link-objects : ln -s $(XTLIB) $(DEST)/libXt.a ln -s $(XLIB) $(DEST)/libX11.a ln -s $(FCLIMOBJS) $(DEST) - ln -s $(LIBXOL) $(DEST) + +# Backwards compatibility... +link-motif-libraries: link-objects echo_src_files: @ls $(SRC_FILES) | cat @@ -624,18 +632,23 @@ makeclimobjs : $(CLIMOBJS) ################## Lower level Makefile stuff -ol-dcl : stub-x.o stub-xt.o stub-olit.o xlibsupport.o olsupport.o $(MALLOCOBJS) +ol-dcl : stub-x.o stub-xt.o clim-olit.o xlibsupport.o olsupport.o $(MALLOCOBJS) cd $(CL_SRC) ; /bin/rm -f ucl ;\ - make initial_oldspace=$(OLDSPACE) oldspace=$(OLDSPACE) newspace=$(NEWSPACE) premallocs='-m 401408' ucl_xtras='$(PWD)/stub-x.o $(PWD)/stub-xt.o $(PWD)/stub-olit.o $(PWD)/xlibsupport.o $(PWD)/olsupport.o $(MALLOCOBJS) $(LIBXOL) $(OLXLIBS)' dcl + make initial_oldspace=$(OLDSPACE) oldspace=$(OLDSPACE) newspace=$(NEWSPACE) premallocs=$(PREMALLOCS) ucl_xtras='$(PWD)/stub-x.o $(PWD)/stub-xt.o $(PWD)/clim-olit.o $(PWD)/xlibsupport.o $(PWD)/olsupport.o $(COMPOSEROBJS) $(MALLOCOBJS) $(OLXLIBS)' dcl -xm-dcl : stub-x.o stub-xt.o stub-motif.o xlibsupport.o MyDrawingA.o $(MALLOCOBJS) +xm-dcl : stub-x.o stub-xt.o clim-motif.o xlibsupport.o MyDrawingA.o $(MALLOCOBJS) cd $(CL_SRC) ; /bin/rm -f ucl ;\ - make initial_oldspace=$(OLDSPACE) oldspace=$(OLDSPACE) newspace=$(NEWSPACE) premallocs='-m 401408' ucl_xtras='$(PWD)/stub-x.o $(PWD)/stub-xt.o $(PWD)/stub-motif.o $(PWD)/xlibsupport.o $(PWD)/MyDrawingA.o $(MALLOCOBJS) $(MOTIFLIB) $(XTLIB) $(XLIB)' dcl + make initial_oldspace=$(OLDSPACE) oldspace=$(OLDSPACE) newspace=$(NEWSPACE) premallocs=$(PREMALLOCS) ucl_xtras='$(PWD)/stub-x.o $(PWD)/stub-xt.o $(PWD)/clim-motif.o $(PWD)/xlibsupport.o $(PWD)/MyDrawingA.o $(COMPOSEROBJS) $(MALLOCOBJS) $(XTLIB) $(XLIB)' dcl dcl : cd $(CL_SRC) ; /bin/rm -f ucl ;\ make dcl +clim-motif.o : stub-motif.o + ld -r -o clim-motif.o stub-motif.o $(MOTIFLIB) + +clim-olit.o : stub-olit.o + ld -r -o clim-olit.o stub-olit.o $(LIBXOL) stub-motif.c : $(XT_UNDEFS) $(XM_UNDEFS) misc/make-stub-file misc/make-stub-file "void ___lisp_load_motif_stub ()" $(XT_UNDEFS) $(XM_UNDEFS) > stub-motif.c @@ -658,7 +671,7 @@ MyDrawingA.o: misc/MyDrawingA.c olsupport.o: misc/olsupport.c $(CC) -c $(CFLAGS) -o olsupport.o misc/olsupport.c -FRC : +FORCE : xm-composer : xm-dcl cd /usr/composer2 ; make CL=$(CL) rebuild-c2 diff --git a/clim/frames.lisp b/clim/frames.lisp index 3b3a4cfc83cb64df82d38df26b4f5902024397c1..41b52d17a1440162bde4e0848861ee80907c2499 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.35 92/07/27 19:29:46 cer Exp $ +;; $fiHeader: frames.lisp,v 1.36 92/08/18 17:24:53 cer Exp Locker: cer $ (in-package :clim-internals) @@ -564,18 +564,18 @@ :geometry :left :top :right :bottom :width :height)) (macrolet ((check-conflict (edge1 edge2 size) `(cond - ((and ,edge1 ,size) - (if ,edge2 - (error "Cannot specify ~S, ~S, and ~S together" ,edge1 ,size ,edge2) - (setq ,edge2 (+ ,edge1 ,size)))) - ((and ,edge2 ,size) - (if ,edge1 - (error "Cannot specify ~S, ~S, and ~S together" ,edge2 ,size ,edge1) - (setq ,edge1 (+ ,edge2 ,size)))) - ((and ,edge2 ,edge1) - (if ,size - (error "Cannot specify ~S, ~S, and ~S together" ,edge2 ,edge1 ,size) - (setq ,size (- ,edge2 ,edge1))))))) + ((and ,edge1 ,size) + (if ,edge2 + (error "Cannot specify ~S, ~S, and ~S together" ,edge1 ,size ,edge2) + (setq ,edge2 (+ ,edge1 ,size)))) + ((and ,edge2 ,size) + (if ,edge1 + (error "Cannot specify ~S, ~S, and ~S together" ,edge2 ,size ,edge1) + (setq ,edge1 (+ ,edge2 ,size)))) + ((and ,edge2 ,edge1) + (if ,size + (error "Cannot specify ~S, ~S, and ~S together" ,edge2 ,edge1 ,size) + (setq ,size (- ,edge2 ,edge1))))))) (check-conflict left right width) (check-conflict top bottom height)) (setf (getf options :geometry) @@ -583,15 +583,19 @@ (and top `(:top ,top)) (and width `(:width ,width)) (and height `(:height ,height))))) + (let ((geometry (getf options :geometry))) - (when (and (eq user-specified-position-p :unspecified) - (getf geometry :left) - (getf geometry :top)) - (setf user-specified-position-p t)) - (when (and (eq user-specified-size-p :unspecified) - (getf geometry :width) - (getf geometry :height)) - (setf user-specified-size-p t))) + (when (eq user-specified-position-p :unspecified) + (if (or (and (getf :left) + (getf geometry :top)) + (and left top)) + (setf user-specified-position-p t))) + (when (eq user-specified-size-p :unspecified) + (if (or (and (getf geometry :width) + (getf geometry :height)) + (and width height)) + (setf user-specified-size-p t)))) + (with-keywords-removed (options options '(:frame-class :pretty-name :enable :save-under :left :top :right :bottom :width :height diff --git a/clx/clx-mirror.lisp b/clx/clx-mirror.lisp index b6ea9a9c0a34211cd02abbab70755b5780a1e90a..64233d21904455bce551acd7873a0d5a54a5313a 100644 --- a/clx/clx-mirror.lisp +++ b/clx/clx-mirror.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: clx-mirror.lisp,v 1.9 92/07/27 11:01:59 cer Exp $ +;; $fiHeader: clx-mirror.lisp,v 1.10 92/08/18 17:24:24 cer Exp Locker: cer $ (in-package :clx-clim) @@ -206,7 +206,7 @@ :discard-p t :timeout nil) ;; Device Events - ((:motion-notify :enter-notify :leave-notify) + (:motion-notify (event-window) (multiple-value-bind (x y same-screen-p child state root-x root-y) (xlib:query-pointer event-window) @@ -220,14 +220,34 @@ (distribute-event port ;(EQ PORT (PORT-SHEET)) ==> T (allocate-event 'pointer-motion-event - :x root-x - :y root-y :native-x x :native-y y :modifier-state modifier-state :pointer pointer :sheet sheet)))) t)) + ((:enter-notify :leave-notify) + (event-window event-key state kind) + (let ((sheet (mirror->sheet port event-window)) + (modifier-state (state-mask->modifier-state state display)) + (pointer (port-pointer port))) + ;;--- This should probably set the native position of the pointer + (setf (port-modifier-state port) modifier-state) + (when sheet + (distribute-event + port ;(EQ PORT (PORT-SHEET)) ==> T + (allocate-event (case event-key + (:enter-notify 'pointer-enter-event) + (:leave-notify 'pointer-exit-event)) + :x root-x + :y root-y + :native-x x + :native-y y + :kind kind + :modifier-state modifier-state + :pointer pointer + :sheet sheet)))) + t) ((:button-press :button-release) (event-key event-window code) (multiple-value-bind (x y same-screen-p child state root-x root-y) diff --git a/instclimol.lisp b/instclimol.lisp index 74ca043decda069d4d70593273793da1e7511e54..8c3db76112ef7763c1408aa610960c18a5d4218e 100644 --- a/instclimol.lisp +++ b/instclimol.lisp @@ -20,7 +20,7 @@ ;; applicable. ;; -;; $fiHeader: instclimol.lisp,v 1.2 92/05/22 19:29:17 cer Exp $ +;; $fiHeader: instclimol.lisp,v 1.3 92/06/02 13:31:19 cer Exp $ ;; ;; Load CLIM @@ -29,9 +29,8 @@ (in-package :system) -(defvar sys::*libx11-pathname* "/x11/R4/sun4-lib/libX_d.a") -(defvar sys::*libxt-pathname* "/x11/R4/sun4-lib/libXt_d.a") -(defvar sys::*libxol-pathname* "/vapor/usr/tech/cer/stuff/clim-2.0/tk/lib2/libXol.a") +(defvar sys::*libx11-pathname* "/x11/R4/sun4-lib/libX11.a") +(defvar sys::*libxt-pathname* "/x11/R4/sun4-lib/libXt.a") (load-application (progn (require :climol) diff --git a/instclimxm.lisp b/instclimxm.lisp index 419258ad571e8d2835afd86e89ad9d92195dc9b8..a651c8a10e7a96440adb72044487b2b9228dfc25 100644 --- a/instclimxm.lisp +++ b/instclimxm.lisp @@ -20,7 +20,7 @@ ;; applicable. ;; -;; $fiHeader: instclimxm.lisp,v 1.2 92/05/22 19:29:18 cer Exp $ +;; $fiHeader: instclimxm.lisp,v 1.3 92/06/02 13:31:20 cer Exp $ ;; ;; Load CLIM @@ -28,9 +28,8 @@ (in-package :system) -(defvar sys::*libx11-pathname* "/x11/R4/sun4-lib/libX_d.a") -(defvar sys::*libxt-pathname* "/x11/R4/sun4-lib/libXt_d.a") -(defvar sys::*libxm-pathname* "/x11/motif-1.1/lib/Xm/libXm.a") +(defvar sys::*libx11-pathname* "/x11/R4/sun4-lib/libX11.a") +(defvar sys::*libxt-pathname* "/x11/R4/sun4-lib/libXt.a") (load-application (progn (require :climxm) diff --git a/silica/classes.lisp b/silica/classes.lisp index e1462c268ecd0d1a40ecda125272be4500c18ca8..95de869659784815fef37a23d34f39e7ec81a0d7 100644 --- a/silica/classes.lisp +++ b/silica/classes.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: classes.lisp,v 1.13 92/07/27 11:01:28 cer Exp $ +;; $fiHeader: classes.lisp,v 1.14 92/08/18 17:23:23 cer Exp Locker: cer $ (in-package :silica) @@ -141,6 +141,11 @@ (pointer :reader pointer-event-pointer :initarg :pointer :initform nil))) +#+CLIM-1-compatibility +(define-compatibility-function (pointer-event-shift-mask event-modifier-state) + (pointer-event) + (event-modifier-state pointer-event)) + (define-event-class pointer-button-event (pointer-event) ((button :reader pointer-event-button :initarg :button :initform nil))) @@ -152,10 +157,14 @@ (define-event-class pointer-click-hold-event (pointer-click-event) ()) (define-event-class pointer-double-click-event (pointer-click-event) ()) -(define-event-class pointer-motion-or-boundary-event (pointer-event) ()) -(define-event-class pointer-motion-event (pointer-motion-or-boundary-event) ()) -(define-event-class pointer-exit-event (pointer-motion-or-boundary-event) ()) -(define-event-class pointer-enter-event (pointer-motion-or-boundary-event) ()) +(define-event-class pointer-motion-event (pointer-event) ()) + +(define-event-class pointer-boundary-event (pointer-event) + ((kind :reader pointer-boundary-event-kind :initarg :kind + :type (member :ancestor :virtual :inferior :nonlinear :nonlinear-virtual + nil)))) +(define-event-class pointer-exit-event (pointer-boundary-event) ()) +(define-event-class pointer-enter-event (pointer-boundary-event) ()) (define-event-class window-event (event) diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp index 6bc25ddb1c6787d66b7698f3896581a02d16b6d3..671358517ad3bf3c75cac905d7d639ca553d25ce 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.20 92/07/27 11:03:10 cer Exp $ +;; $fiHeader: sysdcl.lisp,v 1.21 92/08/18 17:25:53 cer Exp Locker: cer $ (in-package #-ANSI-90 :user #+ANSI-90 :cl-user) @@ -344,6 +344,7 @@ ("pkg") ("macros") ("xt-defs") ; Used to be 'xtk'. + ("xt-funs") ("foreign-obj") ;; Xlib stuff ("xlib") @@ -362,21 +363,43 @@ ("xt-classes") ("xt-init")) +#+Allegro +(clim-defsys:defsystem xm-load + (:default-pathname #+Genera "SYS:CLIM;REL-2;TK;" + #-Genera (frob-pathname "tk") + :default-binary-pathname #+Genera "SYS:CLIM;REL-2;TK;" + #-Genera (frob-pathname "tk") + :needed-systems (xlib) + :load-before-compile (xlib)) + ;; Motif specific foriegn loading. Must be done early so defforeigns can + ;; be opencoded. + ("load-xm")) + +#+Allegro +(clim-defsys:defsystem ol-load + (:default-pathname #+Genera "SYS:CLIM;REL-2;TK;" + #-Genera (frob-pathname "tk") + :default-binary-pathname #+Genera "SYS:CLIM;REL-2;TK;" + #-Genera (frob-pathname "tk") + :needed-systems (xlib) + :load-before-compile (xlib)) + ;; Motif specific foriegn loading. Must be done early so defforeigns can + ;; be opencoded. + ("load-ol")) + #+Allegro (clim-defsys:defsystem xm-tk (:default-pathname #+Genera "SYS:CLIM;REL-2;TK;" #-Genera (frob-pathname "tk") :default-binary-pathname #+Genera "SYS:CLIM;REL-2;TK;" #-Genera (frob-pathname "tk") - :needed-systems (xt-tk) - :load-before-compile (xt-tk)) + :needed-systems (xm-load xt-tk) + :load-before-compile (xm-load xt-tk)) ;; Motif specific stuff - ("load-xm") ("xm-defs") + ("xm-funs") ("xm-classes") ("xm-callbacks") - ("xt-funs") ;;--- This is really in tk but because of the loading - ("xm-funs") ("xm-classes") ("xm-init") ("xm-widgets") @@ -391,12 +414,10 @@ #-Genera (frob-pathname "tk") :default-binary-pathname #+Genera "SYS:CLIM;REL-2;TK;" #-Genera (frob-pathname "tk") - :needed-systems (xt-tk) - :load-before-compile (xt-tk)) + :needed-systems (ol-load xt-tk) + :load-before-compile (ol-load xt-tk)) ;; OpenLook specific stuff ("ol-defs") - ("load-ol") - ("xt-funs") ;;--- This is really in tk but because of the loading ("ol-funs") ("ol-classes") ("ol-init") diff --git a/tk-silica/ol-silica.lisp b/tk-silica/ol-silica.lisp index 73579141567c4ebec0c0307be0df3d1e9cff9819..a9a073256890a309e6bbfc11c94be251d1edc72a 100644 --- a/tk-silica/ol-silica.lisp +++ b/tk-silica/ol-silica.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-silica.lisp,v 1.11 92/07/01 15:48:01 cer Exp $ +;; $fiHeader: ol-silica.lisp,v 1.12 92/07/20 16:01:50 cer Exp $ (in-package :xm-silica) @@ -50,14 +50,17 @@ (let ((mirror (sheet-mirror stream))) (when mirror (let ((window (tk::widget-window mirror))) - (when (eq (tk::window-map-state window) :viewable) - ;;--- There could very well be a race condition involving - ;;--- a couple of processes. Another process could have made - ;;--- this window go away at this point - (tk::ol_set_input_focus - mirror - 2 ; RevertToParent - 0))))))) + (with-port-event-lock (port) + (excl:without-interrupts + (tk:with-server-grabbed ((port-display port)) + (when (eq (tk::window-map-state window) :viewable) + ;;--- There could very well be a race condition involving + ;;--- a couple of processes. Another process could have made + ;;--- this window go away at this point + (tk::ol_set_input_focus + mirror + 2 ; RevertToParent + 0)))))))))) (defmethod change-widget-geometry ((parent tk::draw-area) child &rest args diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index 5135d33aa902fc19e1f5374701592f35771946c0..cf8c5412b2fe64da727d07098d89b10326298fc4 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-gadgets.lisp,v 1.40 92/07/27 11:03:46 cer Exp $ +;; $fiHeader: xm-gadgets.lisp,v 1.41 92/08/18 17:26:35 cer Exp Locker: cer $ (in-package :xm-silica) @@ -728,6 +728,15 @@ ;;-- the pane should resize its child ) +(defmethod add-sheet-callbacks + ((port motif-port) (sheet t) (widget tk::xm-frame)) + (tk::add-event-handler widget + '(:enter-window + :leave-window) + 0 + 'sheet-mirror-event-handler + sheet)) + ;;; Scrolling Window (defclass basic-motif-scrolling-window (motif-geometry-manager diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp index e16e79d4a6db998c6daa30b7340baa4668492785..b54ed296d37401a38a257cf2d322c78604d42856 100644 --- a/tk-silica/xm-silica.lisp +++ b/tk-silica/xm-silica.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-silica.lisp,v 1.23 92/07/08 16:31:56 cer Exp $ +;; $fiHeader: xm-silica.lisp,v 1.24 92/08/18 17:26:37 cer Exp Locker: cer $ (in-package :xm-silica) @@ -96,11 +96,11 @@ (desired :unsigned-long)) (my-drawing-area-query-geometry widget intended desired)) -(ff::defforeign 'initializemydrawingareaquerygeometry - :entry-point "_InitializeMyDrawingAreaQueryGeometry") +(defun setup-mda () + (tk::initializemydrawingareaquerygeometry + (ff:register-function 'my-drawing-area-query-geometry-stub))) -(initializemydrawingareaquerygeometry - (ff:register-function 'my-drawing-area-query-geometry-stub)) +(setup-mda) (defun my-drawing-area-query-geometry (widget intended desired) (let* ((sheet (find-sheet-from-widget-address widget)) diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index 69d2322c4277a8a410190debdea116dc354f69cd..7261595c06d050d89f75252f4d0d2070b1f244b6 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -20,13 +20,34 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-graphics.lisp,v 1.32 92/07/27 19:30:25 cer Exp $ +;; $fiHeader: xt-graphics.lisp,v 1.33 92/08/18 17:26:40 cer Exp Locker: cer $ (in-package :tk-silica) (defclass fast-gcontext (tk::gcontext) - ((last-medium-clip-mask :initform nil) - (last-line-style :initform nil))) + ((last-medium-clip-mask :initform nil :fixed-index 1) + (last-line-style :initform nil :fixed-index 2))) + +(defmacro fast-gcontext-last-line-style (gcontext) + `(locally (declare (optimize (speed 3) (safety 0))) + (excl::slot-value-using-class-name 'fast-gcontext ,gcontext + 'last-line-style))) +(defsetf fast-gcontext-last-line-style (gcontext) (value) + `(locally (declare (optimize (speed 3) (safety 0))) + (setf (excl::slot-value-using-class-name 'fast-gcontext ,gcontext + 'last-line-style) + ,value))) + +(defmacro fast-gcontext-last-medium-clip-mask (gcontext) + `(locally (declare (optimize (speed 3) (safety 0))) + (excl::slot-value-using-class-name 'fast-gcontext ,gcontext + 'last-medium-clip-mask))) +(defsetf fast-gcontext-last-medium-clip-mask (gcontext) (value) + `(locally (declare (optimize (speed 3) (safety 0))) + (setf (excl::slot-value-using-class-name 'fast-gcontext ,gcontext + 'last-medium-clip-mask) + ,value))) + (defclass xt-medium (basic-medium) ((foreground-gcontext :reader medium-foreground-gcontext :initform nil) @@ -270,7 +291,7 @@ (defmethod decode-ink ((ink (eql +flipping-ink+)) stream) (slot-value stream 'flipping-gcontext)) -(defmethod decode-ink ((ink color) (medium xt-medium)) +(defmethod decode-ink ((ink color) medium) (with-slots (ink-table sheet tile-gcontext white-pixel black-pixel drawable color-p) medium @@ -378,50 +399,49 @@ and on color servers, unless using white or black") (defvar *default-dashes* '(4 4)) (defun adjust-ink (gc medium line-style x-origin y-origin) - (with-slots (last-medium-clip-mask last-line-style) gc - (unless (eq last-line-style line-style) - (let* ((dashes (line-style-dashes line-style)) - (gc-line-style (if dashes :dash :solid))) + (unless (eq (fast-gcontext-last-line-style gc) line-style) + (let* ((dashes (line-style-dashes line-style)) + (gc-line-style (if dashes :dash :solid))) - (tk::set-line-attributes - gc - (let ((thickness (line-style-thickness line-style))) - (ecase (line-style-unit line-style) - (:normal) - (:point - (setq thickness (* (graft-pixels-per-point (graft medium)) - thickness)))) - (when (< thickness 2) - (setq thickness 0)) - (setq thickness (the fixnum (round thickness))) - thickness) - gc-line-style - (ecase (line-style-cap-shape line-style) - (:butt :butt) - (:square :projecting) - (:round :round) - (:no-end-point :not-last)) - (ecase (line-style-joint-shape line-style) - ((:miter :none) :miter) - (:bevel :bevel) - (:round :round))) + (tk::set-line-attributes + gc + (let ((thickness (line-style-thickness line-style))) + (ecase (line-style-unit line-style) + (:normal) + (:point + (setq thickness (* (graft-pixels-per-point (graft medium)) + thickness)))) + (when (< thickness 2) + (setq thickness 0)) + (setq thickness (the fixnum (round thickness))) + thickness) + gc-line-style + (ecase (line-style-cap-shape line-style) + (:butt :butt) + (:square :projecting) + (:round :round) + (:no-end-point :not-last)) + (ecase (line-style-joint-shape line-style) + ((:miter :none) :miter) + (:bevel :bevel) + (:round :round))) - (when (eq gc-line-style :dash) - (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)))) - (setf last-line-style line-style)) - - (let ((mcm (medium-clip-mask medium))) - (unless (eq last-medium-clip-mask mcm) - (setf (tk::gcontext-clip-mask gc) (medium-clip-mask medium)) - (setf last-medium-clip-mask mcm))) + (when (eq gc-line-style :dash) + (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)))) + (setf (fast-gcontext-last-line-style gc) line-style)) + + (let ((mcm (medium-clip-mask medium))) + (unless (eq (fast-gcontext-last-medium-clip-mask gc) mcm) + (setf (tk::gcontext-clip-mask gc) (medium-clip-mask medium)) + (setf (fast-gcontext-last-medium-clip-mask gc) mcm))) - (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)) + (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)) @@ -759,7 +779,7 @@ and on color servers, unless using white or black") filled))) (t (port-draw-transformed-rectangle* - port sheet medium x1 y1 x2 y2 filled))))))) + (port sheet) sheet medium x1 y1 x2 y2 filled))))))) (defmethod medium-draw-polygon* ((medium xt-medium) position-seq closed filled) (let ((drawable (medium-drawable medium))) @@ -1027,7 +1047,7 @@ and on color servers, unless using white or black") (declare (ignore oy) (ignore ox)) (setf (tk::gcontext-clip-mask gcontext) pixmap) - (setf (slot-value gcontext 'last-medium-clip-mask) nil) + (setf (fast-gcontext-last-medium-clip-mask gcontext) nil) (unless start (setq start 0)) (unless end (setq end (length string))) (dotimes (i (- end start)) @@ -1204,8 +1224,8 @@ and on color servers, unless using white or black") (tk::font-width (text-style-mapping (port medium) text-style))) (defmethod text-style-height ((text-style standard-text-style) (medium xt-medium)) - (+ (text-style-ascent text-style medium) - (text-style-descent text-style medium))) + ;; Optimization + (tk::font-height (text-style-mapping (port medium) text-style))) (defmethod text-style-ascent ((text-style standard-text-style) (medium xt-medium)) (tk::font-ascent (text-style-mapping (port medium) text-style))) @@ -1221,5 +1241,6 @@ and on color servers, unless using white or black") (x11:xflush (port-display (port medium)))) (defmethod medium-finish-output ((medium xt-medium)) - (x11:xsync (port-display (port medium)))) ;--- is this right? + (x11:xsync (port-display (port medium)) 0)) + diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index 15641c4ae591c444fbccd23ff2076e3e8fb7ca78..fdba30a16ccebac97905829235ff1cbed6956961 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.39 92/07/27 19:30:28 cer Exp $ +;; $fiHeader: xt-silica.lisp,v 1.40 92/08/18 17:26:44 cer Exp Locker: cer $ (in-package :xm-silica) @@ -351,129 +351,141 @@ (declare (ignore sheet))) (defmethod sheet-mirror-event-handler (widget event sheet) - (multiple-value-bind (same-p root child root-x root-y native-x native-y mask) - (tk::query-pointer (tk::widget-window widget)) - (declare (ignore same-p root child root-x root-y)) - (let ((port (port sheet)) - (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 :selection-clear :selection-request - :selection-notify :client-message :mapping-notify) - nil) - (:configure-notify - (sheet-mirror-resized-callback - widget nil event sheet) - nil) - (:no-expose nil) - (:graphics-expose - ;; Tricky! - (setf (port-safe-backing-store (port sheet)) nil)) - ;; This gets called only for an XmBulletinBoard widget. - (:expose - (sheet-mirror-exposed-callback - widget - nil ; window - event - sheet) - nil) - (:key-press - (multiple-value-bind (character keysym) - (lookup-character-and-keysym sheet widget event) - (allocate-event 'key-press-event - :key-name keysym - :character character - :sheet sheet - :modifier-state - (setf (port-modifier-state port) - (state->modifiers - (x11::xkeyevent-state event) nil))))) - (:key-release - (multiple-value-bind (character keysym) - (lookup-character-and-keysym sheet widget event) - (allocate-event 'key-release-event - :key-name keysym - :character character - :sheet sheet - :modifier-state - (setf (port-modifier-state port) - (state->modifiers - (x11::xkeyevent-state event) nil))))) - (:button-press - (let ((button (x-button->silica-button - (x11::xbuttonevent-button event))) - (pointer (port-pointer port))) - (setf (pointer-button-state pointer) - (logior (pointer-button-state pointer) (or button 0))) - (allocate-event 'pointer-button-press-event - :sheet sheet - :pointer pointer - :x :?? :y :?? - :modifier-state - (setf (port-modifier-state port) - (state->modifiers - (x11::xkeyevent-state event))) - :button button - :native-x (x11::xbuttonevent-x event) - :native-y (x11::xbuttonevent-y event)))) - (:button-release - (let ((button (x-button->silica-button - (x11::xbuttonevent-button event))) - (pointer (port-pointer port))) - (setf (pointer-button-state pointer) - (logandc2 (pointer-button-state pointer) (or button 0))) - (allocate-event 'pointer-button-release-event - :pointer pointer - :sheet sheet - :x :?? :y :?? - :modifier-state - (setf (port-modifier-state port) - (state->modifiers - (x11::xkeyevent-state event))) - :button button - :native-x (x11::xbuttonevent-x event) - :native-y (x11::xbuttonevent-y event)))) - (:leave-notify - (allocate-event 'pointer-exit-event - :native-x native-x - :native-y native-y - :modifier-state - (setf (port-modifier-state port) - (state->modifiers (x11::xkeyevent-state event))) - :sheet sheet - :pointer (port-pointer port))) - (:enter-notify - (allocate-event 'pointer-enter-event - :native-x native-x - :native-y native-y - :modifier-state - (setf (port-modifier-state port) - (state->modifiers (x11::xkeyevent-state event))) - :sheet sheet - :pointer (port-pointer port))) - (:motion-notify - (allocate-event 'pointer-motion-event - :native-x native-x - :native-y native-y - :modifier-state - (setf (port-modifier-state port) - (state->modifiers (x11::xkeyevent-state event))) - :sheet sheet - :pointer (port-pointer port)))))) - (when clim-event - (distribute-event (port sheet) clim-event)))))) + #+ignore + (format excl:*initial-terminal-io* "Got event ~s~%" (tk::event-type event)) + (let ((port (port sheet)) + (clim-event nil)) + (when port + (setq clim-event + (ecase (tk::event-type event) + ((:map-notify :unmap-notify :selection-clear :selection-request + :selection-notify :client-message :mapping-notify :no-expose) + nil) + (:configure-notify + (sheet-mirror-resized-callback widget nil event sheet) + nil) + (:graphics-expose + ;; Tricky! + (setf (port-safe-backing-store port) nil) + nil) + (:expose + ;; This gets called only for an XmBulletinBoard widget. + (sheet-mirror-exposed-callback widget nil event sheet) + nil) + (:key-press + (multiple-value-bind (character keysym) + (lookup-character-and-keysym sheet widget event) + (allocate-event 'key-press-event + :sheet sheet + :key-name keysym + :character character + :modifier-state + (setf (port-modifier-state port) + (state->modifiers + (x11::xkeyevent-state event) nil))))) + (:key-release + (multiple-value-bind (character keysym) + (lookup-character-and-keysym sheet widget event) + (allocate-event 'key-release-event + :sheet sheet + :key-name keysym + :character character + :modifier-state + (setf (port-modifier-state port) + (state->modifiers + (x11::xkeyevent-state event) nil))))) + (:button-press + (let ((button (x-button->silica-button + (x11::xbuttonevent-button event))) + (pointer (port-pointer port))) + (setf (pointer-button-state pointer) + (logior (pointer-button-state pointer) button)) + (allocate-event 'pointer-button-press-event + :sheet sheet + :pointer pointer + :button button + :native-x (x11::xbuttonevent-x event) + :native-y (x11::xbuttonevent-y event) + :x :?? :y :?? + :modifier-state + (setf (port-modifier-state port) + (state->modifiers + (x11::xbuttonevent-state event)))))) + (:button-release + (let ((button (x-button->silica-button + (x11::xbuttonevent-button event))) + (pointer (port-pointer port))) + (setf (pointer-button-state pointer) + (logandc2 (pointer-button-state pointer) button)) + (allocate-event 'pointer-button-release-event + :sheet sheet + :pointer pointer + :button button + :native-x (x11::xbuttonevent-x event) + :native-y (x11::xbuttonevent-y event) + :x :?? :y :?? + :modifier-state + (setf (port-modifier-state port) + (state->modifiers + (x11::xkeyevent-state event)))))) + (:leave-notify + (allocate-event 'pointer-exit-event + :sheet sheet + :native-x (x11:xcrossingevent-x event) + :native-y (x11:xcrossingevent-y event) + :kind (boundary-detail->kind + (x11:xcrossingevent-detail event)) + :pointer (port-pointer port) + :modifier-state + (setf (port-modifier-state port) + (state->modifiers (x11::xcrossingevent-state event))))) + (:enter-notify + (allocate-event 'pointer-enter-event + :pointer (port-pointer port) + :sheet sheet + :native-x (x11:xcrossingevent-x event) + :native-y (x11:xcrossingevent-y event) + :kind (boundary-detail->kind + (x11:xcrossingevent-detail event)) + :modifier-state + (setf (port-modifier-state port) + (state->modifiers (x11::xcrossingevent-state event))))) + (:motion-notify + (multiple-value-bind (same-p root child root-x root-y + native-x native-y state) + (tk::query-pointer (tk::widget-window widget)) + (declare (ignore same-p root child)) + (allocate-event 'pointer-motion-event + :pointer (port-pointer port) + :sheet sheet + :x root-x ; These are actually unused... + :y root-y ; "" + :native-x native-x + :native-y native-y + :modifier-state + (setf (port-modifier-state port) + (state->modifiers state)))))))) + (when clim-event + (distribute-event port clim-event)))) (defun x-button->silica-button (button) - (ecase button - (0 nil) - (4 #+ignore (warn "got an event 4") - +pointer-left-button+) - (#.x11::button3 +pointer-right-button+) + (case button + (#.x11::button1 +pointer-left-button+) (#.x11::button2 +pointer-middle-button+) - (#.x11::button1 +pointer-left-button+))) + (#.x11::button3 +pointer-right-button+) + (#.x11::button4 +pointer-left-button+) ; These two are arbitrary. + (#.x11::button5 +pointer-left-button+))) + +(defun boundary-detail->kind (detail) + (declare (optimize (speed 3) (safety 0)) + (fixnum detail)) + (case detail + (#.x11:notifyancestor :ancestor) + (#.x11:notifyvirtual :virtual) + (#.x11:notifyinferior :inferior) + (#.x11:notifynonlinear :nonlinear) + (#.x11:notifynonlinearvirtual :nonlinear-virtual))) + (defmethod sheet-mirror-resized-callback (widget window event sheet) (declare (ignore widget window event)) @@ -513,65 +525,66 @@ (let ((port (port sheet))) (ecase (tk::event-type event) (:key-press - (distribute-event - port - (multiple-value-bind (character keysym) - (lookup-character-and-keysym sheet widget event) - (allocate-event 'key-press-event - :key-name keysym - :character character - :sheet sheet - :modifier-state (setf (port-modifier-state port) - (state->modifiers - (x11::xkeyevent-state event) nil)))))) + (distribute-event + port + (multiple-value-bind (character keysym) + (lookup-character-and-keysym sheet widget event) + (allocate-event 'key-press-event + :sheet sheet + :key-name keysym + :character character + :modifier-state (setf (port-modifier-state port) + (state->modifiers + (x11::xkeyevent-state event) nil)))))) (:key-release - (distribute-event - port - (multiple-value-bind (character keysym) - (lookup-character-and-keysym sheet widget event) - (allocate-event 'key-release-event - :key-name keysym - :character character - :sheet sheet - :modifier-state (setf (port-modifier-state port) - (state->modifiers - (x11::xkeyevent-state event) nil)))))) + (distribute-event + port + (multiple-value-bind (character keysym) + (lookup-character-and-keysym sheet widget event) + (allocate-event 'key-release-event + :sheet sheet + :key-name keysym + :character character + :modifier-state (setf (port-modifier-state port) + (state->modifiers + (x11::xkeyevent-state event) nil)))))) (:button-press - (let ((button (x-button->silica-button - (x11::xbuttonevent-button event))) - (pointer (port-pointer port))) - (setf (pointer-button-state pointer) - (logior (pointer-button-state pointer) (or button 0))) - (distribute-event - port - (allocate-event 'pointer-button-press-event - :sheet sheet - :pointer pointer - :x :?? :y :?? - :modifier-state (setf (port-modifier-state port) - (state->modifiers - (x11::xkeyevent-state event))) - :button button - :native-x (x11::xbuttonevent-x event) - :native-y (x11::xbuttonevent-y event))))) + (let ((button (x-button->silica-button + (x11::xbuttonevent-button event))) + (pointer (port-pointer port))) + (setf (pointer-button-state pointer) + (logior (pointer-button-state pointer) button)) + (distribute-event + port + (allocate-event 'pointer-button-press-event + :sheet sheet + :pointer pointer + :button button + :native-x (x11::xbuttonevent-x event) + :native-y (x11::xbuttonevent-y event) + :x :?? :y :?? + :modifier-state (setf (port-modifier-state port) + (state->modifiers + (x11::xbuttonevent-state event))))))) (:button-release - (let ((button (x-button->silica-button - (x11::xbuttonevent-button event))) - (pointer (port-pointer port))) - (setf (pointer-button-state pointer) - (logandc2 (pointer-button-state pointer) (or button 0))) - (distribute-event - port - (allocate-event 'pointer-button-release-event - :sheet sheet - :pointer pointer - :x :?? :y :?? - :modifier-state (setf (port-modifier-state port) - (state->modifiers - (x11::xkeyevent-state event))) - :button button - :native-x (x11::xbuttonevent-x event) - :native-y (x11::xbuttonevent-y event)))))))) + (let ((button (x-button->silica-button + (x11::xbuttonevent-button event))) + (pointer (port-pointer port))) + (setf (pointer-button-state pointer) + (logandc2 (pointer-button-state pointer) button)) + (distribute-event + port + (allocate-event 'pointer-button-release-event + :sheet sheet + :pointer pointer + :button button + :native-x (x11::xbuttonevent-x event) + :native-y (x11::xbuttonevent-y event) + :x :?? :y :?? + :modifier-state (setf (port-modifier-state port) + (state->modifiers + (x11::xbuttonevent-state event))))))) + ))) (defmethod find-widget-class-and-initargs-for-sheet ((port xt-port) (parent t) (sheet sheet)) @@ -652,10 +665,6 @@ (unless (xt::is-managed-p mirror) (manage-child mirror))) -(defmethod enable-xt-widget ((parent top-level-shell) (mirror t)) - (manage-child mirror) - (popup (widget-parent mirror))) - (defmethod disable-mirror ((port xt-port) sheet) (declare (ignore port)) (let ((mirror (sheet-mirror sheet))) @@ -994,10 +1003,12 @@ (define-xt-keysym right-hyper-keysym :right-hyper) (defun lookup-character-and-keysym (sheet mirror event) - (declare (ignore sheet mirror)) + (declare (ignore sheet mirror) + (optimize (speed 3) (safety 0))) (multiple-value-bind (character keysym) (tk::lookup-string event) - (setq character (and (= (length character) 1) (aref character 0))) + (setq character (and (= (length (the simple-string character)) 1) + (aref (the simple-string character) 0))) ;;--- Map the asci control-characters into the common lisp ;;--- control characters except where they are special! ;; Also deal with the modifier bits @@ -1016,23 +1027,29 @@ #\page #\backspace #\linefeed - #\escape)))) + #\escape) + :test #'eq))) (cltl1::int-char (+ (cltl1::char-int character) (1- (if (logtest x +shift-key+) (char-int #\A) (char-int #\a))))) character) - ;;-- Should deal with hyper and super also (logior (if (logtest x +control-key+) cltl1:char-control-bit 0) (if (logtest x +meta-key+) - cltl1:char-meta-bit 0)))))) + cltl1:char-meta-bit 0) + (if (logtest x +super-key+) + cltl1:char-super-bit 0) + (if (logtest x +hyper-key+) + cltl1:char-hyper-bit 0)))))) (values character (xt-keysym->keysym keysym)))) (defun state->modifiers (x &optional (shift-it t)) + (declare (optimize (speed 3) (safety 0)) + (fixnum x)) (logior (if (and shift-it (logtest x x11:shiftmask)) +shift-key+ 0) (if (logtest x x11:controlmask) +control-key+ 0) @@ -1227,20 +1244,17 @@ the geometry of the children. Instead the parent has control. ")) silica::*ports*)) -(defmethod port-canonicalize-gesture-spec ((port xt-port) gesture-spec &optional modifier-state) - (multiple-value-bind (keysym shifts) - (if modifier-state - (values gesture-spec modifier-state) - (parse-gesture-spec gesture-spec)) - ;; Here, we must take the gesture spec, turn it back into - ;; a keycode, then see what the keysyms are for that keycode - (let ((x-keysym (if (and (characterp keysym) (standard-char-p keysym)) - (keysym->xt-keysym (xt-keysym->keysym (char-code keysym))) - (keysym->xt-keysym keysym))) - (x-keycode nil)) - (unless x-keysym - (return-from port-canonicalize-gesture-spec nil)) - (cons keysym shifts)))) +(defmethod port-canonicalize-gesture-spec ((port xt-port) keysym &optional shifts) + (declare (optimize (speed 3) (safety 0))) + ;; Here, we must take the gesture spec, turn it back into + ;; a keycode, then see what the keysyms are for that keycode + (let ((x-keysym (if (and (characterp keysym) (standard-char-p keysym)) + (keysym->xt-keysym (xt-keysym->keysym (char-code keysym))) + (keysym->xt-keysym keysym))) + (x-keycode nil)) + (unless x-keysym + (return-from port-canonicalize-gesture-spec nil)) + (cons keysym shifts))) (defmethod port-set-pointer-position ((port xt-port) pointer x y) @@ -1260,13 +1274,13 @@ the geometry of the children. Instead the parent has control. ")) (defmethod enable-mirror ((port xt-port) (sheet top-level-sheet)) - (let* ((mirror (sheet-mirror sheet)) + (let* ((mirror (sheet-mirror sheet)) (parent (widget-parent mirror))) - (manage-child mirror) - (xt:realize-widget parent) ; Make sure widget is realized. - (let ((ussp (slot-value sheet 'silica::user-specified-size-p)) + (manage-child mirror) + (xt:realize-widget parent) ; Make sure widget is realized. + (let ((ussp (slot-value sheet 'silica::user-specified-size-p)) (uspp (slot-value sheet 'silica::user-specified-position-p))) - (unless (and (eq ussp :unspecified) + (unless (and (eq ussp :unspecified) (eq uspp :unspecified)) (let* ((window (tk::widget-window parent)) (display (tk::widget-display parent)) @@ -1287,9 +1301,9 @@ the geometry of the children. Instead the parent has control. ")) then (setf flags (logandc2 flags x11::ussizehint))) (setf (x11::xsizehints-flags size-hints) flags)) (x11::xsetwmnormalhints display window size-hints))))) - (popup parent))) + (popup parent))) - (defmethod enable-xt-widget ((parent top-level-shell) (mirror t)) - (manage-child mirror) - (popup (widget-parent mirror))) +(defmethod enable-xt-widget ((parent top-level-shell) (mirror t)) + (manage-child mirror) + (popup (widget-parent mirror))) diff --git a/tk/convenience.lisp b/tk/convenience.lisp index 32da4951a490c8133eae89a4a3eb331c031e4dc8..175e59a72c7312c1c2ec166391019c195fc4905b 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.10 92/06/16 19:10:47 cer Exp $ +;; $fiHeader: convenience.lisp,v 1.11 92/07/27 19:28:54 cer Exp $ (in-package :tk) @@ -30,7 +30,13 @@ (intern (substitute #\_ #\- (lispify-tk-name entry-point :package nil))))) `(progn - (defforeign ',c-function-name :entry-point ,entry-point) + (eval-when (eval compile) + (defforeign ',c-function-name + :entry-point ,entry-point + :call-direct t + :arguments '(foreign-address foreign-address foreign-address fixnum) + :arg-checking nil + :return-type :unsigned-integer)) (defclass ,class ,superclasses () (:metaclass xt-class)) diff --git a/tk/font.lisp b/tk/font.lisp index 5d92d4155314c25d7385591d2915ee11ea03c0d3..c0b8a53509de184c7a2c3d5689ca85e2d14aa023 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.11 92/04/28 09:25:00 cer Exp $ +;; $fiHeader: font.lisp,v 1.12 92/05/22 19:26:18 cer Exp $ (in-package :tk) @@ -48,23 +48,23 @@ :display display :foreign-address h))) -(defmethod font-width (font) +(defun font-width (font) (x11::xfontstruct-max-bounds-width font)) -(defmethod font-height (font) - (+ (font-ascent font) - (font-descent font))) +(defun font-height (font) + (+ (x11:xfontstruct-ascent font) + (x11:xfontstruct-descent font))) -(defmethod font-ascent (font) +(defun font-ascent (font) (x11:xfontstruct-ascent font)) -(defmethod font-descent (font) +(defun font-descent (font) (x11:xfontstruct-descent font)) -(defmethod font-all-chars-exist-p (font) +(defun font-all-chars-exist-p (font) (x11:xfontstruct-all-chars-exist font)) -(defmethod font-range (font) +(defun font-range (font) (let* ((h font) (min-byte-1 (x11:xfontstruct-min-byte1 h)) (max-byte-1 (x11:xfontstruct-max-byte1 h))) @@ -73,7 +73,7 @@ (values (x11:xfontstruct-min-char-or-byte2 h) (x11:xfontstruct-max-char-or-byte2 h)))))) -(defmethod char-width (font index) +(defun char-width (font index) (multiple-value-bind (min max) (font-range font) (if (and (<= min index) @@ -82,7 +82,7 @@ (x11:xfontstruct-per-char font) (- index min))))) -(defmethod char-dimensions (font index) +(defun char-dimensions (font index) (multiple-value-bind (min max) (font-range font) (if (and (<= min index) diff --git a/tk/foreign.lisp b/tk/foreign.lisp index 92d7717370b9970cd289052b03a9d5293bc00d72..9c8bd81ed9cb08ac8a43cad09ab670eae66f7e31 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.11 92/05/13 17:10:13 cer Exp Locker: cer $ +;; $fiHeader: foreign.lisp,v 1.12 92/05/22 19:26:19 cer Exp $ (in-package :tk) @@ -70,8 +70,11 @@ argc argv)))) (if (zerop d) - (error "cannot open the display: ~A" host) - d))) + (error "cannot open the display: ~A" host)) + ;; Used for debugging: + #+ignore + (x11:xsynchronize d 1) + d)) (defmethod initialize-instance :after ((d display) &rest args &key display diff --git a/tk/init.lisp b/tk/init.lisp deleted file mode 100644 index d3ece19a63a7f5600ee83f8f09280467c6a48a7e..0000000000000000000000000000000000000000 --- a/tk/init.lisp +++ /dev/null @@ -1,33 +0,0 @@ -;; -*- mode: common-lisp; package: tk -*- -;; -;; -[]- -;; -;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved. -;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA All rights reserved. -;; -;; The software, data and information contained herein are proprietary -;; to, and comprise valuable trade secrets of, Franz, Inc. They are -;; given in confidence by Franz, Inc. pursuant to a written license -;; agreement, and may be stored and used only in accordance with the terms -;; of such license. -;; -;; Restricted Rights Legend -;; ------------------------ -;; Use, duplication, and disclosure of the software, data and information -;; contained herein by any agency, department or entity of the U.S. -;; Government are subject to restrictions of Restricted Rights for -;; Commercial Software developed at private expense as specified in FAR -;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as -;; applicable. -;; -;; $fiHeader: init.lisp,v 1.4 92/02/24 13:03:05 cer Exp $ - - -(in-package :tk) - -(defvar *done* nil) -(unless *done* - (insert_classes) - (xt_toolkit_initialize) - (make-classes) - (setq *done* t)) diff --git a/tk/load-ol.lisp b/tk/load-ol.lisp index e51d2a0e7c0501314d18292a671868401aaf1fcd..87409db10f9351cd3c3e4f5fedf6e9053f4f00ac 100644 --- a/tk/load-ol.lisp +++ b/tk/load-ol.lisp @@ -1,4 +1,4 @@ -;; -*- mode: common-lisp; package: tk -*- +;; -*- mode: common-lisp; package: user -*- ;; ;; -[]- ;; @@ -20,52 +20,23 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: load-ol.lisp,v 1.12 92/06/23 08:19:07 cer Exp $ +;; $fiHeader: load-ol.lisp,v 1.13 92/07/27 19:28:56 cer Exp $ -(in-package :tk) +(in-package :user) -(defvar sys::*libxol-pathname* "/vapor/usr/tech/cer/stuff/clim-2.0/tk/lib2/libXol.a") -(defvar sys::*libxt-pathname* "/x11/R4/sun4-lib/libXt_d.a") +(provide :climxm) +(require :climg) -(defun load-from-ol () - (unless (ff:get-entry-point (ff:convert-to-lang "ol_appl_add_item")) - #+ignore (mapc #'ff::remove-entry-point - '("__unpack_quadruple" - "__prod_b10000" - "__carry_out_b10000" - "__prod_65536_b10000" - "__unpacked_to_decimal" - ;; got these when compiling on ox - "__pack_integer" - "_class_double" - "_class_single" - "_class_extended" - "__unpack_integer")) - (load "olsupport.o" - :system-libraries (list sys::*libxol-pathname* - sys::*libxt-pathname* - sys::*libx11-pathname*) - :print t)) - (x11::load-undefined-symbols-from-library - "stub-olit.o" - (x11::symbols-from-file - "misc/undefinedsymbols.xt" - "misc/undefinedsymbols.olit") - #+ignore '("__unpack_quadruple" - "__unpacked_to_decimal" - "__prod_b10000" - "__carry_out_b10000" - "__prod_65536_b10000" - ;; got these when compiling on ox - "__pack_integer" - "_class_double" - "_class_single" - "_class_extended" - "__unpack_integer") - #-ignore nil - (list sys::*libxol-pathname* - sys::*libxt-pathname* - sys::*libx11-pathname*))) +(defvar sys::*libxt-pathname* "/x11/R4/sun4-lib/libXt.a") -(load-from-ol) +(x11::load-undefined-symbols-from-library + "clim-olit" + (x11::symbols-from-file "misc/undefinedsymbols.olit") + (list sys::*libxt-pathname* sys::*libx11-pathname*)) +(unless (ff:get-entry-point (ff:convert-to-lang "ol_appl_add_item")) + (load "olsupport.o" + :system-libraries (list sys::*libxt-pathname* + sys::*libx11-pathname*) + :print t)) +(pushnew :clim-openlook *features*) diff --git a/tk/load-xm.lisp b/tk/load-xm.lisp index 8574d83178971b583035eb616127954b5924fc96..1a532ca750fb04139d1d18b678f176eec4c2a05b 100644 --- a/tk/load-xm.lisp +++ b/tk/load-xm.lisp @@ -1,4 +1,4 @@ -;; -*- mode: common-lisp; package: tk -*- +;; -*- mode: common-lisp; package: user -*- ;; ;; -[]- ;; @@ -20,51 +20,25 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: load-xm.lisp,v 1.16 92/07/06 18:51:19 cer Exp $ +;; $fiHeader: load-xm.lisp,v 1.17 92/07/27 19:28:57 cer Exp $ -(in-package :tk) +(in-package :user) + +(provide :climxm) +(require :climg) ;;;; -(defvar sys::*libxt-pathname* "/x11/R4/sun4-lib/libXt_d.a") -(defvar sys::*libxm-pathname* "/x11/R4/sun4-lib/libXm_d.a") +(defvar sys::*libxt-pathname* "/x11/R4/sun4-lib/libXt.a") -(defun load-from-xm () - (unless (ff:get-entry-point (ff:convert-to-lang "XmCreateMyDrawingArea")) - #+ignore (mapc #'ff::remove-entry-point - '("__unpack_quadruple" - "__prod_b10000" - "__carry_out_b10000" - "__prod_65536_b10000" - ;; got these when compiling on ox - "__pack_integer" - "_class_double" - "_class_single" - "_class_extended" - "__unpack_integer")) - (load "MyDrawingA.o" - :system-libraries (list sys::*libxm-pathname* - sys::*libxt-pathname* - sys::*libx11-pathname*) - :print t)) - (x11::load-undefined-symbols-from-library - "stub-motif.o" - (x11::symbols-from-file - "misc/undefinedsymbols.xt" - "misc/undefinedsymbols.motif") - #+ignore '("__unpack_quadruple" - "__prod_b10000" - "__carry_out_b10000" - "__prod_65536_b10000" - ;; got these when compiling on ox - "__pack_integer" - "_class_double" - "_class_single" - "_class_extended" - "__unpack_integer") - #-ignore nil - (list sys::*libxm-pathname* - sys::*libxt-pathname* - sys::*libx11-pathname*))) +(x11::load-undefined-symbols-from-library + "clim-motif.o" + (x11::symbols-from-file "misc/undefinedsymbols.motif") + (list sys::*libxt-pathname* sys::*libx11-pathname*)) -(load-from-xm) +(unless (ff:get-entry-point (ff:convert-to-lang "XmCreateMyDrawingArea")) + (load "MyDrawingA.o" + :system-libraries (list sys::*libxt-pathname* + sys::*libx11-pathname*) + :print t)) +(pushnew :clim-motif *features*) diff --git a/tk/load-xt.lisp b/tk/load-xt.lisp index b1c9a22564772d61b2f1624eef1a97ea3a7f6b21..a7aa9c0539386411c328e0637428f0a478faa2e9 100644 --- a/tk/load-xt.lisp +++ b/tk/load-xt.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: load-xt.lisp,v 1.2 92/06/02 13:30:38 cer Exp $ +;; $fiHeader: load-xt.lisp,v 1.3 92/07/27 19:28:59 cer Exp $ (in-package :tk) @@ -28,19 +28,14 @@ ;;;; -(defvar *libxt-pathname* "/x11/R4/sun4-lib/libXt_d.a") +(defvar sys::*libxt-pathname* "/x11/R4/sun4-lib/libXt.a") (defun load-from-xt () (x11::load-undefined-symbols-from-library "stub-xt.o" (x11::symbols-from-file "misc/undefinedsymbols.xt") - #+ignore '("__unpack_quadruple" - "__prod_b10000" - "__carry_out_b10000" - "__prod_65536_b10000") - #-ignore nil - (list *libxt-pathname* x11::*libx11-pathname*))) + (list sys::*libxt-pathname* sys::*libx11-pathname*))) (load-from-xt) diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp index 06a0dd15055562a943cd9dad5dc51f0d38842ba0..babd2c12ab9d18606e21ade54c869b0a6b2219af 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.23 92/07/27 19:29:00 cer Exp $ +;; $fiHeader: make-classes.lisp,v 1.24 92/08/18 17:23:20 cer Exp Locker: cer $ (in-package :tk) @@ -62,6 +62,11 @@ (error "No resource named ~s found for class ~s" resource-name class)) result)) +;; These are so we don't need the foreign functions at run time. +(defun xt-get-resource-list (class res-return num-res-return) + (xt_get_resource_list class res-return num-res-return)) +(defun xt-get-constraint-resource-list (class res-return num-res-return) + (xt_get_constraint_resource_list class res-return num-res-return)) (defmethod find-class-resource ((class xt-class) resource-name) (declare (optimize (speed 3) (safety 0))) @@ -76,7 +81,7 @@ :key #'resource-name) thenret else (get-resource-internal class - #'xt_get_resource_list + #'xt-get-resource-list 'resource resource-name))))))) @@ -90,7 +95,7 @@ value ; Never had it, never will (setf (gethash resource-name cached-constraint-resources) (get-resource-internal class - #'xt_get_constraint_resource_list + #'xt-get-constraint-resource-list 'constraint-resource resource-name)))))) @@ -126,10 +131,10 @@ r))) (defun get-resource-list (class) - (get-resource-list-internal class #'xt_get_resource_list 'resource)) + (get-resource-list-internal class #'xt-get-resource-list 'resource)) (defun get-constraint-resource-list (class) - (get-resource-list-internal class #'xt_get_constraint_resource_list + (get-resource-list-internal class #'xt-get-constraint-resource-list 'constraint-resource)) @@ -183,6 +188,7 @@ (let ((clist nil)) (dolist (class-ep classes) + #+ignore (format excl:*initial-terminal-io* ";; Initializing class ~s~%" class-ep) (let ((h (get-foreign-variable-value class-ep))) (push (list h class-ep) clist) @@ -257,11 +263,12 @@ (defun-c-callable toolkit-error-handler ((message :unsigned-long)) - (error "toolkit error: ~a" (char*-to-string message))) + (let ((*error-output* excl:*initial-terminal-io*)) + (error "Xt: ~a" (char*-to-string message)))) (defun-c-callable toolkit-warning-handler ((message :unsigned-long)) (let ((*error-output* excl:*initial-terminal-io*)) - (warn "toolkit warning: ~a" (char*-to-string message)))) + (warn "Xt: ~a" (char*-to-string message)))) ;; This is a terrible hack used to compensate for bugs/inconsistencies diff --git a/tk/ol-classes.lisp b/tk/ol-classes.lisp index 247e9678ee36f5bd6343aea1033bf2e27efc153f..c7558796d005bcb857eeca28f68fb47103642528 100644 --- a/tk/ol-classes.lisp +++ b/tk/ol-classes.lisp @@ -20,10 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-classes.lisp,v 1.5 92/05/07 13:10:54 cer Exp Locker: cer $ - -(provide :climol) -(require :climg) +;; $fiHeader: ol-classes.lisp,v 1.6 92/06/23 08:19:12 cer Exp $ (in-package :tk) diff --git a/tk/ol-funs.lisp b/tk/ol-funs.lisp index 89eb4cd104a0580d49d5e8bf5070eae689037d2c..eb96b53ce1bbb910f5f26ee18cf3b49a0c3a9b93 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-funs.lisp,v 1.4 92/06/23 08:19:14 cer Exp Locker: cer $ +;; $fiHeader: ol-funs.lisp,v 1.5 92/06/29 14:04:21 cer Exp $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -28,33 +28,122 @@ (in-package :tk) -(defforeign 'ol_toolkit_initialize :entry-point "_OlToolkitInitialize") +(defforeign 'ol_toolkit_initialize + :entry-point "_OlToolkitInitialize" + :call-direct t + :arguments nil + :arg-checking nil + :return-type :void) (defforeign 'ol_set_warning_handler - :entry-point "_OlSetWarningHandler") + :entry-point "_OlSetWarningHandler" + :call-direct t + :arguments '(integer) + :arg-checking nil + :return-type :unsigned-integer) (defforeign 'ol_set_error_handler - :entry-point "_OlSetErrorHandler") - + :entry-point "_OlSetErrorHandler" + :call-direct t + :arguments '(integer) + :arg-checking nil + :return-type :unsigned-integer) + (defforeign 'ol_set_va_display_error_msg_handler - :entry-point "_OlSetVaDisplayErrorMsgHandler") + :entry-point "_OlSetVaDisplayErrorMsgHandler" + :call-direct t + :arguments '(integer) + :arg-checking nil + :return-type :unsigned-integer) (defforeign 'ol_set_va_display_warning_msg_handler - :entry-point "_OlSetVaDisplayWarningMsgHandler") + :entry-point "_OlSetVaDisplayWarningMsgHandler" + :call-direct t + :arguments '(integer) + :arg-checking nil + :return-type :unsigned-integer) + +(defforeign 'ol_add_callback + :entry-point "_OlAddCallback" + :call-direct t + :arguments '(foreign-address foreign-address foreign-address foreign-address) + :arg-checking nil + :return-type :void) + +(defforeign 'ol_set_input_focus + :entry-point "_OlSetInputFocus" + :call-direct t + :arguments '(foreign-address fixnum integer) + :arg-checking nil + :return-type :void) -(defforeign 'ol_add_callback :entry-point "_OlAddCallback") +(defforeign 'ol_menu_post + :entry-point "_OlMenuPost" + :call-direct t + :arguments '(foreign-address) + :arg-checking nil + :return-type :void) + +(defforeign 'ol_menu_popdown + :entry-point "_OlMenuPopdown" + :call-direct t + :arguments '(foreign-address fixnum) + :arg-checking nil + :return-type :void) + +(defforeign 'ol_text_edit_clear_buffer + :entry-point "_OlTextEditClearBuffer" + :call-direct t + :arguments '(foreign-address) + :arg-checking nil + :return-type :fixnum) -(defforeign 'ol_set_input_focus :entry-point "_OlSetInputFocus") +(defforeign 'ol_text_edit_read_substring + :entry-point "_OlTextEditReadSubString" + :call-direct t + :arguments '(foreign-address foreign-address fixnum fixnum) + :arg-checking nil + :return-type :fixnum) -(defforeign 'ol_menu_post :entry-point "_OlMenuPost") -(defforeign 'ol_menu_popdown :entry-point "_OlMenuPopdown") -(defforeign 'ol_appl_add_item :entry-point "_ol_appl_add_item") -(defforeign 'ol_list_item_pointer :entry-point "_ol_list_item_pointer") +(defforeign 'ol_text_edit_insert + :entry-point "_OlTextEditInsert" + :call-direct t + :arguments '(foreign-address foreign-address fixnum) + :arg-checking nil + :return-type :fixnum) + +(defforeign 'ol_text_edit_get_last_position + :entry-point "_OlTextEditGetLastPosition" + :call-direct t + :arguments '(foreign-address foreign-address) + :arg-checking nil + :return-type :fixnum) + +(defforeign 'ol_register_help + :entry-point "_OlRegisterHelp" + :call-direct t + :arguments '(fixnum foreign-address foreign-address fixnum foreign-address) + :arg-checking nil + :return-type :void) -(defforeign 'ol_appl_touch_item :entry-point "_ol_appl_touch_item") +(defforeign 'ol_appl_add_item + :entry-point "_ol_appl_add_item" + :call-direct t + :arguments '(integer foreign-address foreign-address foreign-address + foreign-address) + :arg-checking nil + :return-type :unsigned-integer) + +(defforeign 'ol_list_item_pointer + :entry-point "_ol_list_item_pointer" + :call-direct t + :arguments '(integer) + :arg-checking nil + :return-type :unsigned-integer) -(defforeign 'ol_text_edit_clear_buffer :entry-point "_OlTextEditClearBuffer") -(defforeign 'ol_text_edit_read_substring :entry-point "_OlTextEditReadSubString") -(defforeign 'ol_text_edit_insert :entry-point "_OlTextEditInsert") -(defforeign 'ol_text_edit_get_last_position :entry-point "_OlTextEditGetLastPosition") -(defforeign 'ol_register_help :entry-point "_OlRegisterHelp") +(defforeign 'ol_appl_touch_item + :entry-point "_ol_appl_touch_item" + :call-direct t + :arguments '(integer foreign-address integer) + :arg-checking nil + :return-type :void) diff --git a/tk/ol-init.lisp b/tk/ol-init.lisp index b6421aa3466ab7656635dafd55e470ea69ceed48..cd94c31de9045ea7f106d8d1e0312a243709f879 100644 --- a/tk/ol-init.lisp +++ b/tk/ol-init.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.14 92/06/02 13:30:39 cer Exp $ +;; $fiHeader: ol-init.lisp,v 1.15 92/07/27 19:29:11 cer Exp $ (in-package :tk) @@ -29,36 +29,24 @@ (ol_toolkit_initialize)) (defun-c-callable ol-error-handler ((message :unsigned-long)) - (error "toolkit error: ~A" - (char*-to-string message))) + (let ((*error-output* excl:*initial-terminal-io*)) + (error "OLit: ~A" (char*-to-string message)))) (defun-c-callable ol-warning-handler ((message :unsigned-long)) - (warn "toolkit error: ~A" - (char*-to-string message))) + (let ((*error-output* excl:*initial-terminal-io*)) + (warn "OLit: ~A" (char*-to-string message)))) (defun-c-callable ol-error-va-handler ((message :unsigned-long)) - (error "toolkit error: ~A" - (char*-to-string message))) + (let ((*error-output* excl:*initial-terminal-io*)) + (error "OLit: ~A" (char*-to-string message)))) (defun-c-callable ol-warning-va-handler ((message :unsigned-long)) - (warn "toolkit error: ~A" - (char*-to-string message))) + (let ((*error-output* excl:*initial-terminal-io*)) + (warn "OLit: ~A" (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 8c88ff8b1a2134dd975b8d35e419a18d64989389..5ddd12c3b72b7acf8534f16c4c80e5216e0f81dc 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.10 92/06/16 19:10:53 cer Exp $ +;; $fiHeader: pkg.lisp,v 1.11 92/07/27 19:29:16 cer Exp $ (defpackage :tk ;;-- No we really need @@ -45,5 +45,6 @@ #:int32 #:int16 #:int8 + #:with-server-grabbed )) diff --git a/tk/resources.lisp b/tk/resources.lisp index 71429f8553f934dcef0e1105aef07a012f941822..dce12bb55bd632dc16ffd2755ac436965866a0d8 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.27 92/07/01 15:44:36 cer Exp $ +;; $fiHeader: resources.lisp,v 1.28 92/07/08 16:28:50 cer Exp $ (in-package :tk) @@ -42,17 +42,6 @@ (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) - (and (not (zerop value)) - (with-ref-par ((string 0)) - ;;--- I think we need to read the book about - ;;--- xm_string_get_l_to_r and make sure it works with multiple - ;;-- segment strings - (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 @@ -489,9 +478,6 @@ 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) @@ -553,11 +539,6 @@ (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 nil value)))) - (defmethod convert-resource-out ((widget t) (type (eql 'widget)) x) x) @@ -600,17 +581,6 @@ -;;-- This is a problem cos we dont know the number of items - -(defmethod convert-resource-in ((parent t) (type (eql 'xm-string-table)) value) - value) - -(defun convert-xm-string-table-in (parent table n) - (let ((r nil)) - (dotimes (i n (nreverse r)) - (push (convert-resource-in parent 'xm-string (x-arglist table i)) - r)))) - (defmethod convert-resource-out ((parent t) (type (eql 'proc)) value) (etypecase value ;;-- Should check to see if its registered diff --git a/tk/widget.lisp b/tk/widget.lisp index 7f07b3d43a08a978a4e70565ef7bf2ff9486093c..b2af6fca569614ddd7ee8e9c4162f466b6ff6f82 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.22 92/06/29 14:04:24 cer Exp $ +;; $fiHeader: widget.lisp,v 1.23 92/07/27 19:29:18 cer Exp $ (in-package :tk) @@ -46,14 +46,20 @@ :display display args)))) +;; These are so we don't need the foreign functions at run time. +(defun xt-create-widget (name class parent args num-args) + (xt_create_widget name class parent args num-args)) +(defun xt-create-managed-widget (name class parent args num-args) + (xt_create_managed_widget name class parent args num-args)) + (defun create-widget (name widget-class parent &rest args) (apply #'create-widget-1 - #'xt_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 - #'xt_create_managed_widget name widget-class parent + #'xt-create-managed-widget name widget-class parent args)) @@ -242,7 +248,7 @@ (error (c) c "Get-values failed!"))))) (defun set-sensitive (widget value) - (xtsetsensitive widget (if value 1 0))) + (xt_set_sensitive widget (if value 1 0))) ;; Could not think of anywhere better! diff --git a/tk/xlib.lisp b/tk/xlib.lisp index 8c9de2df5a25dce0de70a8991d08103c9be41589..a49677343db5ce91c054e8a0ca1d51ab725e5a7c 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.22 92/07/01 15:44:38 cer Exp Locker: cer $ +;; $fiHeader: xlib.lisp,v 1.23 92/07/24 10:53:40 cer Exp $ (in-package :tk) @@ -132,6 +132,7 @@ (define-window-reader map-state decode-window-map-state) (defun decode-window-map-state (x) + (declare (optimize (speed 3) (safety 0))) (ecase x (0 :unmapped) (1 :unviewable) @@ -176,13 +177,57 @@ depth)) (register-xid p display)))) -(defun-c-callable x-error-handler ((display :unsigned-long) (x :unsigned-long)) - (error "x-error:~S" - (get-error-text (x11:xerrorevent-error-code x) display))) - -(defun-c-callable x-io-error-handler (x) - (error "x-io-error:~S" x)) - +;; -- +;; Error handling + +(define-condition x-error (error) + ((display :reader x-error-display :initarg :display) + (error-code :reader x-error-error-code :initarg :error-code) + (request-code :reader x-error-request-code :initarg :request-code) + (minor-code :reader x-error-minor-code :initarg :minor-code) + (serial :reader x-error-serial :initarg :serial) + (resourceid :reader x-error-resourceid :initarg :resourceid) + (current-serial :reader x-error-current-serial :initarg :current-serial) + (asynchronous :reader x-error-asynchronous :initarg :asynchronous)) + (:report report-x-error)) + +(defun report-x-error (condition stream) + (let ((display (x-error-display condition)) + (error-code (x-error-error-code condition)) + (request-code (x-error-request-code condition)) + (minor-code (x-error-minor-code condition)) + (serial (x-error-serial condition)) + (resourceid (x-error-resourceid condition)) + (current-serial (x-error-current-serial condition))) + (format stream "~@<Xlib: ~;~a ~:_in ~:[request ~d (last request was ~d)~;current request~2*~], ~:_Code: ~d.~d~@[ [~a]~], ~:_ResourceID: ~d~:>" + (get-error-text error-code display) + (= serial current-serial) + serial current-serial request-code minor-code + (when (< 1 request-code 128) + (let ((request-cstring (princ-to-string request-code)) + (s (make-string 1000))) + (x11:xgeterrordatabasetext display "XRequest" request-cstring + 0 s 1000) + (let ((n (position (cltl1::int-char 0) s))) + (when n (setq s (subseq s 0 n)))) + s)) + resourceid))) + +(defun-c-callable x-error-handler ((display :unsigned-long) (event :unsigned-long)) + (let ((*error-output* excl:*initial-terminal-io*)) + (error 'x-error + :display display + :error-code (x11:xerrorevent-error-code event) + :request-code (x11:xerrorevent-request-code event) + :minor-code (x11:xerrorevent-minor-code event) + :resourceid (x11:xerrorevent-resourceid event) + :serial (x11:xerrorevent-serial event) + :current-serial (x11:display-request display)))) + +(defun-c-callable x-io-error-handler ((display :unsigned-long)) + (let ((*error-output* excl:*initial-terminal-io*)) + (error "Xlib: Connection to X11 server '~a' lost" + (ff:char*-to-string (x11:display-display-name display))))) (defun get-error-text (code display-handle) @@ -199,6 +244,7 @@ (eval-when (load) (setup-error-handlers)) +;;-- (defmethod display-root-window (display) (intern-object-xid @@ -521,3 +567,15 @@ (defun destroy-image (image) (x11:xdestroyimage image)) +;; + +(defmacro with-server-grabbed ((display) &body body) + `(let ((.display. ,display)) + (unwind-protect + (let ((result nil)) + (x11:xgrabserver .display.) + (x11:xflush .display.) + (excl:errorset (setq result (multiple-value-list (progn ,@body))) t) + (values-list (cdr result))) + (x11:xungrabserver .display.) + (x11:xflush .display.)))) diff --git a/tk/xm-classes.lisp b/tk/xm-classes.lisp index 1ac9e8ef3a241e76ccc2fa7e75205e1cf550fbe5..0f6f0b9d044ce223d77d4e0218d065ab3861d207 100644 --- a/tk/xm-classes.lisp +++ b/tk/xm-classes.lisp @@ -20,12 +20,9 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-classes.lisp,v 1.5 92/05/13 17:10:29 cer Exp $ +;; $fiHeader: xm-classes.lisp,v 1.6 92/07/01 15:44:39 cer Exp $ -(provide :climxm) -(require :climg) - (in-package :tk) ;;; This has to kept consistent with the Makefile diff --git a/tk/xm-funs.lisp b/tk/xm-funs.lisp index 0378df27acf20a9a12ecbd93d6d67dc2326780c0..9010a551c459cc02a9c2feefbbdf9ecf2d28cc71 100644 --- a/tk/xm-funs.lisp +++ b/tk/xm-funs.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.4 92/04/28 09:25:09 cer Exp Locker: cer $ +;; $fiHeader: xm-funs.lisp,v 1.5 92/05/06 15:37:11 cer Exp $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -30,48 +30,122 @@ (defforeign 'xm_string_create_l_to_r :entry-point "_XmStringCreateLtoR" - :return-type :integer) + :call-direct t + :callback nil + :arguments '(foreign-address foreign-address) + :return-type :unsigned-integer) (defforeign 'xm_string_get_l_to_r :entry-point "_XmStringGetLtoR" - :return-type :integer) + :call-direct t + :callback nil + :arguments '(foreign-address foreign-address foreign-address) + :arg-checking nil + :return-type :fixnum) (defforeign 'xm_get_pixmap - :entry-point "_XmGetPixmap") + :entry-point "_XmGetPixmap" + :call-direct t + :arguments '(foreign-address foreign-address integer integer) + :arg-checking nil + :return-type :unsigned-integer) (defforeign 'xm_font_list_init_font_context - :entry-point "_XmFontListInitFontContext") + :entry-point "_XmFontListInitFontContext" + :call-direct t + :callback nil + :arguments '(foreign-address foreign-address) + :arg-checking nil + :return-type :fixnum) (defforeign 'xm_font_list_free_font_context - :entry-point "_XmFontListFreeFontContext") + :entry-point "_XmFontListFreeFontContext" + :call-direct t + :callback nil + :arguments '(foreign-address) + :arg-checking nil + :return-type :void) (defforeign 'xm_font_list_get_next_font - :entry-point "_XmFontListGetNextFont") + :entry-point "_XmFontListGetNextFont" + :call-direct t + :callback nil + :arguments '(foreign-address foreign-address foreign-address) + :arg-checking nil + :return-type :fixnum) (defforeign 'xm_font_list_create - :entry-point "_XmFontListCreate") + :entry-point "_XmFontListCreate" + :call-direct t + :callback nil + :arguments '(foreign-address foreign-address) + :arg-checking nil + :return-type :unsigned-integer) (defforeign 'xm_add_protocol_callback - :entry-point "_XmAddProtocolCallback") + :entry-point "_XmAddProtocolCallback" + :call-direct t + :arguments '(foreign-address integer integer foreign-address foreign-address) + :arg-checking nil + :return-type :void) (defforeign 'xm_intern_atom - :entry-point "_XmInternAtom") - -(defforeign 'xm_main_window_set_area :entry-point - "_XmMainWindowSetAreas") + :entry-point "_XmInternAtom" + :call-direct t + :callback nil + :arguments '(foreign-address foreign-address fixnum) + :arg-checking nil + :return-type :unsigned-integer) + +(defforeign 'xm_main_window_set_area + :entry-point "_XmMainWindowSetAreas" + :call-direct t + :arguments '(foreign-address foreign-address foreign-address + foreign-address foreign-address foreign-address) + :arg-checking nil + :return-type :void) (ff:defforeign 'xm_process_traversal - :entry-point "_XmProcessTraversal") + :entry-point "_XmProcessTraversal" + :call-direct t + :arguments '(foreign-address integer) + :arg-checking nil + :return-type :fixnum) (defforeign 'xm-message-box-get-child - :entry-point "_XmMessageBoxGetChild") + :entry-point "_XmMessageBoxGetChild" + :call-direct t + :arguments '(foreign-address fixnum) + :arg-checking nil + :return-type :unsigned-integer) (defforeign 'xm_file_selection_do_search - :entry-point "_XmFileSelectionDoSearch") + :entry-point "_XmFileSelectionDoSearch" + :call-direct t + :arguments '(foreign-address foreign-address) + :arg-checking nil + :return-type :void) (defforeign 'xm_option_label_gadget - :entry-point "_XmOptionLabelGadget") + :entry-point "_XmOptionLabelGadget" + :call-direct t + :arguments '(foreign-address) + :arg-checking nil + :return-type :unsigned-integer) (defforeign 'xm_option_button_gadget - :entry-point "_XmOptionButtonGadget") + :entry-point "_XmOptionButtonGadget" + :call-direct t + :arguments '(foreign-address) + :arg-checking nil + :return-type :unsigned-integer) + +(defforeign 'initializemydrawingareaquerygeometry + :entry-point "_InitializeMyDrawingAreaQueryGeometry" + :call-direct t + :callback nil + :arguments '(integer) + :arg-checking nil + :return-type :void) + diff --git a/tk/xm-widgets.lisp b/tk/xm-widgets.lisp index 6f30796e21200954248605c1c7195f00aa63f25e..32293900e040978e527a87c09af4f177fb83a0f4 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.6 92/04/21 20:27:49 cer Exp $ +;; $fiHeader: xm-widgets.lisp,v 1.7 92/07/27 19:29:20 cer Exp $ (in-package :tk) @@ -62,3 +62,34 @@ "keyboardFocusPolicy"))) +;; Moved here as to be after loading xm-funs. + +;;-- This is a problem cos we dont know the number of items + +(defconstant xm_string_default_char_set "") + +(defmethod convert-resource-in (class (type (eql 'xm-string)) value) + (and (not (zerop value)) + (with-ref-par ((string 0)) + ;;--- I think we need to read the book about + ;;--- xm_string_get_l_to_r and make sure it works with multiple + ;;-- segment strings + (xm_string_get_l_to_r value xm_string_default_char_set string) + (char*-to-string (aref string 0))))) + +(defmethod convert-resource-in ((parent t) (type (eql 'xm-string-table)) value) + value) + +(defun convert-xm-string-table-in (parent table n) + (let ((r nil)) + (dotimes (i n (nreverse r)) + (push (convert-resource-in parent 'xm-string (x-arglist table i)) + r)))) + +(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 'xm-background-pixmap)) value) + (etypecase value + (pixmap + (encode-pixmap nil value)))) diff --git a/tk/xt-funs.lisp b/tk/xt-funs.lisp index e290a4a52d49b1dfd6e2886d121f597c91f7f161..46e903035d127226af71688ac8a402fcd843f775 100644 --- a/tk/xt-funs.lisp +++ b/tk/xt-funs.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-funs.lisp,v 1.7 92/07/01 15:44:40 cer Exp $ +;; $fiHeader: xt-funs.lisp,v 1.8 92/07/08 16:28:51 cer Exp $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -28,100 +28,255 @@ (in-package :xt) -(defforeign 'xt_get_resource_list :entry-point "_XtGetResourceList") -(defforeign 'xt_get_constraint_resource_list :entry-point "_XtGetConstraintResourceList") +(defforeign 'xt_get_resource_list + :entry-point "_XtGetResourceList" + :call-direct t + :arguments '(foreign-address foreign-address foreign-address) + :arg-checking nil + :return-type :void) + +(defforeign 'xt_get_constraint_resource_list + :entry-point "_XtGetConstraintResourceList" + :call-direct t + :arguments '(foreign-address foreign-address foreign-address) + :arg-checking nil + :return-type :void) -(defforeign 'xt_initialize_widget_class :entry-point "_XtInitializeWidgetClass") +(defforeign 'xt_initialize_widget_class + :entry-point "_XtInitializeWidgetClass" + :call-direct t + :arguments '(foreign-address) + :arg-checking nil + :return-type :void) (defforeign 'xt_free - :arguments '(ff:foreign-address) + :entry-point "_XtFree" :call-direct t :callback nil + :arguments '(foreign-address) :arg-checking nil - :return-type :void - :entry-point "_XtFree") + :return-type :void) (defforeign 'xt_toolkit_initialize - :entry-point "_XtToolkitInitialize") + :entry-point "_XtToolkitInitialize" + :call-direct t + :arguments nil + :arg-checking nil + :return-type :void) (defforeign 'xt_create_application_context - :entry-point "_XtCreateApplicationContext") - + :entry-point "_XtCreateApplicationContext" + :call-direct t + :arguments nil + :arg-checking nil + :return-type :unsigned-integer) (defforeign 'xt_app_set_error_handler - :entry-point "_XtAppSetErrorHandler") + :entry-point "_XtAppSetErrorHandler" + :call-direct t + :arguments '(foreign-address integer) + :arg-checking nil + :return-type :integer) (defforeign 'xt_app_set_warning_handler - :entry-point "_XtAppSetWarningHandler") + :entry-point "_XtAppSetWarningHandler" + :call-direct t + :arguments '(foreign-address integer) + :arg-checking nil + :return-type :integer) (defforeign 'xt_open_display - :entry-point "_XtOpenDisplay") + :entry-point "_XtOpenDisplay" + :call-direct t + :arguments '(foreign-address foreign-address foreign-address foreign-address + foreign-address fixnum foreign-address foreign-address) + :arg-checking nil + :return-type :unsigned-integer) (defforeign 'xt_app_create_shell - :entry-point "_XtAppCreateShell") + :entry-point "_XtAppCreateShell" + :call-direct t + :arguments '(foreign-address foreign-address foreign-address foreign-address + foreign-address fixnum) + :arg-checking nil + :return-type :unsigned-integer) ;;;; -(defforeign 'xt_create_widget :entry-point "_XtCreateWidget") +(defforeign 'xt_create_widget + :entry-point "_XtCreateWidget" + :call-direct t + :arguments '(foreign-address foreign-address foreign-address + foreign-address fixnum) + :arg-checking nil + :return-type :unsigned-integer) + + (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 '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") + :entry-point "_XtCreateManagedWidget" + :call-direct t + :arguments '(foreign-address foreign-address foreign-address + foreign-address fixnum) + :arg-checking nil + :return-type :unsigned-integer) + +(defforeign 'xt_realize_widget + :entry-point "_XtRealizeWidget" + :call-direct t + :arguments '(foreign-address) + :arg-checking nil + :return-type :void) + +(defforeign 'xt_destroy_widget + :entry-point "_XtDestroyWidget" + :call-direct t + :arguments '(foreign-address) + :arg-checking nil + :return-type :void) + +(defforeign 'xt_manage_child + :entry-point "_XtManageChild" + :call-direct t + :arguments '(foreign-address) + :arg-checking nil + :return-type :void) + +(defforeign 'xt_is_managed + :entry-point "_XtIsManaged" + :call-direct t + :arguments '(foreign-address) + :arg-checking nil + :return-type :fixnum) + +(defforeign 'xt_unmanage_child + :entry-point "_XtUnmanageChild" + :call-direct t + :arguments '(foreign-address) + :arg-checking nil + :return-type :void) + +(defforeign 'xt_manage_children + :entry-point "_XtManageChildren" + :call-direct t + :arguments '(foreign-address fixnum) + :arg-checking nil + :return-type :void) + +(defforeign 'xt_create_popup_shell + :entry-point "_XtCreatePopupShell" + :call-direct t + :arguments '(foreign-address foreign-address foreign-address foreign-address fixnum) + :arg-checking nil + :return-type :unsigned-integer) + +(defforeign 'xt_popup + :entry-point "_XtPopup" + :call-direct t + :arguments '(foreign-address integer) + :arg-checking nil + :return-type :void) + +(defforeign 'xt_popdown + :entry-point "_XtPopdown" + :call-direct t + :arguments '(foreign-address) + :arg-checking nil + :return-type :void) + +(defforeign 'xt_window + :entry-point "_XtWindow" + :call-direct t + :arguments '(foreign-address) + :arg-checking nil + :return-type :unsigned-integer) + +(defforeign 'xt_parent + :entry-point "_XtParent" + :call-direct t + :arguments '(foreign-address) + :arg-checking nil + :return-type :unsigned-integer) + +(defforeign 'xt_query_geometry + :entry-point "_XtQueryGeometry" + :call-direct t + :arguments '(foreign-address foreign-address foreign-address) + :arg-checking nil + :return-type :unsigned-integer) + +(defforeign 'xt_configure_widget + :entry-point "_XtConfigureWidget" + :call-direct t + :arguments '(foreign-address fixnum fixnum fixnum fixnum fixnum) + :arg-checking nil + :return-type :void) (defforeign 'xt_set_values - :arguments '(ff:foreign-address ff:foreign-address fixnum) + :arguments '(foreign-address 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) + :arguments '(foreign-address 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) + :arguments '(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) + :arguments '(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 'xt_add_callback :entry-point "_XtAddCallback") -(defforeign 'xt_has_callbacks :entry-point "_XtHasCallbacks") -(defforeign 'xt_remove_all_callbacks :entry-point "_XtRemoveAllCallbacks") +(defforeign 'xt_add_event_handler + :entry-point "_XtAddEventHandler" + :call-direct t + :arguments '(foreign-address integer fixnum foreign-address foreign-address) + :arg-checking nil + :return-type :void) + +(defforeign 'xt_build_event_mask + :entry-point "_XtBuildEventMask" + :call-direct t + :arguments '(foreign-address) + :arg-checking nil + :return-type :unsigned-integer) + +(defforeign 'xt_add_callback + :entry-point "_XtAddCallback" + :call-direct t + :arguments '(foreign-address foreign-address foreign-address foreign-address) + :arg-checking nil + :return-type :void) + +(defforeign 'xt_has_callbacks + :entry-point "_XtHasCallbacks" + :call-direct t + :arguments '(foreign-address foreign-address) + :arg-checking nil + :return-type :unsigned-integer) + +(defforeign 'xt_remove_all_callbacks + :entry-point "_XtRemoveAllCallbacks" + :call-direct t + :arguments '(foreign-address foreign-address) + :arg-checking nil + :return-type :void) + +(defforeign 'xt_set_sensitive + :entry-point "_XtSetSensitive" + :call-direct t + :arguments '(foreign-address fixnum) + :arg-checking nil + :return-type :void) + -(defforeign 'xtsetsensitive :entry-point "_XtSetSensitive") diff --git a/xlib/load-xlib.lisp b/xlib/load-xlib.lisp index c563f06ae1a220890b217945d8901c8b6f2f5f48..8d4c2fb457eda0ad249f4e4aaac499e83aa77ca6 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.6 92/06/16 15:01:26 cer Exp $ +;; $fiHeader: load-xlib.lisp,v 1.7 92/07/27 19:29:30 cer Exp $ (in-package :x11) @@ -33,7 +33,7 @@ (push l r)))))) -(defun load-undefined-symbols-from-library (file what kludges libraries) +(defun load-undefined-symbols-from-library (file what libraries) (let* ((n (length what)) (names (coerce what 'vector)) (entry-points (make-array n :element-type '(unsigned-byte 32)))) @@ -44,12 +44,11 @@ (when (= (aref entry-points i) sys::*impossible-load-address*) (format t ";; ~A is undefined~%" (aref names i)))) - (mapc #'foreign-functions:remove-entry-point kludges) (load file :system-libraries libraries :print t)))) -(defvar sys::*libx11-pathname* "/x11/R4/sun4-lib/libX_d.a") +(defvar sys::*libx11-pathname* "/x11/R4/sun4-lib/libX11.a") (unless (ff:get-entry-point (ff:convert-to-lang "lisp_XDrawString")) (load "xlibsupport.o" :system-libraries (list sys::*libx11-pathname*) :print t)) @@ -57,11 +56,5 @@ (x11::load-undefined-symbols-from-library "stub-x.o" (x11::symbols-from-file "misc/undefinedsymbols") - ;; This was only needed when bogus removesyms was done. - #+ignore '("__unpack_quadruple" - "__prod_b10000" - "__carry_out_b10000" - "__prod_65536_b10000") - #-ignore nil (list sys::*libx11-pathname*))