From 5858407d20daff6f41061d87889ec326bf9226e4 Mon Sep 17 00:00:00 2001 From: cer <cer> Date: Mon, 27 Jul 1992 19:30:28 +0000 Subject: [PATCH] jdi_merge --- ChangeLog.n | 82 +++++++++++++++ Makefile | 189 +++++++++++++++++++++++++++++++++-- clim/frames.lisp | 87 ++++++++++------ clim/graphics-recording.lisp | 35 ++++--- clim/input-protocol.lisp | 7 +- clim/menus.lisp | 11 +- misc/dev-load-1.lisp | 7 +- misc/load-xm.lisp | 36 ------- misc/undefinedsymbols | 2 + silica/framem.lisp | 14 +-- silica/layout.lisp | 23 +++-- tk-silica/pkg.lisp | 4 +- tk-silica/xt-graphics.lisp | 7 +- tk-silica/xt-silica.lisp | 36 ++++++- tk/convenience.lisp | 8 +- tk/load-ol.lisp | 51 +++++----- tk/load-xm.lisp | 53 +++++----- tk/load-xt.lisp | 13 +-- tk/make-classes.lisp | 46 +++++---- tk/make-widget.lisp | 12 +-- tk/ol-init.lisp | 8 +- tk/ol-widgets.lisp | 10 +- tk/pkg.lisp | 3 +- tk/widget.lisp | 4 +- tk/xm-widgets.lisp | 16 +-- xlib/load-xlib.lisp | 12 ++- xlib/xlib-defs.lisp | 32 +++++- xlib/xlib-funs.lisp | 19 +++- 28 files changed, 580 insertions(+), 247 deletions(-) delete mode 100644 misc/load-xm.lisp diff --git a/ChangeLog.n b/ChangeLog.n index 3b8deebc..82591ae0 100644 --- a/ChangeLog.n +++ b/ChangeLog.n @@ -1,3 +1,85 @@ +-------------------------------------------------------------------------------- +from jdi: Mon Jul 27 19:28:33 PDT 1992 + +NOTES + 1: Delete files: + clim/output-recording-protocol.lisp + clim/output-recording-defs.lisp + + 2: New directory malloclib. Contains debugging version of malloc & + friends. To turn on, uncomment appropriate lines in Makefile + + 3: This time, you want most of my changes to the Makefile. I tried to + edit out the unnecessary ones. +-- + + Makefile + -- Added optional malloclib support. Added source rule + so TAGS file is correct. + + clim/frames + -- Added support for use-specified-{size,position}-p frame + and their default processing in make-application-frame. + + clim/graphics-recording + -- Fixed problem where point sequence wasn't always copied, + leading to death because the original was stack allocated. + + clim/input-protocol + -- Turn off highlighted presentation on leave event. + + clim/menus + -- Send the beep to a CLIM window. + + misc/dev-load-1 + -- take out malloc & bogus update-package form + + misc/load-xm + -- take out malloc + + misc/undefinedsymbols + -- add X{Get,Set}WMNormalHints + + silica/framem + silica/layout + -- more user-specified hacking + + tk/convenience + tk/make-widget + tk/ol-init + tk/ol-widgets + tk/xm-widgets + tk/widget + -- remf had args reversed + + tk/load-ol + tk/load-xm + tk/load-xt + xlib/load-xlib + -- remove-entry-point no longer necessary + + tk/make-classes + -- resource not found error now caught at higher level. + + tk/pkg + -- export realize-widget + + tk-silica/xt-graphics + -- finish output needs to XSync, not XFlush + + tk-silica/xt-silica + -- sheet-mirror-event-handler rewritten. Now doesn't have + to incur server roundtrip for each event. + Button handling code rewritten. + -- new enable-mirror method for user-specified stuff + -- misc other stuff + + xlib/xlib-defs + -- added xsizehints definition + xlib/xlib-fnus + -- added xallocsizehints, xsetwmnormalhints, xgetwmnormalhints + + -------------------------------------------------------------------------------- from swm: Mon Jul 20 13:49:12 PDT 1992 diff --git a/Makefile b/Makefile index 6e7471c7..e9797b78 100644 --- a/Makefile +++ b/Makefile @@ -1,8 +1,9 @@ -# $fiHeader: Makefile,v 1.38 92/07/08 16:31:43 cer Exp Locker: cer $ +# $fiHeader: Makefile,v 1.39 92/07/17 13:52:32 cer Exp Locker: cer $ # # Makefile for CLIM 2.0 # CL = /usr/tech/cer/cl/src/dcl +PWD = /usr/tech/cer/stuff/clim-2.0 DUMP-CL = $(CL) CLOPTS = -qq @@ -66,9 +67,9 @@ CL_SRC=/usr/tech/cer/cl/src OPENWINHOME=/usr/openwin-3.0 -DEBUGLIB=_d +DEBUGLIB= MOTIFLIB=/x11/R4/sun4-lib/libXm$(DEBUGLIB).a -XLIB= /x11/R4/sun4-lib/libX$(DEBUGLIB).a +XLIB= /x11/R4/sun4-lib/libX11$(DEBUGLIB).a XTLIB=/x11/R4/sun4-lib/libXt$(DEBUGLIB).a XLIBS= $(XTLIB) $(XLIB) @@ -96,6 +97,15 @@ CLIMOBJS= stub-x.o stub-xt.o stub-motif.o stub-olit.o xlibsupport.o MyDrawingA.o FCLIMOBJS= `pwd`/stub-motif.o `pwd`/stub-olit.o `pwd`/stub-x.o `pwd`/stub-xt.o `pwd`/xlibsupport.o `pwd`/MyDrawingA.o `pwd`/olsupport.o +MALLOCOBJS = +# Uncomment to enable malloc debugging. +# +# MALLOCOBJS= $(PWD)/malloclib/malloc.o $(PWD)/malloclib/free.o $(PWD)/malloclib/realloc.o \ +# $(PWD)/malloclib/calloc.o $(PWD)/malloclib/string.o \ +# $(PWD)/malloclib/malloc_chk.o $(PWD)/malloclib/malloc_chn.o \ +# $(PWD)/malloclib/memory.o $(PWD)/malloclib/tostring.o \ +# $(PWD)/malloclib/m_perror.o $(PWD)/malloclib/m_init.o \ +# $(PWD)/malloclib/mallopt.o $(PWD)/malloclib/dump.o $(PWD)/malloclib/leak.o # # "Compile time objects" -- these go into clim-debug.fasl @@ -280,6 +290,165 @@ OPENLOOK-CLIM-OBJS = tk-silica/pkg.fasl \ tk-silica/xt-cursor.fasl \ tk-silica/xt-pixmaps.fasl +# Used for tags +ALL_SRC = utils/excl-verification.lisp \ + utils/lisp-package-fixups.lisp \ + utils/defpackage.lisp \ + utils/packages.lisp \ + utils/defun-utilities.lisp \ + utils/reader.lisp \ + utils/clos-patches.lisp \ + utils/clos.lisp \ + utils/utilities.lisp \ + utils/lisp-utilities.lisp \ + utils/processes.lisp \ + utils/queue.lisp \ + utils/protocols.lisp \ + utils/autoconstructor.lisp \ + utils/clim-streams.lisp \ + utils/excl-streams.lisp \ + utils/clim-macros.lisp \ + utils/transformations.lisp \ + utils/regions.lisp \ + utils/region-arithmetic.lisp \ + utils/extended-regions.lisp \ + utils/designs.lisp \ + silica/classes.lisp \ + silica/text-style.lisp \ + silica/macros.lisp \ + silica/sheet.lisp \ + silica/mirror.lisp \ + silica/event.lisp \ + silica/port.lisp \ + silica/medium.lisp \ + silica/framem.lisp \ + silica/graphics.lisp \ + silica/std-sheet.lisp \ + silica/layout.lisp \ + silica/db-layout.lisp \ + silica/db-box.lisp \ + silica/db-table.lisp \ + silica/gadgets.lisp \ + silica/db-border.lisp \ + silica/db-scroll.lisp \ + silica/db-button.lisp \ + silica/db-slider.lisp \ + clim/gestures.lisp \ + clim/defprotocol.lisp \ + clim/stream-defprotocols.lisp \ + clim/defresource.lisp \ + clim/temp-strings.lisp \ + clim/clim-defs.lisp \ + clim/stipples.lisp \ + clim/stream-class-defs.lisp \ + clim/interactive-defs.lisp \ + clim/cursor.lisp \ + clim/view-defs.lisp \ + clim/input-defs.lisp \ + clim/input-protocol.lisp \ + clim/output-protocol.lisp \ + clim/recording-defs.lisp \ + clim/recording-protocol.lisp \ + clim/text-recording.lisp \ + clim/graphics-recording.lisp \ + clim/interactive-protocol.lisp \ + clim/input-editor-commands.lisp \ + clim/formatted-output-defs.lisp \ + clim/incremental-redisplay.lisp \ + clim/coordinate-sorted-set.lisp \ + clim/window-stream.lisp \ + clim/ptypes1.lisp \ + clim/completer.lisp \ + clim/presentations.lisp \ + clim/translators.lisp \ + clim/histories.lisp \ + clim/ptypes2.lisp \ + clim/standard-types.lisp \ + clim/excl-presentations.lisp \ + clim/table-formatting.lisp \ + clim/graph-formatting.lisp \ + clim/surround-output.lisp \ + clim/text-formatting.lisp \ + clim/tracking-pointer.lisp \ + clim/dragging-output.lisp \ + clim/db-stream.lisp \ + clim/gadget-output.lisp \ + clim/accept.lisp \ + clim/present.lisp \ + clim/command.lisp \ + clim/command-processor.lisp \ + clim/basic-translators.lisp \ + clim/frames.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 \ + xlib/ffi.lisp \ + xlib/xlib-defs.lisp \ + xlib/load-xlib.lisp \ + xlib/xlib-funs.lisp \ + xlib/x11-keysyms.lisp \ + xlib/last.lisp \ + tk/pkg.lisp \ + tk/macros.lisp \ + tk/xt-defs.lisp \ + tk/foreign-obj.lisp \ + tk/xlib.lisp \ + tk/font.lisp \ + tk/gcontext.lisp \ + tk/graphics.lisp \ + tk/meta-tk.lisp \ + tk/make-classes.lisp \ + tk/foreign.lisp \ + tk/widget.lisp \ + tk/resources.lisp \ + tk/event.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 \ + tk/xt-funs.lisp \ + tk/xm-funs.lisp \ + tk/xm-classes.lisp \ + tk/xm-init.lisp \ + tk/xm-widgets.lisp \ + tk/xm-font-list.lisp \ + tk/xm-protocols.lisp \ + tk/convenience.lisp \ + tk/make-widget.lisp \ + tk-silica/pkg.lisp \ + tk-silica/xt-silica.lisp \ + tk-silica/xm-silica.lisp \ + tk-silica/xt-graphics.lisp \ + tk-silica/xm-graphics.lisp \ + tk-silica/image.lisp \ + tk-silica/xt-frames.lisp \ + tk-silica/xm-frames.lisp \ + tk-silica/xt-gadgets.lisp \ + tk-silica/xm-gadgets.lisp \ + tk-silica/xm-menus.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 \ + tk/ol-widgets.lisp \ + tk/ol-callbacks.lisp \ + tk-silica/ol-silica.lisp \ + tk-silica/ol-graphics.lisp \ + tk-silica/ol-frames.lisp \ + tk-silica/ol-gadgets.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) @@ -362,7 +531,7 @@ tk/xm-defs.fasl : tk/xm-defs.lisp # Building clim-xm: FORCE - -$(RM) $(CLIM) +# -$(RM) $(CLIM) $(ECHO) " \ (load \"misc/dev-load-xm.lisp\") \ (load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch @@ -391,7 +560,7 @@ clim-small: FORCE (load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch $(MV) $(TMP)/clim.temp_`whoami` $(CLIM-SMALL) ls -lt $(CLIM-SMALL) >> Clim-sizes.n - size $(CLIM) >> Clim-sizes.n + size $(CLIM-SMALL) >> Clim-sizes.n ls -lt $(CLIM-SMALL) # Training @@ -412,7 +581,7 @@ cheapclean: tags: - $(TAGS) `find $(DIRS) '(' -name "*.cl" -o -name "*.lisp" ')' -print` + $(TAGS) $(ALL_SRC) swm-tape: tar cf $(DEVICE) `find $(PUBDIRS) '(' -name "*.cl" -o -name "*.lisp" ')' -print` @@ -452,13 +621,13 @@ makeclimobjs : $(CLIMOBJS) ################## Lower level Makefile stuff -ol-dcl : stub-x.o stub-xt.o stub-olit.o xlibsupport.o olsupport.o +ol-dcl : stub-x.o stub-xt.o stub-olit.o xlibsupport.o olsupport.o $(MALLOCOBJS) cd $(CL_SRC) ; /bin/rm -f ucl ;\ - make initial_oldspace=$(OLDSPACE) oldspace=$(OLDSPACE) newspace=$(NEWSPACE) ucl_xtras='$(PWD)/stub-x.o $(PWD)/stub-xt.o $(PWD)/stub-olit.o $(PWD)/xlibsupport.o $(PWD)/olsupport.o $(LIBXOL) $(OLXLIBS)' dcl + 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 -xm-dcl : stub-x.o stub-xt.o stub-motif.o xlibsupport.o MyDrawingA.o +xm-dcl : stub-x.o stub-xt.o stub-motif.o xlibsupport.o MyDrawingA.o $(MALLOCOBJS) cd $(CL_SRC) ; /bin/rm -f ucl ;\ - make initial_oldspace=$(OLDSPACE) oldspace=$(OLDSPACE) newspace=$(NEWSPACE) ucl_xtras='$(PWD)/stub-x.o $(PWD)/stub-xt.o $(PWD)/stub-motif.o $(PWD)/xlibsupport.o $(PWD)/MyDrawingA.o $(MOTIFLIB) $(XTLIB) $(XLIB)' dcl + 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 dcl : cd $(CL_SRC) ; /bin/rm -f ucl ;\ diff --git a/clim/frames.lisp b/clim/frames.lisp index 9036d6ca..fc60e1e3 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.33 92/07/24 10:54:21 cer Exp Locker: cer $ +;; $fiHeader: frames.lisp,v 1.34 92/07/27 11:02:21 cer Exp Locker: cer $ (in-package :clim-internals) @@ -41,6 +41,12 @@ (current-layout :initarg :default-layout :initform nil :reader frame-current-layout) (geometry :initform nil :initarg :geometry :reader frame-geometry) + (user-specified-position-p :initform :unspecified + :initarg :user-specified-position-p + :reader frame-user-specified-position-p) + (user-specified-size-p :initform :unspecified + :initarg :user-specified-size-p + :reader frame-user-specified-size-p) (icon :initform nil :initarg :icon :reader frame-icon) (shell :accessor frame-shell) (pointer-documentation-p :initarg :pointer-documentation @@ -494,18 +500,19 @@ (*application-frame* frame)) (when panes (clear-space-requirement-caches-in-tree panes) - (multiple-value-bind (graft-width graft-height) - (bounding-rectangle-size (graft frame)) - (cond ((and width height) - (minf width graft-width) - (minf height graft-height)) - (t - (let ((sr (compose-space panes))) - (setq width (space-requirement-width sr) - height (space-requirement-height sr)) - ;;--- This formula looks dubious --SWM - (minf width (* 0.9 graft-width)) - (minf height (* 0.9 graft-height)))))) + (unless (and width height) + (let ((sr (compose-space panes))) + (unless width + (setq width (space-requirement-width sr))) + (unless height + (setq height (space-requirement-height sr))) + ;;--- This looks dubious --SWM + (multiple-value-bind (gw gh) + (bounding-rectangle-size (graft frame)) + (unless width + (minf width (* 0.9 gw))) + (unless height + (minf height (* 0.9 gh)))))) ;;--- Don't bother with this if the size didn't change? (let ((top-sheet (or (frame-top-level-sheet frame) panes))) (if (and (sheet-enabled-p top-sheet) @@ -552,11 +559,23 @@ enable pretty-name left top right bottom width height save-under + (user-specified-position-p :unspecified) + (user-specified-size-p :unspecified) &allow-other-keys) (declare (dynamic-extent options)) (check-type pretty-name (or null string)) (when (null frame-class) (setq frame-class frame-name)) + (when (eq user-specified-position-p :unspecified) + (if (or (and (getf (getf options :geometry) :left) + (getf (getf options :geometry) :top)) + (and left top)) + (setf user-specified-position-p t))) + (when (eq user-specified-size-p :unspecified) + (if (or (and (getf (getf options :geometry) :width) + (getf (getf options :geometry) :height)) + (and width height)) + (setf user-specified-size-p t))) (when (or left top right bottom width height) (when (getf options :geometry) (error "Cannot specify ~S and ~S, S, ~S, ~S, ~S, or ~S at the same time" @@ -584,19 +603,33 @@ (and height `(:height ,height))))) (with-keywords-removed (options options '(:frame-class :pretty-name :enable :save-under - :left :top :right :bottom :width :height)) - (let ((frame (apply #'make-instance - frame-class - :name frame-name - ;;--- Perhaps this should be a default-initarg? - :pretty-name (or pretty-name - (title-capitalize (string frame-name))) - :properties `(:save-under ,save-under) - options))) - (when enable - (enable-frame frame)) - frame))) + :left :top :right :bottom :width :height + :user-specified-position-p + :user-specified-size-p)) + (let ((frame (apply #'make-instance + frame-class + :name frame-name + ;;--- Perhaps this should be a default-initarg? + :pretty-name (or pretty-name + (title-capitalize (string frame-name))) + :properties `(:save-under ,save-under) + :user-specified-size-p user-specified-size-p + :user-specified-position-p user-specified-position-p + options))) + (when enable + (enable-frame frame)) + frame))) + +<<<<<<< frames.lisp +(defun title-capitalize (string) + (let ((new-string (substitute #\Space #\- string))) + (when (eq new-string string) + (setq new-string (copy-seq new-string))) + (nstring-capitalize new-string))) + +======= +>>>>>>> 1.34 (defmethod enable-frame ((frame standard-application-frame)) (unless (frame-manager frame) (error "Cannot enable a disowned frame ~S" frame)) @@ -615,9 +648,7 @@ frame (ecase old (:disowned - (if (and width height) - (values width height) - (values))) + (values width height)) (:disabled (bounding-rectangle-size (frame-top-level-sheet frame))))) diff --git a/clim/graphics-recording.lisp b/clim/graphics-recording.lisp index 6cad5cf7..3fa18959 100644 --- a/clim/graphics-recording.lisp +++ b/clim/graphics-recording.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: graphics-recording.lisp,v 1.9 92/07/01 15:46:28 cer Exp $ +;; $fiHeader: graphics-recording.lisp,v 1.10 92/07/08 16:30:28 cer Exp Locker: cer $ (in-package :clim-internals) @@ -47,7 +47,8 @@ (slot-descs (mapcar #'(lambda (x) (list x :initarg (intern (symbol-name x) *keyword-package*))) - slots))) + slots)) + (points (gensym))) `(progn (defclass ,class ,superclasses ,slot-descs) (define-constructor-using-prototype-instance @@ -110,7 +111,9 @@ ;; Adjust the stored coordinates by the current cursor position ,@(mapcar #'(lambda (p) `(with-slots (,p) record - (setf ,p (adjust-position-sequence ,p abs-x abs-y)))) + (let ((,points ,p)) + (setf ,p + (adjust-position-sequence ,points abs-x abs-y t))))) position-sequences-to-transform) ,@(when positions-to-transform `((with-slots ,positions-to-transform record @@ -422,19 +425,21 @@ (+ maxx rthickness) (+ maxy rthickness))))) -(defun adjust-position-sequence (position-seq dx dy) +(defun adjust-position-sequence (position-seq dx dy &optional copy-p) (if (and (zerop dx) (zerop dy)) - position-seq - (let ((result (make-array (length position-seq))) - (i 0)) - (declare (type simple-vector result)) - (map-position-sequence - #'(lambda (x y) - (setf (svref result i) (- x dx) - (svref result (1+ i)) (- y dy) - i (+ i 2))) - position-seq) - result))) + (if copy-p + (make-array (length position-seq) :initial-contents position-seq) + position-seq) + (let ((result (make-array (length position-seq))) + (i 0)) + (declare (type simple-vector result)) + (map-position-sequence + #'(lambda (x y) + (setf (svref result i) (- x dx) + (svref result (1+ i)) (- y dy) + i (+ i 2))) + position-seq) + result))) (define-graphics-recording draw-ellipse (ink line-style) diff --git a/clim/input-protocol.lisp b/clim/input-protocol.lisp index 0a78bb3d..d66099bc 100644 --- a/clim/input-protocol.lisp +++ b/clim/input-protocol.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: input-protocol.lisp,v 1.19 92/07/24 10:54:32 cer Exp Locker: cer $ +;; $fiHeader: input-protocol.lisp,v 1.20 92/07/27 11:02:33 cer Exp Locker: cer $ (in-package :clim-internals) @@ -204,8 +204,9 @@ (when text-cursor (setf (cursor-focus text-cursor) t)))) -(defmethod queue-event :before ((stream input-protocol-mixin) (event pointer-exit-event)) - ;; what about unhighlighting highlighted presentations? +(defmethod queue-event :before ((stream input-protocol-mixin) + (event pointer-exit-event)) + (when (port stream) (unhighlight-highlighted-presentation stream)) (let ((text-cursor (stream-text-cursor stream))) (when text-cursor (setf (cursor-focus text-cursor) nil)))) diff --git a/clim/menus.lisp b/clim/menus.lisp index d7003352..460186f1 100644 --- a/clim/menus.lisp +++ b/clim/menus.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: menus.lisp,v 1.28 92/07/20 16:00:30 cer Exp $ +;; $fiHeader: menus.lisp,v 1.29 92/07/27 11:02:40 cer Exp Locker: cer $ (in-package :clim-internals) @@ -411,11 +411,10 @@ (when *abort-menus-when-buried* #-Silica (wait-for-window-exposed menu)) (with-mouse-grabbed-in-window (menu) - (loop - (read-gesture :stream menu - :input-wait-test #'input-wait-test - :input-wait-handler #'input-wait-handler) - (beep menu)))) + (loop (read-gesture :stream menu + :input-wait-test #'input-wait-test + :input-wait-handler #'input-wait-handler) + (beep menu)))) (t (values object gesture))))) (unless leave-menu-visible (setf (window-visibility menu) nil)) diff --git a/misc/dev-load-1.lisp b/misc/dev-load-1.lisp index 7b669bbc..0dcf9463 100644 --- a/misc/dev-load-1.lisp +++ b/misc/dev-load-1.lisp @@ -20,9 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: dev-load-1.lisp,v 1.7 92/05/22 19:29:22 cer Exp $ - -(excl::free (excl::malloc 262145)) +;; $fiHeader: dev-load-1.lisp,v 1.8 92/07/01 15:47:56 cer Exp $ ;;;; This should not matter ;;;; (setq *ignore-package-name-case* t) @@ -54,9 +52,6 @@ #+ignore (clim-defsys::load-system sys))) - #+ignore - (clim-defsys:update-system sys) - ;;-- What would be good is to mark the files in the system as having ;;-- been loaded diff --git a/misc/load-xm.lisp b/misc/load-xm.lisp deleted file mode 100644 index 82cf58ad..00000000 --- a/misc/load-xm.lisp +++ /dev/null @@ -1,36 +0,0 @@ -;; -*- mode: common-lisp; package: user -*- -;; -;; -[]- -;; -;; 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: load-xm.lisp,v 1.2 92/02/24 13:09:54 cer Exp $ - -(excl::free (excl::malloc 131072)) - -(setq *ignore-package-name-case* t) -(set-case-mode :case-insensitive-lower) - -(tenuring - (let ((*load-source-file-info* nil) - (*load-xref-info* nil) - (excl:*global-gc-behavior* nil)) - (let ((*enable-package-locked-errors* nil)) - (load "climg.fasl") - (load "climxm.fasl")))) diff --git a/misc/undefinedsymbols b/misc/undefinedsymbols index f51457dd..cd329299 100644 --- a/misc/undefinedsymbols +++ b/misc/undefinedsymbols @@ -163,6 +163,7 @@ _XGetSubImage _XGetWMHints _XGetWindowAttributes _XGetWindowProperty +_XGetWMNormalHints _XGrabButton _XGrabKey _XGrabKeyboard @@ -290,6 +291,7 @@ _XSetWindowBorder _XSetWindowBorderPixmap _XSetWindowBorderWidth _XSetWindowColormap +_XSetWMNormalHints _XStoreColor _XStoreColors _XStoreName diff --git a/silica/framem.lisp b/silica/framem.lisp index d33f2147..7f0f3997 100644 --- a/silica/framem.lisp +++ b/silica/framem.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: framem.lisp,v 1.10 92/07/08 16:29:08 cer Exp $ +;; $fiHeader: framem.lisp,v 1.11 92/07/20 15:59:16 cer Exp Locker: cer $ (in-package :silica) @@ -88,11 +88,13 @@ (when (frame-panes frame) (let* ((top-pane (frame-panes frame)) (sheet (with-look-and-feel-realization (framem frame) - (make-pane 'top-level-sheet - :region (multiple-value-bind (width height) - (bounding-rectangle-size top-pane) - (make-bounding-rectangle 0 0 width height)) - :parent (find-graft :port (port frame)))))) + (make-pane 'top-level-sheet + :user-specified-position-p (clim-internals::frame-user-specified-position-p frame) + :user-specified-size-p (clim-internals::frame-user-specified-size-p frame) + :region (multiple-value-bind (width height) + (bounding-rectangle-size top-pane) + (make-bounding-rectangle 0 0 width height)) + :parent (find-graft :port (port frame)))))) (setf (frame-top-level-sheet frame) sheet (frame-shell frame) (sheet-shell sheet)) (sheet-adopt-child sheet (frame-panes frame))))) diff --git a/silica/layout.lisp b/silica/layout.lisp index 48c15ff7..c157ae4e 100644 --- a/silica/layout.lisp +++ b/silica/layout.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: layout.lisp,v 1.20 92/07/20 15:59:21 cer Exp Locker: cer $ +;; $fiHeader: layout.lisp,v 1.21 92/07/24 10:53:56 cer Exp Locker: cer $ (in-package :silica) @@ -322,16 +322,17 @@ ;;--- CLIM 0.9 has some other methods on top-level sheets -- do we want them? (defclass top-level-sheet - (;;--- Temporary kludge until we get the protocols correct - ;;--- so that ACCEPT works correctly on a raw sheet - clim-internals::window-stream - wrapping-space-mixin - sheet-multiple-child-mixin - mirrored-sheet-mixin - pane) - () - ;;--- More of same... - (:default-initargs :text-cursor nil :text-margin 10)) + (;;--- Temporary kludge until we get the protocols correct + ;;--- so that ACCEPT works correctly on a raw sheet + clim-internals::window-stream + wrapping-space-mixin + sheet-multiple-child-mixin + mirrored-sheet-mixin + pane) + ((user-specified-size-p :initform :unspecified :initarg :user-specified-size-p) + (user-specified-position-p :initform :unspecified :initarg :user-specified-position-p)) + ;;--- More of same... + (:default-initargs :text-cursor nil :text-margin 10)) ;;--- Needed methods include: ;;--- INVOKE-WITH-RECORDING-OPTIONS diff --git a/tk-silica/pkg.lisp b/tk-silica/pkg.lisp index 08f1c358..be843e05 100644 --- a/tk-silica/pkg.lisp +++ b/tk-silica/pkg.lisp @@ -18,10 +18,10 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: pkg.lisp,v 1.5 92/04/21 20:28:29 cer Exp $ +;; $fiHeader: pkg.lisp,v 1.6 92/07/01 15:48:02 cer Exp $ (defpackage tk-silica - (:nicknames xm-silica) + (:nicknames xm-silica xt-silica) (:use clim-lisp clim-utils clim silica tk) (:import-from excl #:if*)) diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index f7678a3f..80e90a45 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-graphics.lisp,v 1.30 92/07/08 16:31:58 cer Exp Locker: cer $ +;; $fiHeader: xt-graphics.lisp,v 1.31 92/07/20 16:01:58 cer Exp Locker: cer $ (in-package :tk-silica) @@ -142,9 +142,6 @@ (loose-gc flipping-gcontext) (loose-gc tile-gcontext)))) -(defmethod medium-finish-output ((port xt-medium)) - nil) - (defparameter *use-color* t) ; For debugging monochrome (defun color-medium-p (medium) (and *use-color* @@ -1217,5 +1214,5 @@ and on color servers, unless using white or black") (x11:xflush (port-display (port medium)))) (defmethod medium-finish-output ((medium xt-medium)) - (x11:xflush (port-display (port medium)))) ;--- is this right? + (x11:xsync (port-display (port medium)))) diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index b6ec318b..a4bd3855 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.37 92/07/24 10:55:08 cer Exp Locker: cer $ +;; $fiHeader: xt-silica.lisp,v 1.38 92/07/27 11:03:50 cer Exp Locker: cer $ (in-package :xm-silica) @@ -1247,3 +1247,37 @@ the geometry of the children. Instead the parent has control. ")) (fix-coordinate y))))) +(defmethod enable-mirror ((port xt-port) (sheet top-level-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)) + (uspp (slot-value sheet 'silica::user-specified-position-p))) + (unless (and (eq ussp :unspecified) + (eq uspp :unspecified)) + (let* ((window (tk::widget-window parent)) + (display (tk::widget-display parent)) + (size-hints (x11::xallocsizehints))) + (tk::with-ref-par ((supplied 0)) + (when (zerop + (x11::xgetwmnormalhints display window size-hints supplied)) + (warn "top-level-sheet had no size hints?!") + (return-from enable-mirror)) + (let ((flags (x11::xsizehints-flags size-hints))) + (if* (and uspp (not (eq uspp :unspecified))) + then (setf flags (logior flags x11::uspositionhint)) + elseif (null uspp) + then (setf flags (logandc2 flags x11::uspositionhint))) + (if* (and ussp (not (eq ussp :unspecified))) + then (setf flags (logior flags x11::ussizehint)) + elseif (null ussp) + then (setf flags (logandc2 flags x11::ussizehint))) + (setf (x11::xsizehints-flags size-hints) flags)) + (x11::xsetwmnormalhints display window size-hints))))) + (popup parent))) + + (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 aa650dc8..32da4951 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.9 92/04/28 09:24:58 cer Exp $ +;; $fiHeader: convenience.lisp,v 1.10 92/06/16 19:10:47 cer Exp $ (in-package :tk) @@ -37,9 +37,9 @@ (defmethod make-widget ((w ,class) &rest args &key (managed t) (name "") parent &allow-other-keys) - (remf :name args) - (remf :parent args) - (remf :managed args) + (remf args :name) + (remf args :parent) + (remf args :managed) (let* ((arglist (make-arglist-for-class (find-class ',class) parent diff --git a/tk/load-ol.lisp b/tk/load-ol.lisp index c976bb4a..e51d2a0e 100644 --- a/tk/load-ol.lisp +++ b/tk/load-ol.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: load-ol.lisp,v 1.11 92/06/02 13:30:35 cer Exp Locker: cer $ +;; $fiHeader: load-ol.lisp,v 1.12 92/06/23 08:19:07 cer Exp $ (in-package :tk) @@ -29,19 +29,18 @@ (defun load-from-ol () (unless (ff:get-entry-point (ff:convert-to-lang "ol_appl_add_item")) - (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" - )) + #+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* @@ -52,18 +51,18 @@ (x11::symbols-from-file "misc/undefinedsymbols.xt" "misc/undefinedsymbols.olit") - '("__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 '("__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*))) diff --git a/tk/load-xm.lisp b/tk/load-xm.lisp index aa6bc8b0..8574d831 100644 --- a/tk/load-xm.lisp +++ b/tk/load-xm.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: load-xm.lisp,v 1.15 92/07/01 15:44:31 cer Exp Locker: cer $ +;; $fiHeader: load-xm.lisp,v 1.16 92/07/06 18:51:19 cer Exp $ (in-package :tk) @@ -30,18 +30,17 @@ (defun load-from-xm () (unless (ff:get-entry-point (ff:convert-to-lang "XmCreateMyDrawingArea")) - (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" - )) + #+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* @@ -52,20 +51,20 @@ (x11::symbols-from-file "misc/undefinedsymbols.xt" "misc/undefinedsymbols.motif") - '("__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" - ) - (list sys::*libxm-pathname* - sys::*libxt-pathname* - sys::*libx11-pathname*))) + #+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*))) (load-from-xm) diff --git a/tk/load-xt.lisp b/tk/load-xt.lisp index 389c6785..b1c9a225 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.1 92/03/30 17:58:37 cer Exp $ +;; $fiHeader: load-xt.lisp,v 1.2 92/06/02 13:30:38 cer Exp $ (in-package :tk) @@ -35,11 +35,12 @@ (x11::load-undefined-symbols-from-library "stub-xt.o" (x11::symbols-from-file "misc/undefinedsymbols.xt") - '("__unpack_quadruple" - "__prod_b10000" - "__carry_out_b10000" - "__prod_65536_b10000") - (list *libxt-pathname* x11::*libx11-pathname*))) + #+ignore '("__unpack_quadruple" + "__prod_b10000" + "__carry_out_b10000" + "__prod_65536_b10000") + #-ignore nil + (list *libxt-pathname* x11::*libx11-pathname*))) (load-from-xt) diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp index 58a9932a..70046603 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.21 92/06/23 08:19:08 cer Exp $ +;; $fiHeader: make-classes.lisp,v 1.22 92/07/01 15:44:34 cer Exp $ (in-package :tk) @@ -36,30 +36,32 @@ ;; This is only called to fill in the cache, so it can be (real) slow. (defun get-resource-internal (class fn resource-class resource-name) (let ((x (make-array 1 :element-type '(unsigned-byte 32))) - (y (make-array 1 :element-type '(unsigned-byte 32)))) + (y (make-array 1 :element-type '(unsigned-byte 32))) + result) (funcall fn (class-handle class) x y) (let ((resources (aref x 0)) (n (aref y 0))) - (dotimes (i n) - (let* ((res (x-resource-list resources i)) - (original-name (x-resource-name res)) - (name (lispify-resource-name (char*-to-string original-name)))) - (if (equal name resource-name) - (let ((*package* (find-package :tk))) - (return-from get-resource-internal - (make-instance - resource-class - :original-name original-name - :name name - :class (lispify-resource-class - (char*-to-string (x-resource-class res))) - :type (lispify-resource-type - (char*-to-string (x-resource-type res))))))))))) - #+ignore - (error "No resource named ~s found for class ~s" resource-name class) - ;; Error is actually caught in calling functions. - #-ignore - nil) + (setq result + (dotimes (i n) + (let* ((res (x-resource-list resources i)) + (original-name (x-resource-name res)) + (name (lispify-resource-name (char*-to-string original-name)))) + (if (equal name resource-name) + (let ((*package* (find-package :tk))) + (return (make-instance resource-class + :original-name original-name + :name name + :class (lispify-resource-class + (char*-to-string (x-resource-class res))) + :type (lispify-resource-type + (char*-to-string (x-resource-type res)))))))))) + (xt_free resources)) + #+ignore + (unless result + ;; Error is actually caught in calling functions. + (error "No resource named ~s found for class ~s" resource-name class)) + result)) + (defmethod find-class-resource ((class xt-class) resource-name) (declare (optimize (speed 3) (safety 0))) diff --git a/tk/make-widget.lisp b/tk/make-widget.lisp index 26a981d9..3246131b 100644 --- a/tk/make-widget.lisp +++ b/tk/make-widget.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: make-widget.lisp,v 1.4 92/02/24 13:03:30 cer Exp Locker: cer $ +;; $fiHeader: make-widget.lisp,v 1.5 92/04/03 12:04:04 cer Exp $ (in-package :tk) @@ -29,9 +29,9 @@ ) (defmethod make-widget ((w core) &rest args &key parent (managed t) (name "") &allow-other-keys) - (remf :managed args) - (remf :name args) - (remf :parent args) + (remf args :managed) + (remf args :name) + (remf args :parent) (let ((class (class-of w))) (if managed (apply #'create-managed-widget name class parent args) @@ -42,8 +42,8 @@ (defmethod make-widget ((w top-level-shell) &rest args &key parent (name "") &allow-other-keys) - (remf :parent args) - (remf :name args) + (remf args :parent) + (remf args :name) (apply #'create-popup-shell name (class-of w) parent args)) diff --git a/tk/ol-init.lisp b/tk/ol-init.lisp index 8084c88d..b6421aa3 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.13 92/05/22 19:26:29 cer Exp $ +;; $fiHeader: ol-init.lisp,v 1.14 92/06/02 13:30:39 cer Exp $ (in-package :tk) @@ -78,9 +78,9 @@ (defmethod make-widget ((w event) &rest args &key parent (managed t) (name "") &allow-other-keys) - (remf :managed args) - (remf :name args) - (remf :parent args) + (remf args :managed) + (remf args :name) + (remf args :parent) (let ((class (class-of w))) (if managed (apply #'create-managed-widget name class parent args) diff --git a/tk/ol-widgets.lisp b/tk/ol-widgets.lisp index a915c356..bad4b698 100644 --- a/tk/ol-widgets.lisp +++ b/tk/ol-widgets.lisp @@ -20,20 +20,20 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-widgets.lisp,v 1.1 92/05/26 09:08:11 cer Exp Locker: cer $ +;; $fiHeader: ol-widgets.lisp,v 1.2 92/06/23 08:19:15 cer Exp $ (in-package :xt) (defmethod make-widget ((w menu-shell) &rest args &key parent (name "") &allow-other-keys) - (remf :parent args) - (remf :name args) + (remf args :parent) + (remf args :name) (apply #'create-popup-shell name (class-of w) parent args)) (defmethod make-widget ((w transient-shell) &rest args &key parent (name "") &allow-other-keys) - (remf :parent args) - (remf :name args) + (remf args :parent) + (remf args :name) (apply #'create-popup-shell name (class-of w) parent args)) diff --git a/tk/pkg.lisp b/tk/pkg.lisp index a73aec7a..8c88ff8b 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.9 92/05/13 17:10:24 cer Exp $ +;; $fiHeader: pkg.lisp,v 1.10 92/06/16 19:10:53 cer Exp $ (defpackage :tk ;;-- No we really need @@ -36,6 +36,7 @@ #:top-level-shell #:popup #:manage-child + #:realize-widget #:card32 #:card29 #:card24 diff --git a/tk/widget.lisp b/tk/widget.lisp index 944891f9..7f07b3d4 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.21 92/06/23 08:19:18 cer Exp Locker: cer $ +;; $fiHeader: widget.lisp,v 1.22 92/06/29 14:04:24 cer Exp $ (in-package :tk) @@ -150,7 +150,7 @@ (register-widget w (progn - (remf :foreign-address args) + (remf args :foreign-address) (setf (foreign-pointer-address w) (apply #'make-widget w args)))))) diff --git a/tk/xm-widgets.lisp b/tk/xm-widgets.lisp index 56146cdf..6f30796e 100644 --- a/tk/xm-widgets.lisp +++ b/tk/xm-widgets.lisp @@ -20,28 +20,28 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-widgets.lisp,v 1.5 92/02/24 13:04:08 cer Exp $ +;; $fiHeader: xm-widgets.lisp,v 1.6 92/04/21 20:27:49 cer Exp $ (in-package :tk) (defmethod make-widget ((w xm-gadget) &rest args &key parent (managed t) (name "") &allow-other-keys) - (remf :managed args) - (remf :name args) - (remf :parent args) + (remf args :managed) + (remf args :name) + (remf args :parent) (let ((class (class-of w))) (if managed (apply #'create-managed-widget name class parent args) (apply #'create-widget name class parent args)))) (defmethod make-widget ((w xm-dialog-shell) &rest args &key parent (name "") &allow-other-keys) - (remf :parent args) - (remf :name args) + (remf args :parent) + (remf args :name) (apply #'create-popup-shell name (class-of w) parent args)) (defmethod make-widget ((w xm-menu-shell) &rest args &key parent (name "") &allow-other-keys) - (remf :parent args) - (remf :name args) + (remf args :parent) + (remf args :name) (apply #'create-popup-shell name (class-of w) parent args)) (tk::add-resource-to-class (find-class 'vendor-shell) diff --git a/xlib/load-xlib.lisp b/xlib/load-xlib.lisp index ce9dfa8d..c563f06a 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.5 92/06/02 13:30:50 cer Exp Locker: cer $ +;; $fiHeader: load-xlib.lisp,v 1.6 92/06/16 15:01:26 cer Exp $ (in-package :x11) @@ -57,9 +57,11 @@ (x11::load-undefined-symbols-from-library "stub-x.o" (x11::symbols-from-file "misc/undefinedsymbols") - '("__unpack_quadruple" - "__prod_b10000" - "__carry_out_b10000" - "__prod_65536_b10000") + ;; 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*)) diff --git a/xlib/xlib-defs.lisp b/xlib/xlib-defs.lisp index c475517d..4cd78713 100644 --- a/xlib/xlib-defs.lisp +++ b/xlib/xlib-defs.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;;; $fiHeader: xlib-defs.lisp,v 1.1 92/03/06 17:06:59 cer Exp $ +;;; $fiHeader: xlib-defs.lisp,v 1.3 92/04/21 20:28:04 cer Exp $ ;; (c) Copyright 1989, 1990, 1991 Sun Microsystems, Inc. Sun design ;; patents pending in the U.S. and foreign countries. OPEN LOOK is a @@ -1474,6 +1474,36 @@ typedef union { Display *display; (def-exported-constant ZoomState 2) ;; #define ZoomState 2 (def-exported-constant InactiveState 4) ;; #define InactiveState 4 +(def-exported-foreign-struct xsizehints + (flags :type long) + (x :type int) ; Obsolete + (y :type int) ; Obsolete + (width :type int) ; Obsolete + (height :type int) ; Obsolete + (min-width :type int) + (min-height :type int) + (max-width :type int) + (max-height :type int) + (width-inc :type int) + (height-inc :type int) + (min-aspect-x :type int) + (min-aspect-y :type int) + (max-aspect-x :type int) + (max-aspect-y :type int) + (base-width :type int) + (base-height :type int) + (win-gravity :type int)) + +(def-exported-constant uspositionhint 1) +(def-exported-constant ussizehint 2) +(def-exported-constant ppositionhint 4) +(def-exported-constant psizehint 8) +(def-exported-constant pminsizehint 16) +(def-exported-constant pmaxsizehint 32) +(def-exported-constant presizeincint 64) +(def-exported-constant paspecthint 128) +(def-exported-constant pbasesizehint 256) +(def-exported-constant pwingravityhint 512) (def-exported-constant xcsuccess 0) ;; #define XCSUCCESS 0 (def-exported-constant xcnomem 1) ;; #define XCNOMEM 1 diff --git a/xlib/xlib-funs.lisp b/xlib/xlib-funs.lisp index 756ee9b1..ca318418 100644 --- a/xlib/xlib-funs.lisp +++ b/xlib/xlib-funs.lisp @@ -45,7 +45,7 @@ ;; OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION ;; WITH THE USE OR PERFORMANCE OF THIS OBJECT CODE. -;;; $fiHeader: xlib-funs.lisp,v 1.5 92/04/21 20:28:07 cer Exp $ +;;; $fiHeader: xlib-funs.lisp,v 1.6 92/05/13 17:10:48 cer Exp $ (in-package :x11) @@ -1957,6 +1957,23 @@ (display (:pointer display)) (window window)) +(def-exported-foreign-function (xallocsizehints + (:name "_XAllocSizeHints") + (:return-type (:pointer xsizehints)))) + +(def-exported-foreign-function (xsetwmnormalhints (:return-type void) + (:name "_XSetWMNormalHints")) + (display (:pointer display)) + (window window) + (sizehints (:pointer xsizehints))) + +(def-exported-foreign-function (xgetwmnormalhints (:return-type int) + (:name "_XGetWMNormalHints")) + (display (:pointer display)) + (window window) + (hints-return (:pointer xsizehints)) + (supplied-return (:pointer long))) + (def-exported-foreign-function (xsavecontext (:return-type fixnum-int) (:name "_XSaveContext")) -- GitLab