diff --git a/Makefile b/Makefile index 20fadb8715e641d8efd5dd4783609f24d0fd21cf..e4e833a624655a378ef8c9836ce78440e7e1e8f9 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -# $fiHeader: Makefile,v 1.17 92/03/10 16:00:50 cer Exp Locker: cer $ +# $fiHeader: Makefile,v 1.18 92/03/24 19:38:26 cer Exp Locker: cer $ # # Makefile for CLIM 2.0 # @@ -15,7 +15,7 @@ CLIM = ./slim CLIM-SMALL = ./slim-small PUBDIRS = sys utils silica clim demo test genera clx -DIRS0 = tk xm-silica misc +DIRS0 = tk tk-silica misc DIRS = $(PUBDIRS) xlib $(DIRS0) CHEAP_CLEAN = $(PUBDIRS) $(DIRS0) @@ -23,14 +23,54 @@ DEVICE = /dev/null RM = /bin/rm CAT = /bin/cat ECHO = /bin/echo -MV = mv-nfs +MV = /usr/fi/mv-nfs TAGS = /usr/fi/lib/emacs/etc/etags TMP = /usr/tmp +SRC_FILES= */*.lisp *.lisp Makefile */Makefile misc/make-stub-file \ + misc/undefinedsymbols misc/undefinedsymbols.olit misc/undefinedsymbols.motif +DEST=/dev/null + +CL_SRC=/vapor/usr/tech/cer/cl/src +OPENWINHOME=/usr/openwin-3.0 + +#MOTIFHOME=/usr/motif +#MOTIFLIB=$(MOTIFHOME)/usr/lib/libXm.a +#XLIBS=$(MOTIFHOME)/usr/lib/libXt.a $(MOTIFHOME)/usr/lib/libX11.a + +MOTIFLIB=/x11/motif-1.1/lib/Xm/libXm.a +XLIB= /x11/R4/src/mit/lib/X/libX_d.a +XTLIB=/x11/R4/src/mit/lib/Xt/libXt_d.a +XLIBS= $(XTLIB) $(XLIB) + +#OLXLIBS=$(XTLIB) $(XLIB) +OLCOPYLIB=/usr/tech/cer/stuff/clim-2.0/tk/lib2/ +OLXLIBS=$(OLCOPYLIB)/libXt.a $(OLCOPYLIB)/libX11.a +#LIBXOL=$(OPENWINHOME)/lib/libXol.a +LIBXOL=$(OLCOPYLIB)/libXol.a + +# This has to be kept consistent with xlib.lisp + +UNDEFS=misc/undefinedsymbols + +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 +FCLIMOBJS= `pwd`/stub-motif.o `pwd`/stub-olit.o `pwd`/stub-x.o `pwd`/stub-xt.o + # # "Compile time objects" -- these go into clim-debug.fasl # -DEBUG-OBJS = xlib/ffi.fasl xlib/xlib-defs.fasl xlib/xlib-funs.fasl xlib/x11-keysyms.fasl xlib/last.fasl +DEBUG-OBJS = xlib/ffi.fasl xlib/xlib-defs.fasl xlib/xlib-funs.fasl xlib/x11-keysyms.fasl xlib/load-xlib.fasl xlib/last.fasl # # "Load time objects" -- these go into clim.fasl @@ -131,7 +171,10 @@ CLIM-STANDALONE-OBJS = clim/gestures.fasl \ XLIB-CLIM-OBJS = xlib/pkg.fasl -XT-TK-OBJS = tk/pkg.fasl \ +# Is this the correct place to put this load-xm?? + +XT-TK-OBJS = xlib/load-xlib.fasl \ + tk/pkg.fasl \ tk/foreign-obj.fasl \ tk/macros.fasl \ tk/xlib.fasl \ @@ -150,6 +193,9 @@ XT-TK-OBJS = tk/pkg.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-init.fasl \ tk/xm-widgets.fasl \ tk/xm-font-list.fasl \ @@ -158,57 +204,55 @@ 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-init.fasl \ tk/ol-callbacks.fasl \ tk/make-widget.fasl -MOTIF-CLIM-OBJS = xm-silica/pkg.fasl \ - xm-silica/xt-silica.fasl \ - xm-silica/xm-silica.fasl \ - xm-silica/xt-graphics.fasl \ - xm-silica/xm-graphics.fasl \ - xm-silica/image.fasl \ - xm-silica/xt-frames.fasl \ - xm-silica/xm-frames.fasl \ - xm-silica/xt-gadgets.fasl \ - xm-silica/xm-gadgets.fasl \ - xm-silica/xm-menus.fasl \ - xm-silica/xt-pixmaps.fasl \ - xm-silica/xm-cursor.fasl - - -OPENLOOK-CLIM-OBJS = xm-silica/pkg.fasl \ - xm-silica/xt-silica.fasl \ - xm-silica/ol-silica.fasl \ - xm-silica/xt-graphics.fasl \ - xm-silica/ol-graphics.fasl \ - xm-silica/image.fasl \ - xm-silica/xt-frames.fasl \ - xm-silica/ol-frames.fasl \ - xm-silica/xt-gadgets.fasl \ - xm-silica/ol-gadgets.fasl \ - xm-silica/xt-pixmaps.fasl +MOTIF-CLIM-OBJS = tk-silica/pkg.fasl \ + tk-silica/xt-silica.fasl \ + tk-silica/xm-silica.fasl \ + tk-silica/xt-graphics.fasl \ + tk-silica/xm-graphics.fasl \ + tk-silica/image.fasl \ + tk-silica/xt-frames.fasl \ + tk-silica/xm-frames.fasl \ + tk-silica/xt-gadgets.fasl \ + tk-silica/xm-gadgets.fasl \ + tk-silica/xm-menus.fasl \ + tk-silica/xt-pixmaps.fasl \ + tk-silica/xm-cursor.fasl + + +OPENLOOK-CLIM-OBJS = tk-silica/pkg.fasl \ + tk-silica/xt-silica.fasl \ + tk-silica/ol-silica.fasl \ + tk-silica/xt-graphics.fasl \ + tk-silica/ol-graphics.fasl \ + tk-silica/image.fasl \ + tk-silica/xt-frames.fasl \ + tk-silica/ol-frames.fasl \ + tk-silica/xt-gadgets.fasl \ + tk-silica/ol-gadgets.fasl \ + tk-silica/xt-pixmaps.fasl 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) +OPENLOOK-OBJS = $(OL-CLIM-OBJS) $(OPENLOOK-CLIM-OBJS) default: all-xm all-xm: compile-xm cat-xm clim-xm all-ol: compile-ol cat-ol clim-ol -# Compilation - -compile-xm: FORCE +compile-xm: $(CLIMOBJS) FORCE $(ECHO) " \ - (setq *ignore-package-name-case* t) \ - (set-case-mode :case-insensitive-lower) \ (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ (load \"misc/compile-xm.lisp\")" | $(CL) $(CLOPTS) -batch -compile-ol: FORCE +compile-ol: $(CLIMOBJS) FORCE $(ECHO) " \ (setq *ignore-package-name-case* t) \ (set-case-mode :case-insensitive-lower) \ @@ -252,8 +296,6 @@ clim-debug.fasl: $(DEBUG-OBJS) clim-xm: FORCE -$(RM) $(CLIM) $(ECHO) " \ - (setq *ignore-package-name-case* t) \ - (set-case-mode :case-insensitive-lower) \ (load \"misc/dev-load-xm.lisp\") \ (load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch $(MV) $(TMP)/clim.temp_`whoami` $(CLIM) @@ -275,8 +317,6 @@ clim-ol: FORCE clim-small: FORCE $(ECHO) " \ - (setq *ignore-package-name-case* t) \ - (set-case-mode :case-insensitive-lower) \ (load \"misc/load-xm.lisp\") \ (load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch $(MV) $(TMP)/clim.temp_`whoami` $(CLIM-SMALL) @@ -287,7 +327,7 @@ clim-small: FORCE # Misc clean: - find $(DIRS) -name "*.fasl" -print | xargs rm -f ; rm -f clim.fasl + find $(DIRS) -name "*.fasl" -print | xargs rm -f ; rm -f clim.fasl clim-debug.fasl cheapclean: find $(CHEAP_CLEAN) -name "*.fasl" -print | xargs rm -f @@ -300,69 +340,64 @@ swm-tape: tar cf $(DEVICE) `find $(PUBDIRS) '(' -name "*.cl" -o -name "*.lisp" ')' -print` dist: - tar -cf - \ - */*.lisp *.lisp Makefile */Makefile misc/make-stub-file \ - misc/undefinedsymbols misc/undefinedsymbols.olit misc/undefinedsymbols.motif \ - | compress > Dist/src.tar.Z + tar -cf - $(SRC_FILES) | compress > Dist/src.tar.Z rcscheck: rcscheck $(DIRS) | grep -v .fasl -# For the day the make dist happens. -echo_src_files: - @find . '(' -name '*.cl' -o -name '*.lisp' ')' -print - FORCE: -################## Lower level Makefile stuff +################## Make-dist stuff -CL_SRC=/vapor/usr/tech/cer/cl/src -OPENWINHOME=/usr/openwin-3.0 +makeclimfasls : makeclimxmfasls makeclimolfasls +makeclimxmfasls : compile-xm cat-xm +makeclimolfasls : compile-ol cat-ol -#MOTIFHOME=/usr/motif -#MOTIFLIB=$(MOTIFHOME)/usr/lib/libXm.a -#XLIBS=$(MOTIFHOME)/usr/lib/libXt.a $(MOTIFHOME)/usr/lib/libX11.a -#MOTIFLIB=/x11/motif-1.1/lib/Xm/libXm.a -#XLIBS=/x11/R4/src/mit/lib/Xt/libXt_d.a /x11/R4/src/mit/lib/X/libX_d.a +install_clim : + cp $(CLIMOBJS) $(CLIMFASLS) $(DEST) -XLIBHOME=/misc -MOTIFLIB=$(XLIBHOME)/libXm_d.a -XLIBS=$(XLIBHOME)/libXt_d.a $(XLIBHOME)/libX_d.a +# Link in the libraries with standard names -#OLXLIBS=$(XLIBS) -OLCOPYLIB=/usr/tech/cer/stuff/clim-2.0/tk/lib2/ -OLXLIBS=$(OLCOPYLIB)/libXt.a $(OLCOPYLIB)/libX11.a -#LIBXOL=$(OPENWINHOME)/lib/libXol.a -LIBXOL=$(OLCOPYLIB)/libXol.a +link-motif-libraries : + ln -s $(MOTIFLIB) $(DEST)/libXm.a + ln -s $(XTLIB) $(DEST)/libXt.a + ln -s $(XLIB) $(DEST)/libX11.a + ln -s $(FCLIMOBJS) $(DEST) -# This has to be kept consistent with xlib.lisp +echo_src_files: + @ls $(SRC_FILES) | cat + +makeclimobjs : $(CLIMOBJS) -UNDEFS=misc/undefinedsymbols +################## Lower level Makefile stuff -# This should be the same as load-xm +default : xm-composer -XM_UNDEFS=misc/undefinedsymbols.motif +ol-dcl : stub-x.o stub-xt.o stub-olit.o + cd $(CL_SRC) ; /bin/rm -f ucl ;\ + make ucl_xtras='$(PWD)/stub-x.o $(PWD)/stub-xt.o $(PWD)/stub-olit.o $(LIBXOL) $(OLXLIBS)' dcl -# This should be the same as load-ol +xm-dcl : stub-x.o stub-xt.o stub-motif.o + cd $(CL_SRC) ; /bin/rm -f ucl ;\ + make ucl_xtras='$(PWD)/stub-x.o $(PWD)/stub-xt.o $(PWD)/stub-motif.o $(MOTIFLIB) $(XTLIB) $(XLIB)' dcl -OL_UNDEFS=misc/undefinedsymbols.olit +dcl : + cd $(CL_SRC) ; /bin/rm -f ucl ;\ + make dcl -default : xm-composer -ol-dcl : stub-olit.o - cd $(CL_SRC) ; /bin/rm -f ucl ;\ - make ucl_xtras='$(PWD)/stub-olit.o $(LIBXOL) $(OLXLIBS)' dcl +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 -xm-dcl : stub-motif.o - cd $(CL_SRC) ; /bin/rm -f ucl ;\ - make ucl_xtras='$(PWD)/stub-motif.o $(MOTIFLIB) $(XLIBS)' dcl +stub-olit.c : $(XT_UNDEFS) $(OL_UNDEFS) misc/make-stub-file + misc/make-stub-file "void ___lisp_load_olit_stub ()" $(OL_UNDEFS) > stub-olit.c -stub-motif.c : $(UNDEFS) $(XM_UNDEFS) misc/make-stub-file - misc/make-stub-file "void ___lisp_load_motif_stub ()" $(UNDEFS) $(XM_UNDEFS) > stub-motif.c +stub-x.c : $(UNDEFS) $(OL_UNDEFS) misc/make-stub-file + misc/make-stub-file "void ___lisp_load_x_stub ()" $(UNDEFS) > stub-x.c -stub-olit.c : $(UNDEFS) $(OL_UNDEFS) misc/make-stub-file - misc/make-stub-file "void ___lisp_load_olit_stub ()" $(UNDEFS) $(OL_UNDEFS) > stub-olit.c +stub-xt.c : $(XT_UNDEFS) misc/make-stub-file + misc/make-stub-file "void ___lisp_load_xt_stub ()" $(XT_UNDEFS) > stub-xt.c FRC : diff --git a/clim/graphics-recording.lisp b/clim/graphics-recording.lisp index 3daa0935601221bef09a8eb682cd7cd98afbd6ac..394c322a4bb2f09fe1b773fa096fd9fda0f9d5f5 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.4 92/01/31 14:58:27 cer Exp $ +;; $fiHeader: graphics-recording.lisp,v 1.1 92/02/24 13:17:05 cer Exp Locker: cer $ (in-package :clim-internals) @@ -105,14 +105,15 @@ &optional region (x-offset 0) (y-offset 0)) (declare (ignore region)) (with-slots (,@slots) record - (letf-globally (((medium-transformation stream) +identity-transformation+)) - (with-drawing-options - (stream ,@(mapcan #'(lambda (medium-component) + (with-sheet-medium (medium stream) + (letf-globally (((medium-transformation medium) +identity-transformation+)) + (with-drawing-options + (medium ,@(mapcan #'(lambda (medium-component) (list (intern (symbol-name medium-component) *keyword-package*) medium-component)) medium-components)) - (let (,@(when (and (member 'filled function-args) + (let (,@(when (and (member 'filled function-args) (member 'line-style medium-components)) `((filled (not line-style)))) ,@(mapcar #'(lambda (p) (list p p)) @@ -130,7 +131,6 @@ (push `(+ ,(first p) x-offset) r) (push (second p) r) (push `(+ ,(second p) y-offset) r))) - (with-sheet-medium (medium stream) (,medium-graphics-function* medium ,@function-args))))))) ,@(when highlighting-test diff --git a/clim/input-protocol.lisp b/clim/input-protocol.lisp index f6b1164cb7c8bdae96154fdbb930770cf42356b7..7f213482d365ff3a8adde21880d15da87f0e05b7 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.8 92/03/04 16:21:55 cer Exp $ +;; $fiHeader: input-protocol.lisp,v 1.9 92/03/10 10:12:39 cer Exp Locker: cer $ (in-package :clim-internals) @@ -461,11 +461,11 @@ ;;; stream-read-gesture directly. (defun read-gesture (&rest args &key (stream *standard-input*) &allow-other-keys) (declare (arglist &key (stream *standard-input*) - timeout peek-p input-wait-test input-wait-handler - pointer-button-press-handler)) + timeout peek-p input-wait-test input-wait-handler + pointer-button-press-handler)) (declare (dynamic-extent args)) (with-keywords-removed (keywords args '(:stream)) - (apply #'stream-read-gesture stream keywords))) + (apply #'stream-read-gesture stream keywords))) (defmethod stream-unread-gesture ((stream input-protocol-mixin) gesture) (queue-unget (stream-input-buffer stream) gesture)) diff --git a/silica/db-layout.lisp b/silica/db-layout.lisp index 74135ec9704476088b17624741b1f03457d03efd..5722a5241656acb63f1fd9b8e2b86744a470e3dd 100644 --- a/silica/db-layout.lisp +++ b/silica/db-layout.lisp @@ -22,7 +22,7 @@ ;;; ;;; Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved. ;;; -;; $fiHeader: db-layout.lisp,v 1.9 92/03/04 16:19:28 cer Exp Locker: cer $ +;; $fiHeader: db-layout.lisp,v 1.10 92/03/24 19:36:26 cer Exp Locker: cer $ (in-package :silica) @@ -81,8 +81,9 @@ (defmethod note-space-requirement-changed (parent child) nil) -(defmethod note-sheet-region-changed :after ((pane layout-mixin) &key port) - (note-layout-mixin-region-changed pane :port port)) + +(defmethod note-sheet-region-changed :after ((pane layout-mixin) &key port-did-it) + (note-layout-mixin-region-changed pane :port port-did-it)) (defmethod note-layout-mixin-region-changed ((pane layout-mixin) &key port) (declare (ignore port)) diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp index 8a037c5f9b06cc8ed354cf5a677c4dd13b29455b..0a68bf235ebddeef162b1502992a8cd0582d046e 100644 --- a/silica/db-scroll.lisp +++ b/silica/db-scroll.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-scroll.lisp,v 1.8 92/03/10 15:39:56 cer Exp Locker: cer $ +;; $fiHeader: db-scroll.lisp,v 1.9 92/03/24 19:36:28 cer Exp Locker: cer $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright(c) 1991, 1992 International Lisp Associates. @@ -73,32 +73,41 @@ (update-scrollbar horizontal-scrollbar minx maxx vminx vmaxx))))) + ;;;--- In the case where the viewport is bigger than the window this ;;;code gets things kind a wrong. Checkout the thinkadot puzzl. Its ;;;cos (- (--) (- vminx)) is -ve -(defun update-scrollbar (scrollbar minx maxx vminx vmaxx) +(defun update-scrollbar (scrollbar min max vmin vmax) (declare (optimize (safety 0) (speed 3))) - (let* ((size (truncate (* 100.0 - (the single-float - (if (zerop (- maxx minx)) - 1.0 - (min 1.0 (the single-float - (/ (float (- vmaxx vminx)) - (float (- maxx minx)))))))))) - (pos (min 1.0 - (max 0.0 - (if (zerop (- (- maxx minx) (- vmaxx vminx))) - 0.0 - (the single-float - (/ (float (- vminx minx)) - (float (- (- maxx minx) (- vmaxx vminx))))))))) - (value (min (- 100 size) - (truncate (* 100 pos))))) - ;;--- is this safe - (declare (type fixnum size value) - (type single-float pos)) - (with-slots (current-size current-value) scrollbar + (with-slots (current-size current-value) scrollbar + ;; Kinda bogus benchmark optimization -- if the scrollbar was full size + ;; before, and the viewport is bigger than the extent, don't bother with + ;; the fancy math. + (if (and (eql (the (integer 0 100) current-size) 100) + (> (- vmax vmin) (- max min))) + (return-from update-scrollbar)) + (let* ((size (the fixnum (truncate (* 100.0 + (the single-float + (if (zerop (- max min)) + 1.0 + (min 1.0 (the single-float + (/ (float (- vmax vmin) 0.0s0) + (float (- max min) 0.0s0)))))))))) + (pos (the single-float + (min 1.0 + (the single-float + (max 0.0 + (the single-float + (if (zerop (- (- max min) (- vmax vmin))) + 0.0 + (the single-float + (/ (float (- vmin min) 0.0s0) + (float (- (- max min) (- vmax vmin)) 0.0s0)))))))))) + (value (min (the fixnum (- 100 size)) + (the fixnum (truncate (* 100 pos)))))) + (declare (fixnum size value) + (type single-float pos)) (unless (and current-size current-value (eq current-size size) @@ -175,12 +184,14 @@ #+ignore (let ((width (- nmaxx nminx)) (height (- nmaxy nminy))) - (when (or (> width (bounding-rectangle-width stream)) - (> height (bounding-rectangle-height stream))) - (setf (sheet-region stream) - (make-bounding-rectangle 0 0 - (max (bounding-rectangle-width stream) width) - (max (bounding-rectangle-height stream) height)))))) + (when (or (> width (bounding-rectangle-width stream)) + (> height (bounding-rectangle-height stream))) + (setf (sheet-region stream) + (make-bounding-rectangle 0 0 + (max (bounding-rectangle-width stream) width) + (max (bounding-rectangle-height + stream) height)))))) + (defun scroll-extent (stream &key (x 0) (y 0)) (let ((vp (pane-viewport stream))) @@ -222,19 +233,19 @@ (bounding-rectangle* region) :ink +background-ink+ :filled t) #+ignore - (break "cleared region ~S" region) + (break "cleared region ~s" region) (when (typep stream 'clim-internals::output-recording-mixin) (replay (stream-output-history stream) stream region)) #+ignore (break "done replay"))))) ;; otherwise, just redraw the whole visible viewport - ;; Adjust for the left and top margins by hand so clear-area doesn't erase + ;; adjust for the left and top margins by hand so clear-area doesn't erase ;; the margin components. ((typep stream 'clim-internals::output-recording-mixin) (let ((region (viewport-viewport-region vp))) - ;;---- We should make the sheet-region bigger at this point - ;; Perhaps we do a union of the sheet-region and the viewport + ;;---- we should make the sheet-region bigger at this point + ;; perhaps we do a union of the sheet-region and the viewport (with-sheet-medium (medium vp) (draw-rectangle* medium 0 0 @@ -245,13 +256,13 @@ -;;; Home-grown scrollbars +;;; home-grown scrollbars ;;--- orientation, min-value, max-value, unit-increment, page-increment. (defclass scroll-bar-pane (scrollbar pane - ;;--- Add IMMEDIATE-SHEET-INPUT-MIXIN so that scroll bars + ;;--- add immediate-sheet-input-mixin so that scroll bars ;;--- get handled immediately by the event process? wrapping-space-mixin sheet-permanently-enabled-mixin @@ -266,7 +277,7 @@ (:default-initargs :value 0 :shaft-thickness 10)) -;;--- There should really be a small border around scroll bars so that +;;--- there should really be a small border around scroll bars so that ;;--- they don't butt right up against the viewport's drawing area (defmethod initialize-instance :after ((pane scroll-bar-pane) &key orientation shaft-thickness @@ -351,7 +362,7 @@ (defmethod sheet-region-changed :after ((pane scroll-bar-target-pane) &key) (setf (slot-value pane 'coord-cache) nil)) -#+If-we-had-cheap-xforms... +#+if-we-had-cheap-xforms... (defmethod sheet-region-changed :after ((pane scroll-bar-target-pane) &key) (let ((cursor (sheet-cursor pane))) (ecase cursor @@ -377,7 +388,7 @@ :filled nil) (draw-target pane medium))) -;;; You can pass :filled T to this in order to highlight the target when clicked on... +;;; you can pass :filled t to this in order to highlight the target when clicked on... (defmethod draw-target ((pane scroll-bar-target-pane) medium &key filled (ink +foreground-ink+)) (let ((coord-cache (slot-value pane 'coord-cache))) diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp index cbf2d84cea3d9011dc62c80a4e01969aa93957a0..b0814ff72ddfb710b77a66ed60ae61325d57c8dc 100644 --- a/silica/gadgets.lisp +++ b/silica/gadgets.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: gadgets.lisp,v 1.11 92/03/10 10:11:39 cer Exp Locker: cer $ +;; $fiHeader: gadgets.lisp,v 1.12 92/03/24 19:36:39 cer Exp Locker: cer $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright (c) 1992 by Symbolics, Inc. All rights reserved." @@ -249,8 +249,14 @@ (resize-sheet* child (max width cwidth) (max height cheight)))))) - +(defmethod compose-space ((viewport viewport) &key width height) + (declare (ignore width height)) + (let ((sr (call-next-method))) + (setq sr (silica::copy-space-requirement sr)) + (setf (space-requirement-min-width sr) 0 + (space-requirement-min-height sr) 0) + sr)) (defmethod allocate-space :after ((viewport viewport) width height) (bounding-rectangle-set-size diff --git a/silica/mirror.lisp b/silica/mirror.lisp index 67834d0be9e025dbe9dc2c81a032ddc7500de52c..58331ae22137ba807680466ce26e82ea615b0811 100644 --- a/silica/mirror.lisp +++ b/silica/mirror.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: mirror.lisp,v 1.12 92/03/10 10:11:42 cer Exp Locker: cer $ +;; $fiHeader: mirror.lisp,v 1.13 92/03/24 19:36:47 cer Exp Locker: cer $ (in-package :silica) @@ -181,19 +181,6 @@ (when (sheet-direct-mirror sheet) (disable-mirror (port sheet) sheet))) - -(defgeneric invalidate-cached-transformations (sheet) - (:method (sheet) nil) - (:method :after ((sheet sheet-parent-mixin)) - (mapc #'invalidate-cached-transformations (sheet-children sheet)))) - - -(defgeneric invalidate-cached-regions (sheet) - (:method (sheet) nil) - (:method :after ((sheet sheet-parent-mixin)) - (mapc #'invalidate-cached-regions (sheet-children sheet)))) - - ;;--- What sucks big? (warn "This sucks big") @@ -201,9 +188,9 @@ (when (sheet-direct-mirror sheet) (update-mirror-region (port sheet) sheet))) -(defmethod note-sheet-region-changed :after ((sheet mirrored-sheet-mixin) &key port) +(defmethod note-sheet-region-changed :after ((sheet mirrored-sheet-mixin) &key port-did-it) (when (sheet-direct-mirror sheet) - (unless port + (unless port-did-it (update-mirror-region (port sheet) sheet)))) @@ -211,7 +198,7 @@ ;; invalidate-cached-transformations does it anyway. #+ignore -(defmethod note-sheet-transformation-changed :after ((sheet mirrored-sheet-mixin) &key port) +(defmethod note-sheet-transformation-changed :after ((sheet mirrored-sheet-mixin) &key port-did-it) (when (sheet-direct-mirror sheet) (unless port (update-mirror-region (port sheet) sheet)))) @@ -265,8 +252,8 @@ (sc-y (/ (- mirror-bottom mirror-top) (- bottom top)))) (when (and *check-mirror-transformation* - (or (/= sc-x 1.0) - (/= sc-y 1.0) + (or (> (abs (- sc-x 1.0)) 0.01) + (> (abs (- sc-y 1.0)) 0.01) (not (zerop tr-x)) (not (zerop tr-y)))) (let (#+Allegro (*error-output* excl::*initial-terminal-io*)) @@ -346,9 +333,9 @@ (when (or transformation-changed-p region-changed-p) (update-mirror-transformation port sheet)) (when region-changed-p - (note-sheet-region-changed sheet :port t)) + (note-sheet-region-changed sheet :port-did-it t)) (when transformation-changed-p - (note-sheet-transformation-changed sheet :port t))))))) + (note-sheet-transformation-changed sheet :port-did-it t))))))) (defmethod handle-event ((sheet mirrored-sheet-mixin) (event window-configuration-event)) diff --git a/silica/sheet.lisp b/silica/sheet.lisp index a9f8e62a6cf484413017328b8ecbe26db9da932b..8db70041dcd82723350e926bfe031221e3ab8421 100644 --- a/silica/sheet.lisp +++ b/silica/sheet.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: sheet.lisp,v 1.7 92/03/04 16:19:55 cer Exp Locker: cer $ +;; $fiHeader: sheet.lisp,v 1.8 92/03/24 19:36:50 cer Exp Locker: cer $ (in-package :silica) @@ -208,7 +208,13 @@ (defclass sheet-transformation-mixin () ((transformation :initarg :transformation :initform +identity-transformation+ - :accessor sheet-transformation))) + :accessor sheet-transformation) + (cached-device-transformation :initform nil + :accessor sheet-cached-device-transformation) + ;; This next is here for lack of a better place, and because the accessor + ;; sheet-device-region can only work on a sheet that is of this class. + (cached-device-region :initform nil + :accessor sheet-cached-device-region))) (defclass sheet-translation-mixin (sheet-transformation-mixin) ()) @@ -235,38 +241,46 @@ (defgeneric note-sheet-disabled (sheet) (:method (sheet) nil)) - -(defmethod (setf sheet-region) :after (nv sheet) - (note-sheet-region-changed sheet)) - -(defgeneric note-sheet-region-changed (sheet &key port) - (:method (sheet &key port) (declare (ignore port)) nil)) - -(defmethod (setf sheet-transformation) :after (nv sheet) - (note-sheet-transformation-changed sheet)) - -(defgeneric note-sheet-transformation-changed (sheet &key port) - (:method (sheet &key port) (declare (ignore port)) nil)) - - (defgeneric sheet-engrafted-p (sheet) (:method ((sheet sheet)) (let ((parent (sheet-parent sheet))) (or (graftp parent) (sheet-engrafted-p parent))))) - ;;--- -(warn "Is this right?") -(defmethod note-sheet-region-changed :after (sheet &key port) - (unless port - (invalidate-cached-regions sheet))) +(defmethod (setf sheet-region) :after (nv sheet) + (note-sheet-region-changed sheet)) + +(defgeneric note-sheet-region-changed (sheet &key port-did-it) + (:method (sheet &key port-did-it) (declare (ignore port-did-it)) nil)) -(defmethod note-sheet-transformation-changed :after (sheet &key port) - (unless port - (invalidate-cached-transformations sheet))) +(defmethod (setf sheet-transformation) :after (nv sheet) + (note-sheet-transformation-changed sheet)) +(defgeneric note-sheet-transformation-changed (sheet &key port-did-it) + (:method (sheet &key port-did-it) (declare (ignore port-did-it)) nil)) + + +(defgeneric invalidate-cached-transformations (sheet) + (:method ((sheet t)) nil) + (:method :after ((sheet sheet-parent-mixin)) + (mapc #'invalidate-cached-transformations (sheet-children sheet)))) + +(defgeneric invalidate-cached-regions (sheet) + (:method ((sheet t)) nil) + (:method :after ((sheet sheet-parent-mixin)) + (mapc #'invalidate-cached-regions (sheet-children sheet)))) + +(defmethod note-sheet-region-changed :before (sheet &key port-did-it) + (declare (ignore port-did-it)) + (invalidate-cached-regions sheet)) + +;;-- Check to see if the call to invalidate-cached-regions is really necessary. +(defmethod note-sheet-transformation-changed :before (sheet &key port-did-it) + (declare (ignore port-did-it)) + (invalidate-cached-transformations sheet) + (invalidate-cached-regions sheet)) (defgeneric update-native-transformation (port sheet)) diff --git a/sys/defsystem.lisp b/sys/defsystem.lisp index 5831312adb9e1688ee39f7d101ca75775e91113c..1e275591d507044952e134c61b82c92fce6f7a8f 100644 --- a/sys/defsystem.lisp +++ b/sys/defsystem.lisp @@ -27,7 +27,7 @@ ;;; ;;;----------------------------------------------------------- -;; $fiHeader: defsystem.lisp,v 1.6 91/03/26 12:59:59 cer Exp $ +;; $fiHeader: defsystem.lisp,v 1.6 92/03/04 16:22:31 cer Exp Locker: cer $ ;; Add a feature for ANSI-adhering Lisps. So far, only Apple's ;; version 2.0 tries to do adhere to the ANSI spec instead of CLtL rev 1. @@ -1080,7 +1080,8 @@ pathname fields are evaluated." *compiled-modules* *tracep*))) #-(and ANSI-90 (not Allegro) (not Cloe)) -(defun translate-logical-pathname (path) path) +(#+Allegro excl::without-package-locks #-Allegro progn + (defun translate-logical-pathname (path) path)) ;; Evaluate the BODY with the reader context and default pathname set up as ;; defined by the module. diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp index db3f7877bd0706569be33dfeed08ee009f3a24fa..9a45ac172cf4e8338429486d47cc08441d6bb21c 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.8 92/03/10 10:13:03 cer Exp Locker: cer $ +;; $fiHeader: sysdcl.lisp,v 1.9 92/03/24 19:37:59 cer Exp Locker: cer $ (in-package #-ANSI-90 "USER" #+ANSI-90 :cl-user) @@ -417,10 +417,11 @@ #+++ignore ("ffi" :eval-after (mapc #'load '("xlib/xlib.lisp" "xlib/x11-keysyms.lisp" "xlib/last.lisp"))) ("ffi") - ("xlib-defs" #|:load-before-compile ("ffi") |#) ; Takes forever to compile... + ("xlib-defs" #|:load-before-compile ("ffi") |#) ; Takes forever to ; compile... + ("load-xlib") ("xlib-funs" :load-before-compile ("ffi")) ("x11-keysyms" :load-before-compile ("ffi")) - ("last" :load-before-compile ("xlib-funs"))) + ("last" :load-before-compile ("load-xlib" "xlib-funs"))) #+(and Silica Allegro) @@ -433,7 +434,6 @@ ("pkg") ("foreign-obj") ("macros") - ;; Xlib stuff ("xlib") ("font") @@ -441,6 +441,7 @@ ("graphics") ;; Toolkit stuff + ;;; ("load-xt") ("xtk") ("meta-tk") ("make-classes") @@ -460,6 +461,10 @@ :load-before-compile (xt-tk)) ;; Motif specific stuff ("xm-classes") + ("load-xm") + ;;--- This is really in tk but because of the loading + ("xt-funs") + ("xm-funs") ("xm-init") ("xm-widgets") ("xm-font-list") @@ -478,6 +483,8 @@ :load-before-compile (xt-tk)) ;; OpenLook specific stuff ("ol-classes") + ("load-ol") + ("xt-funs") ("ol-init") ("ol-callbacks") #+ignore("ol-examples") @@ -485,8 +492,8 @@ #+(and Silica Allegro) (defsys:defsystem motif-clim - (:default-pathname (frob-pathname "xm-silica") - :default-binary-pathname (frob-pathname "xm-silica") + (:default-pathname (frob-pathname "tk-silica") + :default-binary-pathname (frob-pathname "tk-silica") :needed-systems (clim-standalone xm-tk) :load-before-compile (clim-standalone xm-tk)) ("pkg") @@ -505,8 +512,8 @@ #+(and Silica Allegro) (defsys:defsystem openlook-clim - (:default-pathname (frob-pathname "xm-silica") - :default-binary-pathname (frob-pathname "xm-silica") + (:default-pathname (frob-pathname "tk-silica") + :default-binary-pathname (frob-pathname "tk-silica") :needed-systems (clim-standalone ol-tk) :load-before-compile (clim-standalone ol-tk)) ("pkg") diff --git a/test/test.lisp b/test/test.lisp index 811ad02e8a0aabce28fa3a76a9213d20ee591a0b..fb6965945b268f32967d956b8186cec9723782bf 100644 --- a/test/test.lisp +++ b/test/test.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: test.lisp,v 1.15 92/03/09 17:41:57 cer Exp Locker: cer $ +;; $fiHeader: test.lisp,v 1.16 92/03/24 19:38:10 cer Exp Locker: cer $ (in-package :clim-user) @@ -361,7 +361,22 @@ :prompt "Select an insect")) (describe bug)) - +(define-application-frame tf100 + () () + (:command-table test-frame) + (:pane + (vertically () + #+ignore + (scrolling () + (realize-pane 'text-editor + :value "lucid sucks" + :ncolumns 30 + :nlines 10)) + (scrolling () + (realize-pane 'text-editor + :value "harlqn sucks more" + :ncolumns 30 + :nlines 10))))) (define-application-frame tf99 () () (:command-table test-frame) diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index ddcca434c18d7738b3c4e067fc60fdd410ff4704..c10e2336864eb0c40c0bd6c71d38cd2a93a0327e 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-gadgets.lisp,v 1.16 92/03/10 10:12:02 cer Exp Locker: cer $ +;; $fiHeader: xm-gadgets.lisp,v 1.17 92/03/24 19:37:09 cer Exp Locker: cer $ (in-package :xm-silica) @@ -367,6 +367,7 @@ (nlines silica::gadget-lines)) sheet (values 'tk::xm-text (append + (list :edit-mode :multi-line) (and ncolumns (list :columns ncolumns)) (and nlines (list :rows nlines)) (and value `(:value ,value)))))) diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index 987d4eeee3672c9e154b1a2dfaa0b25631d6eb78..a1bfaa235fd6ae16462cf2d9d0fa789a4f9e2ff0 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -20,7 +20,7 @@ U;; -*- mode: common-lisp; package: xm-silica -*- ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-graphics.lisp,v 1.12 92/03/09 17:41:28 cer Exp Locker: cer $ +;; $fiHeader: xt-graphics.lisp,v 1.13 92/03/24 19:37:15 cer Exp Locker: cer $ (in-package :xm-silica) @@ -303,8 +303,6 @@ U;; -*- mode: common-lisp; package: xm-silica -*- (defmethod adjust-ink ((medium xt-medium) gc ink line-style x-origin y-origin) (declare (ignore ink)) - ;;-- This should just call the equivalent of xsetlineattributes to bash - ;; everything in one go (let* ((dashes (line-style-dashes line-style)) (gc-line-style (etypecase dashes @@ -360,12 +358,9 @@ U;; -*- mode: common-lisp; package: xm-silica -*- (defmethod decode-ink :around ((ink t) (medium xt-medium)) (let ((gc (call-next-method))) - #+ignore - (setf (tk::gcontext-clip-mask gc) - (compute-gcontext-clip-mask medium)) gc)) -l(defmethod xt-decode-pattern ((pattern pattern) medium &optional width height tiled-p) +(defmethod xt-decode-pattern ((pattern pattern) medium &optional width height tiled-p) (let* ((ink-table (slot-value medium 'ink-table)) (drawable (or (slot-value medium 'drawable) (tk::display-root-window @@ -409,14 +404,6 @@ l(defmethod xt-decode-pattern ((pattern pattern) medium &optional width height t (tk::gcontext-fill-style gc) :tiled) gc))))))) -(defmethod compute-gcontext-clip-mask (medium) - (with-bounding-rectangle* (minx miny maxx maxy) - (sheet-device-region (medium-sheet medium)) - (list (truncate minx) - (truncate miny) - (truncate maxx) - (truncate maxy)))) - (defmethod port-draw-point* ((port xt-port) sheet medium x y) (let ((transform (sheet-device-transformation sheet))) diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index 00789c8bd71c0fec279d5f64c162c72a9e6b5460..eb917b65235ba37b2a290881cfe1af6e1f365ec1 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.14 92/03/10 15:40:01 cer Exp Locker: cer $ +;; $fiHeader: xt-silica.lisp,v 1.15 92/03/24 19:37:17 cer Exp Locker: cer $ (in-package :xm-silica) @@ -394,11 +394,10 @@ ;;--- We do not want to specify the x,y if this is a top-level ;;sheet. (unless (typep parent 'tk::shell) - ;;--floor - (setf (getf initargs :x) (floor left) - (getf initargs :y) (floor top))) - (setf (getf initargs :width) (floor (- right left)) - (getf initargs :height) (floor (- bottom top))))) + (setf (getf initargs :x) (integerize-coordinate left) + (getf initargs :y) (integerize-coordinate top))) + (setf (getf initargs :width) (integerize-coordinate (- right left)) + (getf initargs :height) (integerize-coordinate (- bottom top))))) initargs) ;; If we are creating a top level sheet then we have to create a shell for it @@ -503,10 +502,10 @@ target-right target-bottom) (let ((w (- target-right target-left)) (h (- target-bottom target-top))) - (setf target-left (floor target-left) - target-top (floor target-top) - w (floor w) - h (floor h)) + (setf target-left (integerize-coordinate target-left) + target-top (integerize-coordinate target-top) + w (integerize-coordinate w) + h (integerize-coordinate h)) (change-widget-geometry ;;--- For top level sheets the sheet-parent is the graft whose ;; mirror is the application shell diff --git a/tk/callbacks.lisp b/tk/callbacks.lisp index 1806cbbe0480c384b0da1cdf7ad7dff1efaceb33..e90d18d0c05b79eed61d6bc881ed7a3271de7a0e 100644 --- a/tk/callbacks.lisp +++ b/tk/callbacks.lisp @@ -20,16 +20,10 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: callbacks.lisp,v 1.7 92/02/24 13:02:52 cer Exp Locker: cer $ +;; $fiHeader: callbacks.lisp,v 1.8 92/03/09 17:40:32 cer Exp Locker: cer $ (in-package :tk) -(defforeign 'add_callback - :entry-point "_XtAddCallback") - -(defforeign 'xt_has_callbacks - :entry-point "_XtHasCallbacks") - (defun has-callbacks-p (w name) (not (zerop (xt_has_callbacks w name)))) diff --git a/tk/convenience.lisp b/tk/convenience.lisp index cafba0c6cbb775022344e1cfa69555ee04724e52..037c0fddd141069fbb059b1ba818b9e23b5de4c6 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.4 92/02/24 13:02:53 cer Exp Locker: cer $ +;; $fiHeader: convenience.lisp,v 1.5 92/03/09 17:40:34 cer Exp $ (in-package :tk) @@ -72,7 +72,7 @@ (lispify-tk-name entry-point :package nil))))) `(progn (defforeign ',c-function-name :entry-point ,entry-point) - (defclass ,class ,superclasses + (defclass ,class ,superclasses () (:metaclass xt-class)) (defmethod make-widget ((w ,class) &rest args &key (managed t) diff --git a/tk/event.lisp b/tk/event.lisp index b2428d074c30163dc8c23f8c092293672c4a2f9d..6dbb8f82c32751998a5e56bf6c0c3ab37d3e7dad 100644 --- a/tk/event.lisp +++ b/tk/event.lisp @@ -20,16 +20,10 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: event.lisp,v 1.5 92/02/24 13:02:56 cer Exp Locker: cer $ +;; $fiHeader: event.lisp,v 1.6 92/03/09 17:40:35 cer Exp Locker: cer $ (in-package :tk) -(defforeign 'app_pending - :return-type :fixnum - :entry-point "_XtAppPending") - -(defforeign 'app_process_event - :entry-point "_XtAppProcessEvent") (defun simple-event-loop (context) (loop @@ -80,8 +74,7 @@ (defun app-process-event (context mask) (app_process_event context mask)) -(defforeign 'add_event_handler - :entry-point "_XtAddEventHandler") + (defvar *event* nil) @@ -112,9 +105,6 @@ (list (new-callback-id) (cons function args)) (widget-event-handler-data widget))))) -(defforeign 'xt_build_event_mask - :entry-point "_XtBuildEventMask") - (defun build-event-mask (widget) (xt_build_event_mask widget)) diff --git a/tk/font.lisp b/tk/font.lisp index 15f521254e8d014fdd0fa5279c5e66ef90838146..8fe7aa43200acb36d65e46b97636ca7a8363ecc1 100644 --- a/tk/font.lisp +++ b/tk/font.lisp @@ -20,13 +20,12 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: font.lisp,v 1.6 92/02/24 13:02:59 cer Exp Locker: cer $ +;; $fiHeader: font.lisp,v 1.7 92/03/09 17:40:39 cer Exp $ (in-package :tk) -(defclass font () - ((name :initarg :name :reader font-name)) - (:metaclass standard-class-wrapping-foreign-address)) +(defclass font (ff:foreign-pointer) + ((name :initarg :name :reader font-name))) (defmethod print-object ((x font) stream) (print-unreadable-object (x stream :type t :identity t) @@ -88,7 +87,7 @@ pattern max-fonts n)) - (n (sys:memref-int (foreign-pointer-address n) 0 0 :signed-long)) + (n (aref n 0)) (seq (make-sequence result-type n))) (prog1 (dotimes (i n seq) @@ -105,7 +104,7 @@ max-fonts n fonts)) - (n (sys:memref-int (foreign-pointer-address n) 0 0 :signed-long)) + (n (aref n 0)) (fonts (aref fonts 0)) (seq (make-sequence result-type n))) (prog1 diff --git a/tk/foreign.lisp b/tk/foreign.lisp index 7e199715e57749deef0ed0c6d765991b747ff3da..6ab1189ab3cef41fae7fe84f5cb96c078a21ff92 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.5 92/02/24 13:03:01 cer Exp Locker: cer $ +;; $fiHeader: foreign.lisp,v 1.6 92/03/09 17:40:42 cer Exp $ (in-package :tk) @@ -30,9 +30,8 @@ -(defclass application-context () - ((displays :initform nil :accessor application-context-displays)) - (:metaclass ff:standard-class-wrapping-foreign-address)) +(defclass application-context (ff:foreign-pointer) + ((displays :initform nil :accessor application-context-displays))) (defparameter *error-handler-function-address* (register-function 'toolkit-error-handler)) @@ -76,25 +75,16 @@ (error "cannot open the display: ~A" host) d))) -(defclass display () - ((context :initarg :context :reader display-context)) - (:metaclass ff:standard-class-wrapping-foreign-address)) +(defclass display (ff:foreign-pointer) + ((context :initarg :context :reader display-context))) -(defmethod initialize-instance :after ((d display) &rest args &key display) +(defmethod initialize-instance :after ((d display) &rest args + &key display + &allow-other-keys) (push d (application-context-displays (slot-value d 'context))) (setf (foreign-pointer-address d) (or display (apply #'open-display args)))) -(defforeign 'string_create_l_to_r - :entry-point "_XmStringCreateLtoR" - :return-type :integer) - -(defforeign 'string_get_l_to_r - :entry-point "_XmStringGetLtoR" - :return-type :integer) - -(defforeign 'get_pixmap - :entry-point "_XmGetPixmap") diff --git a/tk/gcontext.lisp b/tk/gcontext.lisp index d819f562ae38815c6355854784730c29d1e6e995..6f690ccdc618823bcf59b0d05692bebedcb3a963 100644 --- a/tk/gcontext.lisp +++ b/tk/gcontext.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: gcontext.lisp,v 1.7 92/03/04 16:19:12 cer Exp Locker: cer $ +;; $fiHeader: gcontext.lisp,v 1.8 92/03/09 17:40:43 cer Exp $ (in-package :tk) @@ -77,8 +77,7 @@ (defclass gcontext (display-object) - () - (:metaclass standard-class-wrapping-foreign-address)) + ()) diff --git a/tk/load-ol.lisp b/tk/load-ol.lisp index 801247703c5887355de99d48e45b441d0615922a..1288832d943aab03facd11e69ca6b7c00c64d935 100644 --- a/tk/load-ol.lisp +++ b/tk/load-ol.lisp @@ -20,31 +20,26 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: load-ol.lisp,v 1.5 92/02/16 20:55:00 cer Exp $ +;; $fiHeader: load-ol.lisp,v 1.6 92/02/24 13:03:09 cer Exp Locker: cer $ (in-package :tk) +(defvar *libxol-pathname* "/usr/tech/cer/stuff/clim-2.0/tk/lib2/libXol.a") +(defvar *libxt-pathname* "/x11/R4/src/mit/lib/Xt/libXt_d.a") -(defun load-ol (&optional (what *openlook-classes*)) - (setq what (remove-if #'ff::get-entry-point `(,@what))) - (when what - (mapc #'foreign-functions:remove-entry-point - '("__unpack_quadruple" - "__prod_b10000" - "__unpacked_to_decimal" - "__carry_out_b10000" - "__prod_65536_b10000")) - (load "" - :unreferenced-lib-names - what - :foreign-files - '("/usr/openwin-3.0/lib/libXol.a" - "/usr/motif/usr/lib/libXt.a" - "/usr/motif/usr/lib/libX11.a" - ;; Hopefully - ;;"/usr/openwin-3.0/lib/libXt.a" - ;; "/usr/openwin-3.0/lib/libX11.a" - ) - :print t))) +(defun load-from-ol () + (x11::load-undefined-symbols-from-library + "stub-olit.o" + (x11::symbols-from-file + "misc/undefinedsymbols.xt" + "misc/undefinedsymbols.olit") + '("__unpack_quadruple" + "__unpacked_to_decimal" + "__prod_b10000" + "__carry_out_b10000" + "__prod_65536_b10000") + (list *libxol-pathname* + *libxt-pathname* + x11::*libx11-pathname*))) -(load-ol) +(load-from-ol) diff --git a/tk/load-xm.lisp b/tk/load-xm.lisp index 5083cb466a225d864cbd9634b5b9cf46a239ff7d..da2e9a7e3cb98ff6ecfa6daa5f6c105504c85b6e 100644 --- a/tk/load-xm.lisp +++ b/tk/load-xm.lisp @@ -20,27 +20,30 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: load-xm.lisp,v 1.7 92/02/28 09:17:23 cer Exp Locker: cer $ +;; $fiHeader: load-xm.lisp,v 1.8 92/03/24 19:36:13 cer Exp Locker: cer $ (in-package :tk) ;;;; -(defvar *libxm-pathname* "/usr/motif/usr/lib/libXm.a") -(defvar *libxt-pathname* "/usr/motif/usr/lib/libXt.a") - +(defvar *libx11-pathname* "/x11/R4/src/mit/lib/X/libX_d.a") +(defvar *libxm-pathname* "/x11/motif-1.1/lib/Xm/libXm.a") +(defvar *libxt-pathname* "/x11/R4/src/mit/lib/Xt/libXt_d.a") (defun load-from-xm () (x11::load-undefined-symbols-from-library - (list* "_XCopyGC" (x11::symbols-from-file "misc/undefinedsymbols.motif")) - '("__unpack_quadruple" - "__prod_b10000" - "__carry_out_b10000" - "__prod_65536_b10000") - (list *libxm-pathname* - *libxt-pathname* - x11::*libx11-pathname*))) + "stub-motif.o" + (x11::symbols-from-file + "misc/undefinedsymbols.xt" + "misc/undefinedsymbols.motif") + '("__unpack_quadruple" + "__prod_b10000" + "__carry_out_b10000" + "__prod_65536_b10000") + (list *libxm-pathname* + *libxt-pathname* + x11::*libx11-pathname*))) (load-from-xm) diff --git a/tk/macros.lisp b/tk/macros.lisp index 34fc1d2602bff61e773ed58d32c6c31303289fe5..1548d2c8a629abf471cc80fa57468efd0059d010 100644 --- a/tk/macros.lisp +++ b/tk/macros.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: macros.lisp,v 1.7 92/02/24 13:03:25 cer Exp Locker: cer $ +;; $fiHeader: macros.lisp,v 1.8 92/03/09 17:40:46 cer Exp $ (in-package :tk) @@ -35,13 +35,10 @@ (let ((val (gensym))) `(let ((,val ,value) (,var (or (and *temp-with-ref-par-p* (pop *temp-with-ref-par*)) - (make-foreign-pointer :size 4)))) - (setf (sys:memref-int (foreign-pointer-address ,var) 0 0 ,type) ,val) + (make-array 1 :element-type '(unsigned-byte 32))))) + (declare (type (simple-array (unsigned-byte 32) (1)) ,var)) + (setf (aref ,var 0) ,val) (multiple-value-prog1 (with-ref-par ,more-bindings ,@body) (when *temp-with-ref-par-p* (push ,var *temp-with-ref-par*)))))))) - - - - diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp index eb5cadc17b4e8ac9674408bd2016bbae75eefacd..9ad671143a8a383a7cd42c42295112f8e59b137b 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.9 92/03/06 14:17:26 cer Exp Locker: cer $ +;; $fiHeader: make-classes.lisp,v 1.10 92/03/09 17:40:47 cer Exp $ (in-package :tk) @@ -68,7 +68,7 @@ -(defclass display-object () +(defclass display-object (ff:foreign-pointer) ((display :initarg :display :reader object-display :fixed-index 0))) @@ -126,7 +126,7 @@ (setq direct-resources (nreverse direct-resources)) (dolist (class-ep classes) - (format excl:*initial-terminal-io* "Initializing class ~s~%" class-ep) + (format excl:*initial-terminal-io* ";; Initializing class ~s~%" class-ep) (let ((h (get-foreign-variable-value class-ep))) (initialize-widget-class h) (push (list h @@ -149,9 +149,9 @@ (clos::ensure-class (lispify-class-name (widget-class-name handle)) :direct-superclasses (list (if (zerop (xtk-class-superclass handle)) - 'xt-root-class - (lispify-class-name (widget-class-name - (xtk-class-superclass handle))))) + 'xt-root-class + (lispify-class-name (widget-class-name + (xtk-class-superclass handle))))) :direct-slots nil :metaclass 'xt-class :direct-resources direct-resources diff --git a/tk/meta-tk.lisp b/tk/meta-tk.lisp index 282df2281e37901ef3d28c494ec964dd083285fd..4cd5d7fa5b21d0bfcfc283fb51395d0a154d67b1 100644 --- a/tk/meta-tk.lisp +++ b/tk/meta-tk.lisp @@ -20,13 +20,13 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: meta-tk.lisp,v 1.5 92/02/24 13:03:32 cer Exp Locker: cer $ +;; $fiHeader: meta-tk.lisp,v 1.6 92/03/09 17:40:49 cer Exp $ (in-package :tk) -(defclass xt-class (standard-class-wrapping-foreign-address) +(defclass xt-class (standard-class ff:foreign-pointer) ((entry-point :initarg :entry-point :reader class-entry-point) (resources :initform nil @@ -40,17 +40,7 @@ :reader class-direct-resources) (constraint-resources :initform nil :initarg :direct-constraints - :reader class-direct-constraint-resources)) - ;; Don't think about this too much, you might get hurt... - (:metaclass standard-class-wrapping-foreign-address)) - -;; This is needed because the class itself is a foreign wrapper. -(defmethod shared-initialize :after ((class xt-class) slot-names - &key foreign-address - &allow-other-keys) - (declare (ignore slot-names)) - (when foreign-address - (setf (foreign-pointer-address class) foreign-address))) + :reader class-direct-constraint-resources))) (defmethod class-handle ((class xt-class)) (unless (clos::class-finalized-p class) diff --git a/tk/ol-classes.lisp b/tk/ol-classes.lisp index f3bbf3c5ef540d493f694691786fa0390deaf4f5..eeabe45e1914b4234773a840c958aaceab53eabc 100644 --- a/tk/ol-classes.lisp +++ b/tk/ol-classes.lisp @@ -20,7 +20,10 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-classes.lisp,v 1.2 92/02/24 13:03:35 cer Exp Locker: cer $ +;; $fiHeader: ol-classes.lisp,v 1.3 92/03/24 19:36:15 cer Exp Locker: cer $ + +(provide :climol) +(require :climg) (in-package :tk) diff --git a/tk/pkg.lisp b/tk/pkg.lisp index b28d56a54d97983609b966b7179e02165f732c4b..8d1fd7aa468afde347554d5693b77406968d367e 100644 --- a/tk/pkg.lisp +++ b/tk/pkg.lisp @@ -20,10 +20,12 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: pkg.lisp,v 1.5 92/02/24 13:03:44 cer Exp Locker: cer $ +;; $fiHeader: pkg.lisp,v 1.6 92/03/09 17:40:55 cer Exp Locker: cer $ (defpackage :tk - (:use :common-lisp :ff :x11) + ;;-- No we really need + ;; to use the x11 package? + (:use :common-lisp :ff #+ignore :x11) (:nicknames :xt) (:export #:initialize-motif-toolkit diff --git a/tk/resources.lisp b/tk/resources.lisp index b525054c32e3d3f5698a3fa344820f127358f9cd..cdd90ce777c4a2c875f6287d000774df4fc1793c 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.10 92/03/09 17:40:58 cer Exp Locker: cer $ +;; $fiHeader: resources.lisp,v 1.11 92/03/10 10:11:31 cer Exp Locker: cer $ (in-package :tk) @@ -34,8 +34,6 @@ (elt ',elements value)))) -(defforeign 'set_values - :entry-point "_XtSetValues") (defun set-values (widget &rest values) @@ -86,8 +84,7 @@ (:vertical 1) (:horizontal 2))) -(defforeign 'get_values - :entry-point "_XtGetValues") + (def-c-type (x-arglist :in-foreign-space) 1 :unsigned-long) @@ -517,3 +514,6 @@ :tight :column :none)) + + +(define-enumerated-resource edit-mode (:multi-line :single-line)) diff --git a/tk/widget.lisp b/tk/widget.lisp index 710f508cfc35fad9ce3f659937699860560d65d4..566fe18a169017b80007acd69cf546c796b409e4 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.12 92/03/09 17:41:01 cer Exp Locker: cer $ +;; $fiHeader: widget.lisp,v 1.13 92/03/10 15:39:52 cer Exp Locker: cer $ (in-package :tk) @@ -46,8 +46,7 @@ :display display args)))) -(defforeign 'create_widget :entry-point "_XtCreateWidget") -(defforeign 'create_managed_widget :entry-point "_XtCreateManagedWidget") + (defun create-widget (name widget-class parent &rest args) (apply #'create-widget-1 @@ -70,54 +69,36 @@ arglist (truncate (length arglist) 2)))) -(defforeign 'realize_widget - :entry-point "_XtRealizeWidget") + (defun realize-widget (widget) (realize_widget widget)) -(defforeign 'manage_child - :entry-point "_XtManageChild") + (defun manage-child (child) (manage_child child)) -(defforeign 'xt_is_managed :entry-point "_XtIsManaged") + (defun is-managed-p (widget) (not (zerop (xt_is_managed widget)))) -(defforeign 'unmanage_child - :entry-point "_XtUnmanageChild") - (defun unmanage-child (child) (unmanage_child child)) -(defforeign 'manage_children - :entry-point "_XtManageChildren") - (defun manage-children (children) (manage_children (map '(simple-array (signed-byte 32)) #'ff:foreign-pointer-address children) (length children))) - -(defforeign 'destroy_widget - :entry-point "_XtDestroyWidget") (defun destroy-widget (widget) (destroy_widget widget)) -(defforeign 'create_popup_shell - :entry-point "_XtCreatePopupShell") - -(defforeign '_popup - :entry-point "_XtPopup") -(defforeign '_popdown - :entry-point "_XtPopdown") (defun popup (shell) (_popup shell @@ -141,8 +122,6 @@ (if (typep x 'clos::class) x (find-class x))) -(defforeign 'xt_window :entry-point "_XtWindow") - (defmethod widget-window (widget &optional (errorp t)) (with-slots (window-cache) widget (or window-cache @@ -185,9 +164,6 @@ (setf (foreign-pointer-address w) (apply #'make-widget w args)))))) -(defforeign 'xt_parent - :entry-point "_XtParent") - (defun intern-widget (widget &rest args) (and (not (zerop widget)) (apply @@ -200,8 +176,6 @@ (let ((x (xt_parent widget))) (and (not (zerop x)) (intern-widget x)))) -(defforeign 'xt_query_geometry :entry-point "_XtQueryGeometry") - (def-c-type xt-geometry-mask :unsigned-int) (def-c-type xt-position :short) (def-c-type xt-dimension :unsigned-short) @@ -253,7 +227,6 @@ (logtest r x11:cwheight) (logtest r x11:cwborderwidth))))) -(defforeign 'xt_configure_widget :entry-point "_XtConfigureWidget") ;;--- Should call either XtResizeWidget or XtConfigureWidget diff --git a/tk/xlib.lisp b/tk/xlib.lisp index c0d4c3669102ee7b94bcfe47526d0e1becaa03b6..4fb3e5931d1f30789beb08f6dcd07291b1bdfc54 100644 --- a/tk/xlib.lisp +++ b/tk/xlib.lisp @@ -20,14 +20,13 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xlib.lisp,v 1.11 92/03/09 17:41:03 cer Exp Locker: cer $ +;; $fiHeader: xlib.lisp,v 1.12 92/03/10 15:39:53 cer Exp $ (in-package :tk) ;;; Pathetic clos interface to Xlib -(defclass screen (display-object) () - (:metaclass standard-class-wrapping-foreign-address)) +(defclass screen (display-object) ()) #+obsolete (defun screen-gcontext (screen) @@ -41,13 +40,9 @@ -(defclass drawable (display-object) - () - (:metaclass standard-class-wrapping-foreign-address)) +(defclass drawable (display-object) ()) -(defclass window (drawable) - () - (:metaclass standard-class-wrapping-foreign-address)) +(defclass window (drawable) ()) ;; Ugh. This should be part of a general purpose mechanism (defmethod drawable-depth ((window window)) @@ -94,8 +89,7 @@ (defclass pixmap (drawable) ((width :initarg :width :reader pixmap-width) (height :initarg :height :reader pixmap-height) - (depth :initarg :depth :reader drawable-depth)) - (:metaclass standard-class-wrapping-foreign-address)) + (depth :initarg :depth :reader drawable-depth))) (defmethod initialize-instance :after ((p pixmap) &key foreign-address width height depth drawable) @@ -142,8 +136,7 @@ (x11:xdefaultscreen display)) -(defclass colormap (display-object) () - (:metaclass standard-class-wrapping-foreign-address)) +(defclass colormap (display-object) ()) (defun default-colormap (display &optional (screen 0)) (intern-object-xid @@ -153,8 +146,7 @@ :display display)) -(defclass color () () - (:metaclass standard-class-wrapping-foreign-address)) +(defclass color (ff:foreign-pointer) ()) (defmethod initialize-instance :after ((x color) &key foreign-address red green blue) @@ -235,18 +227,18 @@ (values t (intern-object-xid - (sys:memref-int (foreign-pointer-address root) 0 0 :signed-long) + (aref root 0) 'window :display display) (intern-object-xid - (sys:memref-int (foreign-pointer-address child) 0 0 :signed-long) + (aref child 0) 'window :display display) - (sys:memref-int (foreign-pointer-address root-x) 0 0 :signed-long) - (sys:memref-int (foreign-pointer-address root-y) 0 0 :signed-long) - (sys:memref-int (foreign-pointer-address x) 0 0 :signed-long) - (sys:memref-int (foreign-pointer-address y) 0 0 :signed-long) - (sys:memref-int (foreign-pointer-address mask) 0 0 :signed-long)))))) + (aref root-x 0) + (aref root-y 0) + (aref x 0) + (aref y 0) + (aref mask 0)))))) @@ -337,27 +329,32 @@ (error "cannot encode event-mask ~S" mask)))))) +(warn "remove me") + (defun lookup-string (event) - (with-ref-par - ((keysym 0) - (buffer 0)) - (values - (x11:xlookupstring - event - buffer - 2 - keysym - 0) - (char*-to-string (foreign-pointer-address buffer)) - (sys:memref-int (foreign-pointer-address keysym) 0 0 :signed-long)))) - -(defclass image () + (let ((buffer (string-to-char* (load-time-value (make-string 4 :initial-element #\null))))) + ;;-- Before anyone goes changing this again they need to remember + ;;-- that buffer needs to be zeroed before hand + (with-ref-par + ((keysym 0)) + (values + (x11:xlookupstring + event + buffer + 2 + keysym + 0) + (prog1 + (char*-to-string buffer) + (excl::free buffer)) + (aref keysym 0))))) + +(defclass image (ff:foreign-pointer) ((width :reader image-width :initarg :width) (height :reader image-height :initarg :height) (data :reader image-data :initarg :data) (depth :reader image-depth :initarg :depth) - (realized-displays :initform nil :accessor realized-displays)) - (:metaclass standard-class-wrapping-foreign-address)) + (realized-displays :initform nil :accessor realized-displays))) (defmethod realize-image (image display) diff --git a/tk/xm-classes.lisp b/tk/xm-classes.lisp index 9f7631feb524d3a9cfea65b0e51be5041bbd7833..dc2b2725cc9cf6e5b07413e1f8a46c7279d5aef0 100644 --- a/tk/xm-classes.lisp +++ b/tk/xm-classes.lisp @@ -20,12 +20,15 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-classes.lisp,v 1.1 92/02/16 20:30:58 cer Exp $ - -(in-package :tk) +;; $fiHeader: xm-classes.lisp,v 1.2 92/02/24 13:03:56 cer Exp Locker: cer $ ;;; This has to kept consistent with the Makefile +(provide :climxm) +(require :climg) + +(in-package :tk) + (defparameter *motif-classes* '("_applicationShellWidgetClass" "_compositeWidgetClass" "_constraintWidgetClass" diff --git a/tk/xm-font-list.lisp b/tk/xm-font-list.lisp index 118caa38d16e3d64b78de3967aa4570511ff640a..6624f05219a8696f293a127fb24880859cee314b 100644 --- a/tk/xm-font-list.lisp +++ b/tk/xm-font-list.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-font-list.lisp,v 1.4 92/03/04 16:19:19 cer Exp Locker: cer $ +;; $fiHeader: xm-font-list.lisp,v 1.5 92/03/09 17:41:05 cer Exp $ (in-package :tk) @@ -62,7 +62,7 @@ (let ((context (with-ref-par ((context 0)) (assert (not (zerop (xm_font_list_init_font_context context font-list)))) - (sys:memref-int (foreign-pointer-address context) 0 0 :signed-long))) + (aref context 0))) (res nil)) (with-ref-par ((char-set 0) @@ -74,11 +74,11 @@ char-set font)) (return nil)) - (push (list (let ((x (sys:memref-int (foreign-pointer-address char-set) 0 0 :signed-long))) + (push (list (let ((x (aref char-set 0))) (prog1 (ff:char*-to-string x) (xt_free x))) - (let ((x (sys:memref-int (foreign-pointer-address font) 0 0 :signed-long))) + (let ((x (aref font 0))) (intern-object-address x 'font diff --git a/tk/xtk.lisp b/tk/xtk.lisp index 074c9e53a988a87df1145d7c222caef32c10b4c1..e3f424453614a486399e69df17a99425323b7c5f 100644 --- a/tk/xtk.lisp +++ b/tk/xtk.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xtk.lisp,v 1.5 92/01/31 14:55:23 cer Exp $ +;; $fiHeader: xtk.lisp,v 1.6 92/02/24 13:04:18 cer Exp Locker: cer $ (in-package :tk) @@ -88,8 +88,7 @@ ;; Horrible internal stuff -(defforeign 'quark_to_string - :entry-point "_XrmQuarkToString") + (def-c-type (xt-offset-rec :in-foreign-space) :struct (next * :char) @@ -113,28 +112,3 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defforeign 'get-resource-list-1 :entry-point "_XtGetResourceList") -(defforeign 'get-constraint-resource-list-1 :entry-point "_XtGetConstraintResourceList") - -(defforeign 'initialize-widget-class :entry-point "_XtInitializeWidgetClass") - -(defforeign 'xt_free :entry-point "_XtFree") - -(defforeign 'toolkit-initialize - :entry-point "_XtToolkitInitialize") - -(defforeign 'create_application_context - :entry-point "_XtCreateApplicationContext") - - -(defforeign 'app_set_error_handler - :entry-point "_XtAppSetErrorHandler") - -(defforeign 'app_set_warning_handler - :entry-point "_XtAppSetWarningHandler") - -(defforeign 'open_display - :entry-point "_XtOpenDisplay") - -(defforeign 'app_create_shell - :entry-point "_XtAppCreateShell") diff --git a/utils/excl-verification.lisp b/utils/excl-verification.lisp index 1ff2e04cd506072e85e5500765c5aeef7b66abbf..4fcead835fe764f941adaff437feddf67bbf5ecd 100644 --- a/utils/excl-verification.lisp +++ b/utils/excl-verification.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: excl-verification.lisp,v 1.5 92/03/10 10:11:51 cer Exp Locker: cer $ +;; $fiHeader: excl-verification.lisp,v 1.6 92/03/24 19:36:55 cer Exp Locker: cer $ (in-package :sys) @@ -13,6 +13,7 @@ (require :clx)) (provide :clim) +(provide :climg) #+(not (version>= 4 1)) (let* ((patch-package (find-package :patch)) diff --git a/utils/lisp-utilities.lisp b/utils/lisp-utilities.lisp index 64a27b9227feeda3e67358c819fbef04d6ef6d42..881037c38735e145d2d92bd42d9854f8c5d9b707 100644 --- a/utils/lisp-utilities.lisp +++ b/utils/lisp-utilities.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: lisp-utilities.lisp,v 1.5 92/03/04 16:20:15 cer Exp $ +;; $fiHeader: lisp-utilities.lisp,v 1.6 92/03/10 10:11:52 cer Exp $ (in-package :clim-utils) @@ -38,7 +38,10 @@ (defmacro integerize-float-coordinate (coord) `(the fixnum (values (floor (+ (the float ,coord) .5))))) +#-allegro (defun integerize-coordinate (coord) + (declare (optimize (speed 3) (safety 0)) + (:explain :calls :types)) (etypecase coord (fixnum coord) (single-float @@ -52,6 +55,13 @@ ;; disallow bignums and other types of numbers )) +#+allegro +(defmacro integerize-coordinate (coord) + ;; Round is good enough in Allegro for 90% of the speed, and it's less + ;; filling. + `(the fixnum (round ,coord))) + + (defmacro integerize-coordinates (&body coords) `(progn ,@(mapcar #'(lambda (x) diff --git a/xlib/ffi.lisp b/xlib/ffi.lisp index 5cb7793bbaa89b20fd26e1984e0a589d0af3abd5..83fcaa1d09da1dff0617c214270a4534b8b535e2 100644 --- a/xlib/ffi.lisp +++ b/xlib/ffi.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ffi.lisp,v 1.7 92/03/09 17:41:32 cer Exp Locker: cer $ +;; $fiHeader: ffi.lisp,v 1.8 92/03/24 19:37:20 cer Exp Locker: cer $ (in-package :x11) @@ -66,7 +66,7 @@ (name &key type) slot `(,name ,@(trans-slot-type type))))) (if (notany #'(lambda (s) (member :overlays (cdr s))) slots) - `(ff::def-c-type (,name :in-foreign-space :no-constructor :no-defuns) + `(ff::def-c-type (,name :in-foreign-space :no-defuns) ,@(mapcar #'foo-slot slots)) (destructuring-bind ((first-slot-name . first-options) . other-slots) slots @@ -77,18 +77,13 @@ (eq (getf (cdr slot) :overlays) first-slot-name)) other-slots)) - `(ff::def-c-type (,name :in-foreign-space :no-constructor :no-defuns) :union + `(ff::def-c-type (,name :in-foreign-space :no-defuns) :union ,@(mapcar #'(lambda (slot) (setq slot (copy-list slot)) (remf (cdr slot) :overlays) (foo-slot slot)) slots)) - (error ":overlays used in a way we cannot handle"))))) - (defmacro ,(fintern "~A~A" 'make- name) () - #+ignore - `(excl::malloc ,,(ff::cstruct-property-length (ff::cstruct-prop name))) - #-ignore - `(ff::make-cstruct ',',name)))) + (error ":overlays used in a way we cannot handle"))))))) (defun trans-slot-type (type) @@ -149,7 +144,7 @@ `(progn (eval-when (eval load compile) (export ',name)) - (eval-when (compile eval) + (eval-when (compile eval load) ,(let ((c-name (second (assoc :name options))) (return-type (or (second (assoc :return-type options)) 'integer))) diff --git a/xlib/load-xlib.lisp b/xlib/load-xlib.lisp index 33d2a61e217902b7e63a16c013002c06b636caa4..57171f45b2f69b76dae84225af634023cd6eed4a 100644 --- a/xlib/load-xlib.lisp +++ b/xlib/load-xlib.lisp @@ -20,38 +20,42 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ - +;; $fiHeader: load-xlib.lisp,v 1.1 92/03/24 19:43:50 cer Exp Locker: cer $ (in-package :x11) -(defmacro symbols-from-file (file) - (with-open-file (s file :direction :input) - (do ((r nil) - (l (read-line s nil nil) (read-line s nil nil))) - ((null l) - `(quote ,r)) - (push l r)))) - - -(defun load-undefined-symbols-from-library (what kludges libraries) - (setq what (remove-if #'ff::get-entry-point what)) - (when what - (mapc #'foreign-functions:remove-entry-point kludges) - (load "" - :unreferenced-lib-names what - :foreign-files libraries - :print t))) - -(defvar *libx11-pathname* "/usr/motif/usr/lib/libX11.a") - -(defun load-from-xlib () - (x11::load-undefined-symbols-from-library - (list* "_XCopyGC" (x11::symbols-from-file "misc/undefinedsymbols")) - '("__unpack_quadruple" - "__prod_b10000" - "__carry_out_b10000" - "__prod_65536_b10000") - (list x11::*libx11-pathname*))) +(defmacro symbols-from-file (&rest files) + (let ((r nil)) + (dolist (file files `(quote ,(nreverse r))) + (with-open-file (s file :direction :input) + (do ((l (read-line s nil nil) (read-line s nil nil))) + ((null l)) + (push l r)))))) + + +(defun load-undefined-symbols-from-library (file what kludges libraries) + (let* ((n (length what)) + (names (coerce what 'vector)) + (entry-points (make-array n :element-type '(unsigned-byte 32)))) + (declare (type (simple-array (unsigned-byte 32) (*)))) + (when (> (ff:get-entry-points names entry-points) 0) + (dotimes (i n) + (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 *libx11-pathname* "/x11/R4/src/mit/lib/X/libX_d.a") + +(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") + (list x11::*libx11-pathname*)) -(load-from-xlib) diff --git a/xlib/xlib-funs.lisp b/xlib/xlib-funs.lisp index 0a571a42673490d7509eed3ed76923d9e7550d37..11a7a2610c255e3541b68dcd58c9c9679c6010e5 100644 --- a/xlib/xlib-funs.lisp +++ b/xlib/xlib-funs.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;;; $fiHeader: xlib-funs.lisp,v 1.1 92/03/06 17:07:01 cer Exp Locker: cer $ +;;; $fiHeader: xlib-funs.lisp,v 1.2 92/03/24 19:37:22 cer Exp Locker: cer $ (in-package :x11)