From 4ddfa1acdd7af89f3cc3ed3f98d8d2381cb745cd Mon Sep 17 00:00:00 2001 From: layer <layer> Date: Tue, 4 May 1999 01:21:12 +0000 Subject: [PATCH] 5/3/99--6.0.pre-alpha.13--join from acl50 branch--tag acl50_merge5 --- ChangeLog.n | 129 ++++++ Makefile | 9 +- Makefile.defs | 8 +- Makefile.freebsd | 4 +- Makefile.linux86 | 42 -- Makefile.rs6000 | 4 +- Makefile.sun4-ol | 24 -- Makefile.sun4-svr4-ol | 33 -- Makefile.wnn | 6 +- RELNOTES | 12 +- aclpc/acl-class.lisp | 66 +-- aclpc/acl-dc.lisp | 22 +- aclpc/acl-frames.lisp | 811 +++++++++++++++++++++---------------- aclpc/acl-medium.lisp | 348 ++++++++++------ aclpc/acl-mirror.lisp | 23 +- aclpc/acl-port.lisp | 242 +++++++---- aclpc/acl-prel.lisp | 243 ++++++----- aclpc/acl-widget.lisp | 40 +- aclpc/pkgdcl.lisp | 7 +- aclpc/winwidgh.lisp | 6 +- clim/accept-values.lisp | 71 ++-- clim/frames.lisp | 44 +- clim/interactive-defs.lisp | 5 +- demo/bitmap-editor.lisp | 11 +- instclimol.lisp | 33 -- make-symbolic-links.sh | 50 --- makedist.sh | 23 -- readme.win32 | 76 ---- silica/graphics.lisp | 44 +- sys/odrawpat.lisp | 34 +- test/test-suite.lisp | 14 +- tk-silica/xt-graphics.lisp | 15 +- tk-silica/xt-silica.lisp | 17 +- utils/defun-utilities.lisp | 27 +- utils/designs.lisp | 25 +- utils/packages.lisp | 4 +- 36 files changed, 1445 insertions(+), 1127 deletions(-) delete mode 100644 Makefile.linux86 delete mode 100644 Makefile.sun4-ol delete mode 100644 Makefile.sun4-svr4-ol delete mode 100644 instclimol.lisp delete mode 100644 make-symbolic-links.sh delete mode 100644 makedist.sh delete mode 100644 readme.win32 diff --git a/ChangeLog.n b/ChangeLog.n index 3311569f..c2aeb6cd 100644 --- a/ChangeLog.n +++ b/ChangeLog.n @@ -10,6 +10,13 @@ If there are user-visible changes in this commit, then list the <standard changelog date stamp> * <changes go here...> +******************************************************************************* +2.2.2.6 -- join from acl50 branch + +- changes from 2.2.1.45 to 2.2.1.54 +- cvs command: cvs update -d -j acl50_merge5 -j acl50 +- next merge tag: acl50_merge6 + ******************************************************************************* 2.2.2.5 -- join from acl50 branch @@ -58,6 +65,128 @@ next merge tag: acl50_merge2 (this should have been version 2.2.2.0, but was 2.2.1.17 instead) next merge tag: acl50_merge1 +******************************************************************************* +2.2.1.54 + +1999-04-15 Kevin Layer <layer@ultra> + + * Makefile.rs6000: use ../src/bin/make_exp + +1999-04-13 <layer@HOBART> + + * clim/frames.lisp: fix for bug7897 from Jeff + * Makefile.defs: SHELL = sh for Interix + +******************************************************************************* +2.2.1.53 + +1999-04-08 Kevin Layer <layer@ultra> + + * clim/frames.lisp: fix for spr19429 from Jeff + +******************************************************************************* +2.2.1.52 + +Thu Apr 08 17:35:24 1999 Charles A. Cox <cox@FOX> + + * utils/defun-utilities.lisp: add backward compatible definitions + of newly used ics functions. + +******************************************************************************* +2.2.1.51 + +Thu Apr 08 11:41:57 1999 Charles A. Cox <cox@FOX> + + Overall change: Add calls to string-convertors for ffi calls to winapi. + This allows clim2 to run under windows iacl, but the japanese-input-stream, + which is unix specific, is disabled under windows. Thus, other than being + able to run in iacl under Japanese Windows, there is no new or changed + functionality with this commit. + + Furthermore, presumably due to font deficiencies, Japanese characters do not + display. Finally, presumably due to "non-standard" windows input, clim + windows appear unable to accept Japanese character input via the Windows + Japanese Input Method Editor. + + NOTE: For this commit, on Windows, it is not possible to compile + clim2 with iacl. One can load, however, already built fasl files + (eg, climnt.fasl, etc.) into iacl. + + * [many files]: use with-native-string, string-to-native, etc. for + foreign calls to winapi. + +******************************************************************************* +2.2.1.50 + +1999-03-31 Jeff Morrill <jmorrill@pointnclick.com> + +* aclpc/acl-frames: Fix (setf command-enabled) again +* aclpc/acl-medium: Fixes for medium-draw-polygon*, rotated text +* aclpc/acl-mirror: Don't error for UpdateWindow, just warn. +* aclpc/acl-port: Rotated font support +* aclpc/acl-prel: Try to address occasional failures of CreateDIBitmap +* aclpc/winwidgh: add memcopy +* silica/graphics: Fix map-endpoint-sequence to fix presentation highlighting +* clim/frames: Fix accepting-values panes for the case of recycled frames +* clim/accept-values: Fix updating-output breakage in avv buttons +* test/test-suite: Add test for flipping-ink +* demo/bitmap-editor: Clean up a bit + +******************************************************************************* +2.2.1.49 + +1999-03-30 <layer@OMEGA> + + * Makefile: add windows ifdef (can't believe it wasn't there!!) + +******************************************************************************* +2.2.1.48 + +1999-03-29 Kevin Layer <layer@ultra> + + changed files: + * Makefile: for mklinux + * Makefile.freebsd: Add second PIC flag + * Makefile.wnn: Add crypt library for freebsd + deleted files: + * Makefile.linux86 + * Makefile.sun4-ol + * Makefile.sun4-svr4-ol + * instclimol.lisp + * make-symbolic-links.sh + * makedist.sh + * readme.win32 + +******************************************************************************* +2.2.1.47 + +1999-03-19 <layer@OMEGA> + + * Makefile.defs: add $(exe) where appropriate (for Interix) + +******************************************************************************* +2.2.1.46 + +1999-03-16 <layer@HOBART> + + * aclpc/pkgdcl.lisp: load user32.dll with :system-library t + arguments (in lisps that support this new keyword to load) + +******************************************************************************* +2.2.1.45 + +1999-02-24 Jeff Morrill <jmorrill@pointnclick.com> + +* aclpc/acl-frames: Fix (setf command-enabled) so it sticks, fix menu-choose + so it can disable menu items and so it will return three values. +* aclpc/acl-medium: Fix medium-draw-lines* so it works +* aclpc/acl-mirror: Try to prevent infinite recursion setting edges of + top-level sheet ("too deep!") +* clim/frames: Fix (setf command-enabled) so it sticks +* tk-silica/xt-graphics: Fix port-draw-rotated-text to rotate the correct angle +* tk-silica/xt-silica: Don't lose character bits (control, meta) +* utils/designs: More helpful error message for palette-full condition. + ******************************************************************************* 2.2.1.44 diff --git a/Makefile b/Makefile index 17c330ac..231dd30c 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -# $Header: /repo/cvs.copy/clim2/Makefile,v 1.87 1999/02/25 08:23:20 layer Exp $ +# $Header: /repo/cvs.copy/clim2/Makefile,v 1.88 1999/05/04 01:20:59 layer Exp $ # If ../makefile.top doesn't exist, then you must specify HOST=xxx on the # `make' command line. @@ -6,6 +6,10 @@ include ../makefile.top include ../makefile.defs +ifeq ($(OS_NAME),windows) +HOST = windows +endif + ifeq ($(OS_NAME),sunos) ifeq ($(MACHINE),sparc) HOST = sun4-svr4 @@ -13,9 +17,10 @@ endif endif ifeq ($(OS_NAME),linux) -HOST = linux ifeq ($(MACHINE),ppc) HOST = linuxppc +else +HOST = linux endif endif diff --git a/Makefile.defs b/Makefile.defs index 367ed38d..516a1503 100644 --- a/Makefile.defs +++ b/Makefile.defs @@ -1,4 +1,4 @@ -# $Id: Makefile.defs,v 1.48 1999/02/25 08:23:21 layer Exp $ +# $Id: Makefile.defs,v 1.49 1999/05/04 01:20:59 layer Exp $ # # Makefile.defs for CLIM 2.0 @@ -8,10 +8,10 @@ CLIM = clim.dxl SHARED_EXT = so ifeq ($(OS_NAME),windows) -LISP = ../src/lisp +LISP = ../src/lisp$(exe) DCL = dcl else -LISP = ../src/lispi +LISP = ../src/lispi$(exe) DCL = dcli endif @@ -23,7 +23,7 @@ CAT = cat ECHO = echo TAGS = etags -SHELL = /bin/sh +SHELL = sh # Lisp optimization for compiling SPEED = 3 diff --git a/Makefile.freebsd b/Makefile.freebsd index 81315b2f..6c418b06 100644 --- a/Makefile.freebsd +++ b/Makefile.freebsd @@ -1,4 +1,4 @@ -# $Id: Makefile.freebsd,v 1.2 1999/02/25 08:23:21 layer Exp $ +# $Id: Makefile.freebsd,v 1.3 1999/05/04 01:20:59 layer Exp $ include Makefile.defs @@ -16,7 +16,7 @@ PRODUCT-OBJS= $(PRODUCT-GENERIC-OBJS) $(STATIC-XM-OBJS) $(SHARED-XM-OBJS) #MOTIFXTRAS=-lgen -PICFLAGS = -DPIC +PICFLAGS = -fPIC -DPIC SHAREFLAGS = MAKE_SHARED = ld -Bshareable -Bdynamic -L/usr/X11R6/lib -L/usr/local/lib STD_DEFINES = diff --git a/Makefile.linux86 b/Makefile.linux86 deleted file mode 100644 index 7655c49b..00000000 --- a/Makefile.linux86 +++ /dev/null @@ -1,42 +0,0 @@ -# $Header: /repo/cvs.copy/clim2/Attic/Makefile.linux86,v 1.3 1997/10/20 23:10:57 layer Exp $ -# -# Makefile.sun4-svr4 for CLIM 2.0 -# - -include Makefile.defs - -Makefile=Makefile.linux86 - -# for other Motif versions use -# /net/sole/opt/ICS/Motif1.2.4/usr/include -# /net/vapor/3rd/motif-1.2.2-sol2/ICS/Motif/usr/include - -XINCLUDES=-I/usr/X11R6/include - -TKLIB=-L/usr/X11R6/lib -lXm -XTLIB=-lXt -XLIB= -lXpm -lXext -lX11 - -SET_LIBRARY_PATH= \ - LD_LIBRARY_PATH=/usr/X11R6/lib:/lib:/usr/lib:/usr/i486-linux/lib; export LD_LIBRARY_PATH - -# for other Motif versions use -# /net/sole/opt/ICS/Motif1.2.4/usr/lib:/usr/lib -# /net/vapor/3rd/motif-1.2.2-sol2/ICS/Motif/usr/lib:/usr/lib - -PRODUCT-OBJS= $(PRODUCT-GENERIC-OBJS) $(STATIC-XM-OBJS) $(SHARED-XM-OBJS) - -# from here on this file should be the same as Makefile.sun4-svr4-ol - -MOTIFXTRAS= - -PICFLAGS = -fPIC -SHAREFLAGS = -MAKE_SHARED = ld -shared -STD_DEFINES = -AR = ar cq - -ICS-PRODUCT-OBJS = -ICS-PRODUCT-FASLS = - -include Makefile.generic diff --git a/Makefile.rs6000 b/Makefile.rs6000 index dd5a897f..e4a1baeb 100644 --- a/Makefile.rs6000 +++ b/Makefile.rs6000 @@ -1,4 +1,4 @@ -# $Header: /repo/cvs.copy/clim2/Makefile.rs6000,v 1.11 1999/02/25 08:23:21 layer Exp $ +# $Header: /repo/cvs.copy/clim2/Makefile.rs6000,v 1.12 1999/05/04 01:20:59 layer Exp $ # # Makefile.rs6000 for CLIM 2.0 # @@ -16,7 +16,7 @@ XLIB=-lX11 XINCLUDES= -I/usr/include PRODUCT-OBJS= $(PRODUCT-GENERIC-OBJS) $(STATIC-XM-OBJS) $(SHARED-XM-OBJS) -MAKE_SHARED = ../src/bin/make_shared.ibm +MAKE_SHARED = ../src/bin/make_shared.ibm -make_exp ../src/bin/make_exp STD_DEFINES = -DSYSV -DAIXV3 AR = ar clq diff --git a/Makefile.sun4-ol b/Makefile.sun4-ol deleted file mode 100644 index 266010b4..00000000 --- a/Makefile.sun4-ol +++ /dev/null @@ -1,24 +0,0 @@ -# $Header: /repo/cvs.copy/clim2/Attic/Makefile.sun4-ol,v 1.3 1997/02/05 01:42:06 tomj Exp $ -# -# Makefile.sun4-ol for CLIM 2.0 -# - -include Makefile.defs - -Makefile=Makefile.sun4-ol - -CLIM=./slim.ol - -SYSTEM= openlook-clim -PRODUCT-FASLS= $(PRODUCT-GENERIC-FASLS) $(PRODUCT-OL-FASLS) -PRODUCT-OBJS= $(PRODUCT-GENERIC-OBJS) $(STATIC-OL-OBJS) - -OPENLOOKHOME=/usr/openwin - -XINCLUDES=-I$(OPENLOOKHOME)/include - -TKLIB=$(OPENLOOKHOME)/lib/libXol.a -XTLIB=$(OPENLOOKHOME)/lib/libXt.a -XLIB=$(OPENLOOKHOME)/lib/libX11.a - -include Makefile.generic diff --git a/Makefile.sun4-svr4-ol b/Makefile.sun4-svr4-ol deleted file mode 100644 index 269b2238..00000000 --- a/Makefile.sun4-svr4-ol +++ /dev/null @@ -1,33 +0,0 @@ -# $Header: /repo/cvs.copy/clim2/Attic/Makefile.sun4-svr4-ol,v 1.4 1997/10/20 23:10:57 layer Exp $ -# -# Makefile.sun4-svr4-ol for CLIM 2.0 -# - -include Makefile.defs - -Makefile=Makefile.sun4-svr4-ol - -CLIM=./slim.ol - -SYSTEM= openlook-clim -PRODUCT-FASLS= $(PRODUCT-GENERIC-FASLS) $(PRODUCT-OL-FASLS) -PRODUCT-OBJS= $(PRODUCT-GENERIC-OBJS) $(STATIC-OL-OBJS) $(SHARED-OL-OBJS) - -XINCLUDES=-I/usr/openwin/include - -TKLIB=-lXol -XTLIB=-lXt -XLIB=-lX11 - -SET_LIBRARY_PATH= \ - LD_LIBRARY_PATH=/usr/openwin/lib:/usr/lib; export LD_LIBRARY_PATH - -# from here on this file should be the same as Makefile.sun4-svr4 - -MOTIFXTRAS=-lgen - -PICFLAGS = -K pic -SHAREFLAGS = -MAKE_SHARED = ld -G - -include Makefile.generic diff --git a/Makefile.wnn b/Makefile.wnn index ca78c55a..68e71ece 100644 --- a/Makefile.wnn +++ b/Makefile.wnn @@ -1,4 +1,4 @@ -# $Header: /repo/cvs.copy/clim2/Makefile.wnn,v 1.5 1999/02/25 08:23:21 layer Exp $ +# $Header: /repo/cvs.copy/clim2/Makefile.wnn,v 1.6 1999/05/04 01:20:59 layer Exp $ # # Makefile.wnn for CLIM 2.0 # @@ -79,6 +79,10 @@ ifeq ($(MACHINE),ppc) REDHATLIBS = -lcrypt endif +ifeq ($(OS_NAME),freebsd) +REDHATLIBS = -lcrypt +endif + wnn.$(SHARED_EXT): $(WNN_OBJS) $(MAKE_SHARED) $(SHAREFLAGS) -o wnn.$(SHARED_EXT) $(WNN_OBJS) \ $(REDHATLIBS) diff --git a/RELNOTES b/RELNOTES index 2e122c1d..33b84a96 100644 --- a/RELNOTES +++ b/RELNOTES @@ -13,4 +13,14 @@ developers or documentation. ************* add new entries below this line ********************************* -1. [bug/rfe#] ...summary... +<<<add new entries here, include bug/rfe id for each item>>> + +******************************************************************************* +*** 5.0.1.beta2 items below this line + +1. <norfe> CLIM works on FreeBSD only with MetroLink Motif + Complete! version 1.2.4. + +2. <norfe> CLIM doesn't work very well on MkLinux/LinuxPPC because + all that we have there is LessTif. + diff --git a/aclpc/acl-class.lisp b/aclpc/acl-class.lisp index 679338ec..0331d2a6 100644 --- a/aclpc/acl-class.lisp +++ b/aclpc/acl-class.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: acl-class.lisp,v 1.11 1999/02/25 08:23:24 layer Exp $ +;; $Id: acl-class.lisp,v 1.12 1999/05/04 01:21:00 layer Exp $ #|**************************************************************************** * * @@ -1083,7 +1083,8 @@ ((device-handle1 :initarg :device-handle1 :initform 0) (device-handle2 :initarg :device-handle1 - :initform (win:CreateDC "DISPLAY" ct:hnull ct:hnull ct:hnull)))) + :initform (excl:with-native-string (d "DISPLAY") + (win:CreateDC d ct:hnull ct:hnull ct:hnull))))) (defun initialize-cg () (let* ((dataobj (make-array 3 :element-type '(signed-byte 32)))) @@ -1242,15 +1243,17 @@ win:WS_MINIMIZEBOX win:WS_MAXIMIZEBOX)))) (setq window - (win:CreateWindowEx exstyle - *clim-class* - *win-name* - winstyle - left top width height - (or parent 0) - menu - *hinst* - *win-x* )) + (excl:with-native-string (*clim-class* *clim-class*) + (excl:with-native-string (*win-name* *win-name*) + (win:CreateWindowEx exstyle + *clim-class* + *win-name* + winstyle + left top width height + (or parent 0) + menu + *hinst* + *win-x* )))) (when (zerop window) (or (check-last-error "CreateWindowEx") (error "CreateWindowEx: unknown error"))) @@ -1275,16 +1278,19 @@ (*win-name* *win-name*)) (when pretty (setq *win-name* pretty)) - (let ((window (win:CreateWindowEx - (if ovl 0 win:WS_EX_TOOLWINDOW) - *clim-class* - *win-name* - winstyle - left top width height - parent - 0 - *hinst* - *win-x*))) + (let ((window + (excl:with-native-string (*clim-class* *clim-class*) + (excl:with-native-string (*win-name* *win-name*) + (win:CreateWindowEx + (if ovl 0 win:WS_EX_TOOLWINDOW) + *clim-class* + *win-name* + winstyle + left top width height + parent + 0 + *hinst* + *win-x*))))) (when (zerop window) (check-last-error "CreateWindowEx")) window))) @@ -1316,15 +1322,17 @@ (when pretty (setq *win-name* pretty)) (setq window + (excl:with-native-string (*clim-class* *clim-class*) + (excl:with-native-string (*win-name* *win-name*) (win:CreateWindowEx exstyle - *clim-class* - *win-name* - winstyle - left top width height - parent - menu - *hinst* - *win-x*)) + *clim-class* + *win-name* + winstyle + left top width height + parent + menu + *hinst* + *win-x*)))) (when (zerop window) (check-last-error "CreateWindowEx")) (if (or (eql scroll :both)(eql scroll :vertical)) diff --git a/aclpc/acl-dc.lisp b/aclpc/acl-dc.lisp index b4b0e5f9..83b79e07 100644 --- a/aclpc/acl-dc.lisp +++ b/aclpc/acl-dc.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: acl-dc.lisp,v 1.8 1999/02/25 08:23:24 layer Exp $ +;; $Id: acl-dc.lisp,v 1.9 1999/05/04 01:21:00 layer Exp $ #|**************************************************************************** * * @@ -236,27 +236,28 @@ (brush *null-brush*) (pen (when (= code 1) (dc-image-solid-1-pen image))) (rop2 (dc-image-rop2 image)) - (color (dc-image-text-color image))) + (text-color (dc-image-text-color image))) (declare (fixnum thickness code)) (unless pen (when *created-pen* (push *created-pen* *extra-objects*)) (when (and dashes (> thickness 1)) - ;; CreatePen does not support this combination. + ;; CreatePen does not support thick dashed lines. ;; So render dashes with thickness=1. + ;; (Use ExtCreatePen!) (setq thickness 1)) (when (= rop2 win:R2_XORPEN) - (setq color #xffffff)) ; black + (setq text-color #xffffff)) ; black (setq pen (setq *created-pen* (createPen (if dashes win:PS_DASH win:PS_SOLID) thickness - color)))) + text-color)))) (selectobject dc pen) (if dashes (win:SetBkMode dc win:TRANSPARENT) (win:SetBkMode dc win:OPAQUE)) - (selectobject dc brush) + (when brush (selectobject dc brush)) (when rop2 (win:SetRop2 dc rop2)) t)) @@ -327,8 +328,7 @@ (text-color (dc-image-text-color image)) (background-color (dc-image-background-color image)) (brush (dc-image-brush image)) - (pen (dc-image-solid-1-pen image)) - (rop2 (dc-image-rop2 image))) + (pen (dc-image-solid-1-pen image))) (win:SetMapMode dc win:MM_TEXT) (when font (selectobject dc font)) (cond ((not background-color) @@ -338,10 +338,12 @@ (t (win:SetBkMode dc win:OPAQUE) (win:SetBkColor dc background-color))) - (when text-color (win:setTextColor dc text-color)) (when brush (win:SelectObject dc brush)) (when pen (win:SelectObject dc pen)) - (when rop2 (win:SetRop2 dc rop2)))) + (when text-color (win:SetTextColor dc text-color)) + ;; SetRop2 has no effect on text. If you want to use + ;; one, you have to draw into a bitmap and biblt that. + t)) (defgeneric dc-image-for-ink (medium ink)) diff --git a/aclpc/acl-frames.lisp b/aclpc/acl-frames.lisp index 603a626d..60cf2b4a 100644 --- a/aclpc/acl-frames.lisp +++ b/aclpc/acl-frames.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: acl-frames.lisp,v 1.9 1999/02/25 08:23:24 layer Exp $ +;; $Id: acl-frames.lisp,v 1.10 1999/05/04 01:21:00 layer Exp $ #|**************************************************************************** * * @@ -171,7 +171,6 @@ (eq c command))))) *menu-id->command-table*)) -;; pr Aug97 (defun map-command-menu-ids (frame func &rest args) (dotimes (id (fill-pointer *menu-id->command-table*)) (let ((x (aref *menu-id->command-table* id))) @@ -179,17 +178,81 @@ (let ((f (first x))) (if (eq f frame) (apply func id args))))))) -;;; Disable all menu items. -(defun clim-internals::enable-menu-items (frame enablep) +;;; The following two methods are called as a pair (see +;;; CLIM-INTERNALS::WITH-MENU-DISABLED). +;;; +;;; In DISABLE-ALL-MENU-ITEMS: +;;; 1] Remember the previously disabled-commands; +;;; 2] Disable all the defined commands; +;;; 3] Return the list of the previously disabled-commands. +;;; +;;; In RE-ENABLE-MENU-ITEMS: +;;; 1] Record the currently disabled-commands; +;;; 2] re-Disable all the commands that were previously +;;; disabled if and only if they are still disabled. +;;; +;;; This last condition worries about any commands that +;;; have been actively enabled since the corresponding +;;; call to DISABLE-ALL-MENU-ITEMS. + +(defun clim-internals::disable-all-menu-items (frame) + ;;; Called before a command is executed. + ;;; + ;;; Push all the commands on top of the + ;;; previously-disabled commands. + ;;; + ;;; In particular note that any previously-disabled + ;;; command will appear in the list of disabled-commands + ;;; two (or possibly more) times. + ;;; + ;;; See the subequent clean-up below in + ;;; clim-internals::re-enable-menu-items. (map-command-menu-ids frame #'(lambda (menuid) (let ((command-name (second (aref *menu-id->command-table* menuid)))) (with-slots (clim-internals::disabled-commands) frame - (if enablep - (setf clim-internals::disabled-commands - (delete command-name clim-internals::disabled-commands)) - (push command-name clim-internals::disabled-commands))))))) + (push command-name clim-internals::disabled-commands))))) + ) + +;;; See the comment for DISABLE-ALL-MENU-ITEMS +(defun clim-internals::re-enable-menu-items (frame) + (let ((new-disabled-commands nil)) + (with-slots (clim-internals::disabled-commands) frame + + ;;; Called after a command has finished executing. + ;;; (See set-up above in clim-internals::disable-all-menu-items.) + ;;; + ;;; Re-Disable a command if and only if it appears + ;;; in the list of disabled-commands twice. + ;;; + ;;; 1] If a command has been actively enabled during + ;;; the execution of the present-command, all + ;;; appearances in the list of disabled-commands + ;;; will have been removed. + ;;; 2] If a command has been actively disabled during + ;;; the execution of the present-command, it + ;;; will appear in the list two (or more) times. + ;;; 3] If a command was disabled before the + ;;; presently-exectuted command began, it should + ;;; appear in the list two (or more) time. + ;;; + ;;; Note that this scheme loses if the presently-executing + ;;; command first actively enables a command and then + ;;; actively disables it (i.e. at the end the command + ;;; will appear in the list only once, and so not be + ;;; disabled here). + ;;; + ;;; Note also this assume that the commands are being + ;;; en/dis-abled throught the standard (setf command-enabled) + ;;; mechanism. I.e. the user's code hasn't been + ;;; directly munging the disabled-command slot. + (loop for (com . rest) on clim-internals::disabled-commands + do (when (member com rest) + (pushnew com new-disabled-commands))) + + (setq clim-internals::disabled-commands + new-disabled-commands)))) ;;; Either of these would be nicer, but redisplay of the menu bar causes them to not ;;; always get repainted in their ungrayed state at the end. pr Aug97 @@ -369,16 +432,20 @@ (when acckey (record-accelerator frame acckey value top-level-sheet)) (let ((menu-item-id (assign-command-menu-item-id value frame))) - (win:AppendMenu - menuhand - flags - menu-item-id - (make-menu-text menu - ;; Don't display the accelerator key if - ;; the command is going to land on the menu bar itself, - ;; Windows will not correctly display such text. - (if top-level-p nil acckey) - item)) + (excl:with-native-string (m (make-menu-text + menu + ;; Don't display the accelerator key if + ;; the command is going to land on the + ;; menu bar itself, + ;; Windows will not correctly display + ;; such text. + (if top-level-p nil acckey) + item)) + (win:AppendMenu + menuhand + flags + menu-item-id + m)) (push menu-item-id (gethash menuhand *popup-menu->menu-item-ids*)))) (:function (warn ":function not yet implemented in menu bars") @@ -387,16 +454,18 @@ (let* ((submenu (win:CreatePopupMenu)) (submenu-handle (ct:handle-value 'win:hmenu submenu)) (menutext (make-menu-text menu acckey item))) - (win:AppendMenu menuhand - smflags - submenu-handle - menutext) + (excl:with-native-string (menutext menutext) + (win:AppendMenu menuhand + smflags + submenu-handle + menutext)) (make-menu-for-command-table value submenu-handle frame top-level-sheet))) (:divider - (win:AppendMenu menuhand - win:MF_SEPARATOR - 0 - "x") + (excl:with-native-string (x "x") + (win:AppendMenu menuhand + win:MF_SEPARATOR + 0 + x)) )))) command-table)) @@ -423,7 +492,8 @@ (ticknow (when tickthen (slot-value (find-command-table command-table) 'clim-internals::menu-tick)))) (when (and tickthen ticknow (not (= tickthen ticknow))) - (make-menu-for-command-table command-table menuhand frame t) + (make-menu-for-command-table command-table menuhand frame + (frame-top-level-sheet frame) t) t))) (defun update-menu-item-sensitivities (hmenu) @@ -610,7 +680,9 @@ to be run from another." (dotimes (i subsize) (ct:cset (:char 256) cstr ((fixnum i)) (char-int (char name i)))) (ct:cset (:char 256) cstr ((fixnum subsize)) (char-int #\NULL)) - (or (win:SetWindowText win cstr) + (or #+removed (win:SetWindowText win cstr) + (excl:with-native-string (cstr name) + (win:SetWindowText win cstr)) (check-last-error "SetWindowText")))))) (defun select-messagebox-icon (style) @@ -717,338 +789,357 @@ to be run from another." ((= code win:idignore) (or (find-label "Ignore") :exit))))))) (defun message-box (hwnd message-string name &optional icon) - (win:messagebox hwnd - (coerce message-string 'simple-string) - (coerce name 'simple-string) - (or icon - (logior win:MB_ICONSTOP - win:MB_TASKMODAL)))) - -(defmethod frame-manager-notify-user - ((framem acl-frame-manager) message-string - &key (style :inform) - (frame nil frame-p) - (associated-window - (if frame-p - (frame-top-level-sheet frame) - (graft framem))) - (title "Notification") - documentation - (exit-boxes '(:exit :abort)) - (name title) - text-style - &allow-other-keys) - (declare (ignore documentation)) ; FIXME - ;; Uses MessageBox() to put up a simple dialog box, - ;; unless the user has specified some fancy options, in - ;; which case accepting-values will have to suffice. - (let ((icon (select-messagebox-icon style)) - (buttons (select-messagebox-buttons exit-boxes))) - (if (and icon buttons (not text-style)) - (let* ((hwnd (sheet-mirror associated-window)) - (code (message-box - hwnd - (coerce message-string 'simple-string) - (coerce name 'simple-string) - (logior win:MB_TASKMODAL icon buttons))) - (symbol (select-messagebox-result code buttons exit-boxes))) - ;; Notify-user is supposed to return T or NIL: - (case symbol - (:exit t) - (:abort nil) - (otherwise symbol))) - (let ((stream associated-window)) - (accepting-values (stream :exit-boxes exit-boxes - :scroll-bars :both - :label name - :own-window t) - (with-text-style (stream text-style) - (write-string message-string stream))))))) - -(defun do-one-menu-item (popmenu item printer tick alist submenus) - (let ((*print-circle* nil)) - (flet ((print-item (item) - (silica::xlat-newline-return - (with-output-to-string (stream) - ;; The click-right menu uses PRESENT at this point to - ;; get the menu text, using the stream-default-view, which needs to be - ;; set to textual-menu-view. - (letf-globally (((stream-default-view stream) +textual-menu-view+)) - (funcall (or printer #'print-menu-item) item stream)))))) - (declare (dynamic-extent #'print-item)) - (incf tick) - (ecase (clim-internals::menu-item-type item) - (:divider - (win:appendmenu popmenu win:MF_SEPARATOR tick 0)) - (:label - (win:appendmenu popmenu win:MF_DISABLED tick - (print-item item))) - (:item - (if (clim-internals::menu-item-items item) - (let ((submenu (win:createpopupmenu))) - (push submenu submenus) - ;; submenu - (win:appendmenu popmenu win:MF_POPUP submenu - (print-item item)) - (map nil - #'(lambda (it) - (multiple-value-setq (tick alist submenus) - (do-one-menu-item submenu it printer - tick alist submenus))) - (clim-internals::menu-item-items item))) - (progn - (push (list tick (menu-item-value item)) - alist) - (win:appendmenu popmenu win:MF_ENABLED tick - (print-item item)))))) - (values tick alist submenus)))) - -;; Gets rid of scroll bars if possible. -(defmethod frame-manager-menu-choose - ((framem acl-frame-manager) items &rest keys - &key printer - presentation-type - (associated-window (frame-top-level-sheet *application-frame*)) - text-style label - foreground background - cache - (unique-id items) - (id-test 'equal) - (cache-value items) - (cache-test #'equal) - (gesture :select) - row-wise - n-columns - n-rows - x-position - y-position - scroll-bars) - ;; The basic theory of ignoring is that we ignore arguments - ;; that don't contribute functionality and just bring up - ;; the native menu without any fluff. - (declare (ignore text-style cache - cache-test cache-value - id-test unique-id label - foreground background)) - (if (or presentation-type ;; foreground background - row-wise n-columns n-rows scroll-bars) - (call-next-method) - #+simple-but-sure - (apply #'call-next-method framem items :scroll-bars nil keys) - (let ((popmenu (win:CreatePopupMenu)) - (submenus nil) - (flags (logior win:tpm_returncmd ; return the selection - win:tpm_nonotify ; don't notify clim - (if (eq gesture :menu) - win:tpm_rightbutton - win:tpm_leftbutton))) - (rect 0) - (tick 0) - (alist nil) - (code 0)) - (when (zerop popmenu) - (check-last-error "CreatePopupMenu")) - (unless (and x-position y-position) - ;; Get screen coordinates of pointer. - (let ((point (ct:ccallocate win:point))) - (or (win:getCursorPos point) - (check-last-error "GetCursorPos")) - (setq x-position (ct:cref win:point point x)) - (setq y-position (ct:cref win:point point y)))) - (setq x-position (truncate x-position)) - (setq y-position (truncate y-position)) - (map nil #'(lambda (item) - (multiple-value-setq (tick alist submenus) - (do-one-menu-item popmenu item printer - tick alist submenus))) - items) - ;; Bug here, exhibited by CAD Demo Create, that menu - ;; is sometimes never exposed. TrackPopupMenu returns 0. - ;; But most of the time this seems to work... 5/98 JPM. - (setq code - (win:trackpopupmenu - popmenu flags x-position y-position - 0 ; reserved, must be zero - (sheet-mirror associated-window) rect)) - (win:destroymenu popmenu) - (dolist (submenu submenus) (win:destroymenu submenu)) - (cond ((zerop code) ; no item is selected - nil) - (t - (second (assoc code alist))))))) - -(defun make-filter-string (dotted-pair) - (let ((*print-circle* nil)) - (format nil "~a (~a)~a~a~a" - (car dotted-pair) (cdr dotted-pair) (code-char 0) - (cdr dotted-pair) (code-char 0)))) - -(eval-when (compile load eval) - ;; All pathnames returned by SELECT-FILE must fit in the scratch string, - ;; so make it pretty big. - (defconstant *scratch-string-length* 2048) - ) - -(defparameter *scratch-lisp-string* - (make-string *scratch-string-length*)) - -(defparameter *scratch-c-string* - (ff:allocate-fobject-c `(:array :char ,*scratch-string-length*))) - -(defun lisp-string-to-scratch-c-string (lisp-string) - (let ((length (min (length lisp-string) - (1- *scratch-string-length*)))) - (dotimes (i length - ;; null term - (setf (ff:fslot-value-c '(:array :char 1) - *scratch-c-string* - length) 0)) - (setf (ff:fslot-value-c '(:array char 1) *scratch-c-string* - i) - (char-int (aref lisp-string i)))) - *scratch-c-string* + (excl:with-native-string (m (coerce message-string 'simple-string)) + (excl:with-native-string (n (coerce name 'simple-string)) + (win:messagebox hwnd + m + n + (or icon + (logior win:MB_ICONSTOP + win:MB_TASKMODAL)))))) + + (defmethod frame-manager-notify-user + ((framem acl-frame-manager) message-string + &key (style :inform) + (frame nil frame-p) + (associated-window + (if frame-p + (frame-top-level-sheet frame) + (graft framem))) + (title "Notification") + documentation + (exit-boxes '(:exit :abort)) + (name title) + text-style + &allow-other-keys) + (declare (ignore documentation)) ; FIXME + ;; Uses MessageBox() to put up a simple dialog box, + ;; unless the user has specified some fancy options, in + ;; which case accepting-values will have to suffice. + (let ((icon (select-messagebox-icon style)) + (buttons (select-messagebox-buttons exit-boxes))) + (if (and icon buttons (not text-style)) + (let* ((hwnd (sheet-mirror associated-window)) + (code (message-box + hwnd + (coerce message-string 'simple-string) + (coerce name 'simple-string) + (logior win:MB_TASKMODAL icon buttons))) + (symbol (select-messagebox-result code buttons exit-boxes))) + ;; Notify-user is supposed to return T or NIL: + (case symbol + (:exit t) + (:abort nil) + (otherwise symbol))) + (let ((stream associated-window)) + (accepting-values (stream :exit-boxes exit-boxes + :scroll-bars :both + :label name + :own-window t) + (with-text-style (stream text-style) + (write-string message-string stream))))))) + + (defun do-one-menu-item (popmenu item printer tick alist submenus) + (let ((*print-circle* nil)) + (flet ((print-item (item) + (silica::xlat-newline-return + (with-output-to-string (stream) + ;; The click-right menu uses PRESENT at this point to + ;; get the menu text, using the stream-default-view, which needs to be + ;; set to textual-menu-view. + (letf-globally (((stream-default-view stream) +textual-menu-view+)) + (funcall (or printer #'print-menu-item) item stream)))))) + (declare (dynamic-extent #'print-item)) + (incf tick) + (ecase (clim-internals::menu-item-type item) + (:divider + (win:appendmenu popmenu win:MF_SEPARATOR tick 0)) + (:label + (excl:with-native-string (p-i (print-item item)) + (win:appendmenu popmenu win:MF_DISABLED tick + p-i))) + (:item + (if (clim-internals::menu-item-items item) + (let ((submenu (win:createpopupmenu))) + (push submenu submenus) + ;; submenu + (excl:with-native-string (p-i (print-item item)) + (win:appendmenu popmenu win:MF_POPUP submenu + p-i)) + (map nil + #'(lambda (it) + (multiple-value-setq (tick alist submenus) + (do-one-menu-item submenu it printer + tick alist submenus))) + (clim-internals::menu-item-items item))) + (progn + (push (list tick (menu-item-value item)) + alist) + + (excl:with-native-string (p-i (print-item item)) + (if (clim-internals::menu-item-active item) + (win:appendmenu popmenu win:MF_ENABLED tick + p-i) + ;;; Use win:MF_GRAYED rather than win:MF_DISABLED. + ;;; The latter will also disable the command, but + ;;; doesn't seem to affect the appearance. + (win:appendmenu popmenu win:MF_GRAYED tick + p-i))))))) + (values tick alist submenus)))) + + ;; Gets rid of scroll bars if possible. + (defmethod frame-manager-menu-choose + ((framem acl-frame-manager) items &rest keys + &key printer + presentation-type + (associated-window (frame-top-level-sheet *application-frame*)) + text-style label + foreground background + cache + (unique-id items) + (id-test 'equal) + (cache-value items) + (cache-test #'equal) + (gesture :select) + row-wise + n-columns + n-rows + x-position + y-position + scroll-bars) + ;; The basic theory of ignoring is that we ignore arguments + ;; that don't contribute functionality and just bring up + ;; the native menu without any fluff. + (declare (ignore text-style cache + cache-test cache-value + id-test unique-id label + foreground background)) + (if (or presentation-type ;; foreground background + row-wise n-columns n-rows scroll-bars) + (call-next-method) + #+simple-but-sure + (apply #'call-next-method framem items :scroll-bars nil keys) + (let ((popmenu (win:CreatePopupMenu)) + (submenus nil) + (flags (logior win:tpm_returncmd ; return the selection + win:tpm_nonotify ; don't notify clim + (if (eq gesture :menu) + win:tpm_rightbutton + win:tpm_leftbutton))) + (rect 0) + (tick 0) + (alist nil) + (code 0)) + (when (zerop popmenu) + (check-last-error "CreatePopupMenu")) + (unless (and x-position y-position) + ;; Get screen coordinates of pointer. + (let ((point (ct:ccallocate win:point))) + (or (win:getCursorPos point) + (check-last-error "GetCursorPos")) + (setq x-position (ct:cref win:point point x)) + (setq y-position (ct:cref win:point point y)))) + (setq x-position (truncate x-position)) + (setq y-position (truncate y-position)) + (map nil #'(lambda (item) + (multiple-value-setq (tick alist submenus) + (do-one-menu-item popmenu item printer + tick alist submenus))) + items) + ;; Bug here, exhibited by CAD Demo Create, that menu + ;; is sometimes never exposed. TrackPopupMenu returns 0. + ;; But most of the time this seems to work... 5/98 JPM. + (setq code + (win:trackpopupmenu + popmenu flags x-position y-position + 0 ; reserved, must be zero + (sheet-mirror associated-window) rect)) + (win:destroymenu popmenu) + (dolist (submenu submenus) (win:destroymenu submenu)) + (cond ((zerop code) ; no item is selected + nil) + (t + (let ((x (assoc code alist))) + (values (second x) (third x) :unknown-gesture)) + ))))) + + (defun make-filter-string (dotted-pair) + (let ((*print-circle* nil)) + (format nil "~a (~a)~a~a~a" + (car dotted-pair) (cdr dotted-pair) (code-char 0) + (cdr dotted-pair) (code-char 0)))) + + (eval-when (compile load eval) + ;; All pathnames returned by SELECT-FILE must fit in the scratch string, + ;; so make it pretty big. + (defconstant *scratch-string-length* 2048) + ) + + (defparameter *scratch-lisp-string* + (make-string *scratch-string-length*)) + + (defparameter *scratch-c-string* + (ff:allocate-fobject-c `(:array :char ,*scratch-string-length*))) + + (defun lisp-string-to-scratch-c-string (lisp-string) + (let ((length (min (length lisp-string) + (1- *scratch-string-length*)))) + (dotimes (i length + ;; null term + (setf (ff:fslot-value-c '(:array :char 1) + *scratch-c-string* + length) 0)) + (setf (ff:fslot-value-c '(:array char 1) *scratch-c-string* + i) + (char-int (aref lisp-string i)))) + *scratch-c-string* + )) + + (defun scratch-c-string-to-lisp-string () + (ff:char*-to-string *scratch-c-string*)) + + (defun pathnames-from-directory-and-filenames (filename-list) + ;; Takes a list consisting of a directory namestring followed + ;; by a set of filenames relative to that directory. + ;; This is the sort of list returned by the common dialog + ;; when multiple choices are allowed. + ;; Returns a list of complete pathnames. + (if (eq (length filename-list) 1) + ;; If only one choice, no separate directory is returned + ;; by the GetOpenFileName call. + filename-list + (let ((directory (car filename-list))) + ;; Windows doesn't stick a backslash on the end of the dir. + (unless (eql (aref directory (1- (length directory))) #\\) + (setf directory (concatenate 'string directory "\\"))) + (mapcar #'(lambda (filename) + ;; cac removed call to namestring to have this function + ;; return pathnames instead of strings. + ;; 5-apr-94 + (merge-pathnames filename directory)) + (cdr filename-list))))) + + (defun delimited-string-to-list (string delimiter-char-or-string) + "Returns a list of substrings of STRING, separating it at DELIMETER-CHAR-OR-STRING" + (do* ((stringp (stringp delimiter-char-or-string)) + (delimiter-length (if stringp + (length delimiter-char-or-string) + 1)) + (s string (subseq s (+ index delimiter-length))) + (index + (if stringp + (search delimiter-char-or-string s) + (position delimiter-char-or-string s)) + (if stringp + (search delimiter-char-or-string s) + (position delimiter-char-or-string s))) + (list + (list (subseq s 0 index)) + (nconc list (list (subseq s 0 index))))) + ((null index) + list))) + + (defun spaced-string-to-list (string) ;; <27> + (delimited-string-to-list string #\space)) + + (cl:defparameter common-dialog-errors + '((#xffff . cderr_dialogfailure) + (#x0000 . cderr_generalcodes) + (#x0001 . cderr_structsize) + (#x0002 . cderr_initialization) + (#x0003 . cderr_notemplate) + (#x0004 . cderr_nohinstance) + (#x0005 . cderr_loadstrfailure) + (#x0006 . cderr_findresfailure) + (#x0007 . cderr_loadresfailure) + (#x0008 . cderr_lockresfailure) + (#x0009 . cderr_memallocfailure) + (#x000a . cderr_memlockfailure) + (#x000b . cderr_nohook) + (#x000c . cderr_registermsgfail) + (#x1000 . pderr_printercodes) + (#x1001 . pderr_setupfailure) + (#x1002 . pderr_parsefailure) + (#x1003 . pderr_retdeffailure) + (#x1004 . pderr_loaddrvfailure) + (#x1005 . pderr_getdevmodefail) + (#x1006 . pderr_initfailure) + (#x1007 . pderr_nodevices) + (#x1008 . pderr_nodefaultprn) + (#x1009 . pderr_dndmmismatch) + (#x100a . pderr_createicfailure) + (#x100b . pderr_printernotfound) + (#x100c . pderr_defaultdifferent) + (#x2000 . cferr_choosefontcodes) + (#x2001 . cferr_nofonts) + (#x2002 . cferr_maxlessthanmin) + (#x3000 . fnerr_filenamecodes) + (#x3001 . fnerr_subclassfailure) + (#x3002 . fnerr_invalidfilename) + (#x3003 . fnerr_buffertoosmall) + (#x4000 . frerr_findreplacecodes) + (#x4001 . frerr_bufferlengthzero) + (#x5000 . ccerr_choosecolorcodes) )) -(defun scratch-c-string-to-lisp-string () - (ff:char*-to-string *scratch-c-string*)) - -(defun pathnames-from-directory-and-filenames (filename-list) - ;; Takes a list consisting of a directory namestring followed - ;; by a set of filenames relative to that directory. - ;; This is the sort of list returned by the common dialog - ;; when multiple choices are allowed. - ;; Returns a list of complete pathnames. - (if (eq (length filename-list) 1) - ;; If only one choice, no separate directory is returned - ;; by the GetOpenFileName call. - filename-list - (let ((directory (car filename-list))) - ;; Windows doesn't stick a backslash on the end of the dir. - (unless (eql (aref directory (1- (length directory))) #\\) - (setf directory (concatenate 'string directory "\\"))) - (mapcar #'(lambda (filename) - ;; cac removed call to namestring to have this function - ;; return pathnames instead of strings. - ;; 5-apr-94 - (merge-pathnames filename directory)) - (cdr filename-list))))) - -(defun delimited-string-to-list (string delimiter-char-or-string) - "Returns a list of substrings of STRING, separating it at DELIMETER-CHAR-OR-STRING" - (do* ((stringp (stringp delimiter-char-or-string)) - (delimiter-length (if stringp - (length delimiter-char-or-string) - 1)) - (s string (subseq s (+ index delimiter-length))) - (index - (if stringp - (search delimiter-char-or-string s) - (position delimiter-char-or-string s)) - (if stringp - (search delimiter-char-or-string s) - (position delimiter-char-or-string s))) - (list - (list (subseq s 0 index)) - (nconc list (list (subseq s 0 index))))) - ((null index) - list))) - -(defun spaced-string-to-list (string) ;; <27> - (delimited-string-to-list string #\space)) - -(cl:defparameter common-dialog-errors - '((#xffff . cderr_dialogfailure) - (#x0000 . cderr_generalcodes) - (#x0001 . cderr_structsize) - (#x0002 . cderr_initialization) - (#x0003 . cderr_notemplate) - (#x0004 . cderr_nohinstance) - (#x0005 . cderr_loadstrfailure) - (#x0006 . cderr_findresfailure) - (#x0007 . cderr_loadresfailure) - (#x0008 . cderr_lockresfailure) - (#x0009 . cderr_memallocfailure) - (#x000a . cderr_memlockfailure) - (#x000b . cderr_nohook) - (#x000c . cderr_registermsgfail) - (#x1000 . pderr_printercodes) - (#x1001 . pderr_setupfailure) - (#x1002 . pderr_parsefailure) - (#x1003 . pderr_retdeffailure) - (#x1004 . pderr_loaddrvfailure) - (#x1005 . pderr_getdevmodefail) - (#x1006 . pderr_initfailure) - (#x1007 . pderr_nodevices) - (#x1008 . pderr_nodefaultprn) - (#x1009 . pderr_dndmmismatch) - (#x100a . pderr_createicfailure) - (#x100b . pderr_printernotfound) - (#x100c . pderr_defaultdifferent) - (#x2000 . cferr_choosefontcodes) - (#x2001 . cferr_nofonts) - (#x2002 . cferr_maxlessthanmin) - (#x3000 . fnerr_filenamecodes) - (#x3001 . fnerr_subclassfailure) - (#x3002 . fnerr_invalidfilename) - (#x3003 . fnerr_buffertoosmall) - (#x4000 . frerr_findreplacecodes) - (#x4001 . frerr_bufferlengthzero) - (#x5000 . ccerr_choosecolorcodes) - )) - -(defun get-pathname-flags (save-p multiple-p warn-if-exists-p) - (logior - (if multiple-p win:OFN_ALLOWMULTISELECT 0) - (if save-p 0 win:OFN_FILEMUSTEXIST) - ;; This is only relevant if save-p: - (if warn-if-exists-p win:OFN_OVERWRITEPROMPT 0) - win:OFN_NOCHANGEDIR - win:OFN_HIDEREADONLY)) - -(defun get-pathname (prompt directory stream allowed-types initial-name - save-p multiple-p warn-if-exists-p) - (flet ((fill-c-string (string) - (let ((c-string (ff:allocate-fobject-c '(:array :char 256))) - (length (length string))) - (assert (< length 255)) - (dotimes (i length) - (setf (ff:fslot-value-c '(:array char 1) c-string i) - (char-int (aref string i)))) - (setf (ff:fslot-value-c '(:array :char 1) c-string length) - 0) - c-string))) - (let* ((open-file-struct (ct:ccallocate win:openfilename)) - (file-filter-string - (fill-c-string - (apply #'concatenate 'string - (mapcar #'make-filter-string allowed-types)))) - (initial-dir-string (fill-c-string (string directory))) - (prompt-string (fill-c-string (string prompt)))) - (ct:csets win:openfilename open-file-struct - lstructsize (ct:sizeof win:openfilename) - hwndowner (or (and stream (sheet-mirror stream)) - 0) - hinstance 0 ; no custom dialog - lpstrfilter file-filter-string - lpstrcustomfilter 0 - nmaxcustfilter 0 ;; length of custom filter string - nfilterindex 0 ; zero means use custom-filter if supplied - ; otherwise the first filter in the list - lpstrfile (lisp-string-to-scratch-c-string (or initial-name "")) - nmaxfile *scratch-string-length* - lpstrfiletitle 0 - nmaxfiletitle 0 - lpstrinitialdir initial-dir-string - lpstrtitle prompt-string - flags (get-pathname-flags save-p multiple-p warn-if-exists-p) - nfileoffset 0 - nfileextension 0 - lpstrdefext 0 - lcustdata 0 - lpfnhook 0 - lptemplatename 0 - ) - (let* ((result + (defun get-pathname-flags (save-p multiple-p warn-if-exists-p) + (logior + (if multiple-p win:OFN_ALLOWMULTISELECT 0) + (if save-p 0 win:OFN_FILEMUSTEXIST) + ;; This is only relevant if save-p: + (if warn-if-exists-p win:OFN_OVERWRITEPROMPT 0) + win:OFN_NOCHANGEDIR + win:OFN_HIDEREADONLY)) + + (defun get-pathname (prompt directory stream allowed-types initial-name + save-p multiple-p warn-if-exists-p) + (flet ((fill-c-string (string) + (let ((c-string (ff:allocate-fobject-c '(:array :char 256))) + (length (length string))) + (assert (< length 255)) + (dotimes (i length) + (setf (ff:fslot-value-c '(:array char 1) c-string i) + (char-int (aref string i)))) + (setf (ff:fslot-value-c '(:array :char 1) c-string length) + 0) + c-string))) + (let* ((open-file-struct (ct:ccallocate win:openfilename)) + (file-filter-string + (fill-c-string + (apply #'concatenate 'string + (mapcar #'make-filter-string allowed-types)))) + (initial-dir-string (fill-c-string (string directory))) + (prompt-string (fill-c-string (string prompt)))) + (excl:with-native-string (file-filter-string file-filter-string) + (excl:with-native-string (s1 (lisp-string-to-scratch-c-string (or initial-name ""))) + (excl:with-native-string (initial-dir-string initial-dir-string) + (excl:with-native-string (prompt-string prompt-string) + + (ct:csets win:openfilename open-file-struct + lstructsize (ct:sizeof win:openfilename) + hwndowner (or (and stream (sheet-mirror stream)) + 0) + hinstance 0 ; no custom dialog + lpstrfilter file-filter-string + lpstrcustomfilter 0 + nmaxcustfilter 0 ;; length of custom filter string + nfilterindex 0 ; zero means use custom-filter if supplied + ; otherwise the first filter in the list + lpstrfile s1 + nmaxfile *scratch-string-length* + lpstrfiletitle 0 + nmaxfiletitle 0 + lpstrinitialdir initial-dir-string + lpstrtitle prompt-string + flags (get-pathname-flags save-p multiple-p warn-if-exists-p) + nfileoffset 0 + nfileextension 0 + lpstrdefext 0 + lcustdata 0 + lpfnhook 0 + lptemplatename 0 + ))))) + (let* ((result (if save-p (win:GetSaveFileName open-file-struct) (win:GetOpenFileName open-file-struct)))) @@ -1450,12 +1541,14 @@ in a second Lisp process. This frame cannot be reused." ;; ---- ;; Actually, the code below repaints the entire frame. ;; Shouldn't we free wrect? JPM. + ;; --- + ;; Don't signal errors for UpdateWindow, just warn. JPM 3/19/99. (or (win:getClientRect handle wrect) (acl-clim::check-last-error "GetClientRect")) (or (win:InvalidateRect handle wrect 1) (acl-clim::check-last-error "InvalidateRect")) (or (win:UpdateWindow handle) - (acl-clim::check-last-error "UpdateWindow")))))) + (acl-clim::check-last-error "UpdateWindow" :action :warn)))))) ;; Obsolete I think. (defun clean-frame (frame) diff --git a/aclpc/acl-medium.lisp b/aclpc/acl-medium.lisp index 51a88120..2d31eef5 100644 --- a/aclpc/acl-medium.lisp +++ b/aclpc/acl-medium.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: acl-medium.lisp,v 1.10 1999/02/25 08:23:24 layer Exp $ +;; $Id: acl-medium.lisp,v 1.11 1999/05/04 01:21:00 layer Exp $ #|**************************************************************************** * * @@ -90,9 +90,6 @@ (setf window nil)) nil) -;; changed the select-acl-dc method to specialize on acl-medium rather -;; than acl-window-medium (sdj 9/27/96) - (defmethod select-acl-dc ((medium acl-medium) window dc) (declare (ignore window)) (let* ((sheet (medium-sheet medium)) @@ -186,13 +183,13 @@ (setf (gethash ink cache) (let ((color (color->wincolor ink medium))) (declare (fixnum color)) - (let ((pen (win:createPen win:ps_solid 1 color)) - (brush (win:createSolidBrush color))) + (let ((pen (win:CreatePen win:ps_solid 1 color)) + (brush (win:CreateSolidBrush color))) (make-dc-image :solid-1-pen pen :brush brush :text-color color :background-color nil - :rop2 win:r2_copypen + :rop2 win:R2_COPYPEN ))))))) ;;; ink for opacities, regions, etc @@ -239,20 +236,21 @@ (bcolor (color->wincolor bink medium)) (width (array-dimension array 1)) (height (array-dimension array 0)) - (into (make-pixel-map width height 256))) + (bits-per-pixel 8) + (into (make-pixel-map width height (expt 2 bits-per-pixel)))) (dotimes (i height) (dotimes (j width) (setf (aref into i j) (aref array i j)))) (setf *bitmap-array* into) - (with-medium-dc (medium dc) - (let* ((bitmapinfo (get-bitmapinfo medium dc-image into designs)) - (bitmap (get-texture dc into bitmapinfo))) - ;; To Do: replace BITMAP with INTO and just use - ;; device-independent bitmap operations. - (setf (dc-image-bitmap dc-image) bitmap - *created-bitmap* bitmap) - (setf (dc-image-background-color dc-image) bcolor) - (setf (dc-image-text-color dc-image) tcolor))) + (let* ((bitmapinfo (get-bitmapinfo medium dc-image into designs)) + (dc (win:GetDC 0)) + (bitmap (get-texture dc into bitmapinfo))) + ;; To Do: replace BITMAP with INTO and just use + ;; device-independent bitmap operations. + (setf (dc-image-bitmap dc-image) bitmap + *created-bitmap* bitmap) + (setf (dc-image-background-color dc-image) bcolor) + (setf (dc-image-text-color dc-image) tcolor)) dc-image)) (defun dc-image-for-transparent-pattern (medium ink array designs) @@ -265,7 +263,8 @@ (bcolor (color->wincolor bink medium)) (width (array-dimension array 1)) (height (array-dimension array 0)) - (into (make-pixel-map width height 256))) + (bits-per-pixel 8) + (into (make-pixel-map width height (expt 2 bits-per-pixel)))) (when (eq tink +transparent-ink+) (rotatef tink bink) (rotatef tcolor bcolor)) @@ -273,23 +272,23 @@ (dotimes (j width) (setf (aref into i j) (aref array i j)))) (setf *bitmap-array* into) - (with-medium-dc (medium dc) - (let* ((bitmapinfo (get-bitmapinfo medium dc-image into designs)) - (bitmap (get-texture dc into bitmapinfo))) - ;; To Do: replace BITMAP with INTO and just use - ;; device-independent bitmap operations. - (setf (dc-image-bitmap dc-image) bitmap - *created-bitmap* bitmap) - (setf (dc-image-background-color dc-image) bcolor) - (setf (dc-image-text-color dc-image) tcolor))) + (let* ((bitmapinfo (get-bitmapinfo medium dc-image into designs)) + (dc (win:GetDC 0)) + (bitmap (get-texture dc into bitmapinfo))) + ;; To Do: replace BITMAP with INTO and just use + ;; device-independent bitmap operations. + (setf (dc-image-bitmap dc-image) bitmap + *created-bitmap* bitmap) + (setf (dc-image-background-color dc-image) bcolor) + (setf (dc-image-text-color dc-image) tcolor)) dc-image)) (defun byte-align-pixmap (a) - ;; Pad the pixmap so that the y dimension is a multiple of 8. + ;; Pad the pixmap so that the y dimension is a multiple of 4. ;; This copies the array, so you oughta cache the result. (let* ((x-dim (array-dimension a 0)) (y-dim (array-dimension a 1)) - (new-y-dim (* 8 (floor (/ (+ y-dim 7) 8)))) + (new-y-dim (* 4 (ceiling y-dim 4))) (b nil)) (cond ((= y-dim new-y-dim) a) ; already aligned (t @@ -300,25 +299,11 @@ (if (>= y y-dim) 0 (aref a x y))))) b)))) -(defun byte-align-bits (a) - ;; Pad the pixmap so that the y dimension is a multiple of 8. - ;; This copies the array, so you oughta cache the result. - (let* ((x-dim (array-dimension a 0)) - (y-dim (array-dimension a 1)) - (new-y-dim (* 8 (floor (/ (+ y-dim 7) 8)))) - (b (make-array (list x-dim new-y-dim) - :element-type 'bit - :initial-element 0))) - (dotimes (col new-y-dim) - (dotimes (row x-dim) - (setf (aref b row col) - (if (>= col y-dim) 0 (if (zerop (aref a row col)) 0 1))))) - b)) - (defun pattern-to-hatchbrush (pattern) (multiple-value-bind (array designs) (decode-pattern pattern) - (let* ((tcolor (position-if #'(lambda (ink) (not (eq ink +transparent-ink+))) - designs)) + (let* ((tcolor (position-if + #'(lambda (ink) (not (eq ink +transparent-ink+))) + designs)) (style nil)) (unless tcolor (return-from pattern-to-hatchbrush nil)) (when (and (> (array-dimension array 0) 1) @@ -421,15 +406,12 @@ draw icons and mouse cursors on the screen. (null (dc-image-bitmap image1)) (null (dc-image-bitmap image2))) (nyi)) - (let ((pen (win:createPen win:ps_solid 1 color)) - (brush (win:createSolidBrush color))) + (let ((pen (win:CreatePen win:PS_SOLID 1 color)) + (brush (win:CreateSolidBrush color))) (make-dc-image :solid-1-pen pen :brush brush - :rop2 win:r2_xorpen - ;; I don't know why but text drawn - ;; in this ink is invisible if you - ;; use COLOR as the text color. JPM 7/98. - :text-color 0 ;color + :rop2 win:R2_XORPEN + :text-color color :background-color nil)))))))) (defmethod dc-image-for-ink ((medium acl-medium) (ink contrasting-ink)) @@ -498,6 +480,14 @@ draw icons and mouse cursors on the screen. (selectobject dc old)))))) (defmethod medium-draw-lines* ((medium acl-medium) position-seq) + #+slow-but-sure + (let (oldx oldy) + (silica:map-position-sequence + #'(lambda (x y) + (when oldx + (clim:medium-draw-line* medium oldx oldy x y)) + (setq oldx x oldy y)) + position-seq)) (let ((window (medium-drawable medium)) (old nil)) (with-medium-dc (medium dc) @@ -508,18 +498,16 @@ draw icons and mouse cursors on the screen. (ink (medium-ink medium)) (line-style (medium-line-style medium))) (set-dc-for-ink dc medium ink line-style) - (do ((i 0 (+ i 4)) - (j 1 (+ j 4)) - (k 2 (+ k 4)) - (l 3 (+ l 4))) - ((>= i (length position-seq))) - (let ((x1 (elt position-seq i)) - (y1 (elt position-seq j)) - (x2 (elt position-seq k)) - (y2 (elt position-seq l))) - (convert-to-device-coordinates transform x1 y1 x2 y2) - (win:moveToEx dc x1 y1 null) - (win:lineTo dc x2 y2))) + (let ((init t)) + (silica:map-position-sequence + #'(lambda (x y) + (convert-to-device-coordinates transform x y) + (cond (init + (win:moveToEx dc x y null) + (setq init nil)) + (t + (win:lineTo dc x y)))) + position-seq)) (selectobject dc old)))))) (defmethod medium-draw-rectangle* ((medium acl-medium) @@ -595,7 +583,9 @@ draw icons and mouse cursors on the screen. (defmethod medium-draw-polygon* ((medium acl-medium) position-seq closed filled) (let ((window (medium-drawable medium)) + (length (length position-seq)) (old nil)) + (assert (evenp length)) (with-medium-dc (medium dc) (setq old (select-acl-dc medium window dc)) (when old @@ -605,34 +595,41 @@ draw icons and mouse cursors on the screen. (line-style (and (not filled) (medium-line-style medium))) (length (length position-seq)) (numpoints (floor length 2)) - (extra (and closed line-style)) - (point-vector (ct:callocate (:long *) :size 512))) ; limit? - ;; These really are fixnums, since we're fixing coordinates below - ;; (declare (type fixnum minx miny)) - (with-stack-array (points (if extra (+ length 2) length)) - (declare (type simple-vector points)) - (replace points position-seq) ;set up the initial contents - (do ((i 0 (+ i 2)) - (j 0 (+ j 1))) - ((>= i length)) - (let ((x (svref points i)) - (y (svref points (1+ i)))) - (convert-to-device-coordinates transform x y) - (ct:cset (:long 512) point-vector ((fixnum (* j 2))) x) - (ct:cset (:long 512) point-vector ((fixnum (+ 1 (* j 2)))) y) - (when (and (= j 0) extra) - (ct:cset (:long 512) point-vector ((fixnum (* numpoints 2))) x) - (ct:cset (:long 512) point-vector ((fixnum (+ 1 (* numpoints 2)))) y) - )))) + (point-vector nil) + (i 0)) + (when (and closed (not filled)) + (incf length 2) + (incf numpoints)) + (setq point-vector (ff:allocate-fobject `(:array :long ,length))) + (silica:map-position-sequence + #'(lambda (x y) + (convert-to-device-coordinates transform x y) + (setf (ff:fslot-value-typed '(:array :long 1) :foreign + point-vector i) + (truncate x)) + (incf i) + (setf (ff:fslot-value-typed '(:array :long 1) :foreign + point-vector i) + (truncate y)) + (incf i)) + position-seq) + (when (and closed (not filled)) + (setf (ff:fslot-value-typed '(:array :long 1) :foreign + point-vector i) + (ff:fslot-value-typed '(:array :long 1) :foreign + point-vector 0)) + (incf i) + (setf (ff:fslot-value-typed '(:array :long 1) :foreign + point-vector i) + (ff:fslot-value-typed '(:array :long 1) :foreign + point-vector 1)) + (incf i)) (set-dc-for-ink dc medium ink line-style) - (if (null line-style) + (if filled (win:polygon dc point-vector numpoints) - (win:polyline dc - point-vector - (if (and closed line-style) - (+ numpoints 1) - numpoints))) - (selectobject dc old)))))) + (win:polyline dc point-vector numpoints)) + (selectobject dc old) + t))))) (defconstant *ft* 0.0001) (defun-inline fl-= (x y) (< (abs (- x y)) *ft*)) @@ -708,44 +705,137 @@ draw icons and mouse cursors on the screen. ;; This is not supposed to try to draw multiline text. ;; For that, use WRITE-STRING. (declare (ignore transform-glyphs)) - (let ((window (medium-drawable medium)) - (old nil)) + (unless end (setq end (length string))) + (let* ((transform (sheet-device-transformation (medium-sheet medium)))) + (convert-to-device-coordinates transform x y) + (when towards-x + (convert-to-device-coordinates transform towards-x towards-y))) + (let* ((port (port medium)) + (text-style (medium-merged-text-style medium)) + (font (text-style-mapping port text-style)) + (window (medium-drawable medium)) + (ink (medium-ink medium)) + (old nil) + (font-angle (pos-to-font-angle x y towards-x towards-y)) + (x-adjust + (compute-text-x-adjustment align-x medium + string text-style start end)) + (y-adjust + (compute-text-y-adjustment align-y (acl-font-descent font) + (acl-font-ascent font) (acl-font-height font)))) + (incf x x-adjust) + (incf y y-adjust) + (when towards-x + (incf towards-x x-adjust) + (incf towards-y y-adjust)) + (cond ((zerop font-angle) + (decf y (acl-font-ascent font))) ;text is positioned by its top left + (t + (setq font + (port-find-rotated-font port font font-angle)))) + (if (typep ink 'clim-utils:flipping-ink) + (medium-draw-inverted-string* medium string x y start end font text-style) + (with-medium-dc (medium dc) + (setq old (select-acl-dc medium window dc)) + (when old + (with-temporary-substring (substring string start end) + (set-dc-for-text dc medium ink (acl-font-index font)) + (multiple-value-bind (cstr len) + (silica::xlat-newline-return substring) + (or + (excl:with-native-string (cstr cstr) + (win:TextOut dc x y cstr len)) + (check-last-error "TextOut" :action :warn)))) + (selectobject dc old)))))) + +(defmethod medium-draw-inverted-string* ((medium acl-medium) + string x y start end font text-style) + ;; This function should be used when the ink is flipping-ink. + ;; Strings cannot be drawn by calling (SetROP2 dc R2_XORPEN). + ;; This has no effect on TextOut. To get the same effect, + ;; draw the string into a bitmap and draw the bitmap onto the screen. + (let (old + (window (medium-drawable medium)) + (width 100) + (height 100)) + (multiple-value-setq (width height) + (text-size medium string :text-style text-style + :start start :end end)) (with-medium-dc (medium dc) (setq old (select-acl-dc medium window dc)) (when old - (let* ((sheet (medium-sheet medium)) - (transform (sheet-device-transformation sheet)) - (ink (medium-ink medium)) - (text-style (medium-merged-text-style medium))) - (convert-to-device-coordinates transform x y) - (when towards-x - (convert-to-device-coordinates transform towards-x towards-y)) - (unless end - (setq end (length string))) - (with-temporary-substring (substring string start end) - (let* ((font (text-style-mapping (port medium) text-style)) - (height (acl-font-height font)) - (descent (acl-font-descent font)) - (ascent (acl-font-ascent font))) - (let ((x-adjust - (compute-text-x-adjustment align-x medium - string text-style start end)) - (y-adjust - (compute-text-y-adjustment align-y descent - ascent height))) - (incf x x-adjust) - (incf y y-adjust) - (when towards-x - (incf towards-x x-adjust) - (incf towards-y y-adjust))) - (decf y ascent) ;;text is positioned by its top left - (set-dc-for-text dc medium ink (acl-font-index font)) - (multiple-value-bind (cstr len) - (silica::xlat-newline-return substring) - (or (win:textOut dc x y cstr len) - (check-last-error "TextOut" :action :warn)) - ))) - (selectobject dc old)))))) + (with-temporary-substring (substring string start end) + (let* ((cdc (win:CreateCompatibleDC dc)) + (hbm (win:CreateCompatibleBitmap cdc width height)) + (oldbm nil)) + (setq oldbm (win:SelectObject cdc hbm)) + ;; Set the bitmap to black, then draw the text in white. + (set-dc-for-text cdc medium +black+ (acl-font-index font)) + (win:rectangle cdc 0 0 width height) + (win:SetTextColor dc 0) ; white + (set-dc-for-text cdc medium +white+ (acl-font-index font)) + (multiple-value-bind (cstr len) + (silica::xlat-newline-return substring) + (or + (excl:with-native-string (cstr cstr) + (win:TextOut cdc 0 0 cstr len)) + (check-last-error "TextOut" :action :warn)) + ) + ;; Copy bitmap from memory dc to screen dc + (win:BitBlt dc x y width height + cdc 0 0 win:SRCINVERT) + ;; Restore the old bitmap + (win:SelectObject cdc oldbm) + ;; Delete the bitmap + (win:DeleteObject hbm) + ;; Delete memory dc + (win:DeleteDC cdc))) + (selectobject dc old))) + nil)) + +;;; Enhance the bounding-box calculation for rotated text. +(defmethod clim-internals::medium-text-bounding-box :around + ((medium acl-window-medium) string x y + start end align-x align-y text-style + towards-x towards-y transform-glyphs transformation) + align-x align-y transform-glyphs transformation + (let ((font-angle nil)) + (cond ((and (or towards-x towards-y) + (not (= (setq font-angle + (pos-to-font-angle x y + (or towards-x x) + (or towards-y y))) + 0))) + ;;; This is sort of expecnsive, but it + ;;; should only happen when the text is + ;;; drawn the first time. + (setq towards-x (or towards-x x)) + (setq towards-y (or towards-y y)) + ;;; Recall, font-angle is in 1/10 dgs. + (let* ((font-angle-rad (* font-angle #.(/ pi (* -180 10)))) + (width (stream-string-width (medium-sheet medium) string + :start start :end end + :text-style text-style)) + (ascent (text-style-ascent text-style medium)) + (descent (text-style-descent text-style medium)) + (height (+ ascent descent)) + (transf (make-rotation-transformation* font-angle-rad x y))) + (multiple-value-bind (xtr ytr) ;;; top-right corner + (transform-position transf (+ x width) y) + (multiple-value-bind (xbr ybr) ;;; bottom-right corner + (transform-position transf (+ x width) (+ y height)) + (multiple-value-bind (xbl ybl) ;;; bottom-left corner + (transform-position transf x (+ y height)) + (values (coordinate (min x xtr xbr xbl)) + (coordinate (min y ytr ybr ybl)) + (coordinate (max x xtr xbr xbl)) + (coordinate (max y ytr ybr ybl)) + ;;; None of the following seems to be + ;;; used, but... + (coordinate x) (coordinate y) + towards-x towards-y)))))) + (t + (call-next-method))))) (defmethod medium-draw-character* ((medium acl-medium) char x y align-x align-y @@ -780,7 +870,11 @@ draw icons and mouse cursors on the screen. (set-dc-for-text dc medium ink (acl-font-index font)) (let ((cstr (ct:callocate (:char *) :size 2))) (ct:cset (:char 2) cstr 0 (char-int char)) - (or (win:textOut dc x y cstr 1) + (or #+removed (win:textOut dc x y cstr 1) + (excl:with-native-string (cstr (make-string + 1 + :initial-element char)) + (win:TextOut dc x y cstr 1)) (check-last-error "TextOut" :action :warn))))) (selectobject dc old))))) diff --git a/aclpc/acl-mirror.lisp b/aclpc/acl-mirror.lisp index 2efcda6e..edad2328 100644 --- a/aclpc/acl-mirror.lisp +++ b/aclpc/acl-mirror.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: acl-mirror.lisp,v 1.8 1999/02/25 08:23:25 layer Exp $ +;; $Id: acl-mirror.lisp,v 1.9 1999/05/04 01:21:00 layer Exp $ #|**************************************************************************** * * @@ -295,8 +295,10 @@ (let ((window (sheet-mirror sheet))) (unless *in-layout-avp* (win:ShowWindow window win:SW_SHOW) ; returns NIL if it was already visible. + ;; Don't signal errors for UpdateWindow, just warn. JPM 3/19/99. (or (win:UpdateWindow window) ; send a WM_PAINT message - (check-last-error "UpdateWindow"))))) + (check-last-error "UpdateWindow" :action :warn)) + ))) (defmethod disable-mirror ((port acl-port) sheet) (win:ShowWindow (sheet-mirror sheet) win:SW_HIDE)) @@ -370,15 +372,19 @@ (values (coordinate 0) (coordinate 0) (- c a) (- d b)))) +(defvar *setting-sheet-mirror* nil) + (defmethod set-sheet-mirror-edges* ((port acl-port) sheet left top right bottom) ;; unspecialized (not top) (fix-coordinates left top right bottom) - (win:SetWindowPos (sheet-mirror sheet) - 0 ; we really want win:HWND_TOP - left top (- right left) (- bottom top) - (logior win:SWP_NOACTIVATE - win:SWP_NOZORDER))) + (unless (eq sheet *setting-sheet-mirror*) ; avoid recursion bug + (let ((*setting-sheet-mirror* sheet)) + (win:SetWindowPos (sheet-mirror sheet) + 0 ; we really want win:HWND_TOP + left top (- right left) (- bottom top) + (logior win:SWP_NOACTIVATE + win:SWP_NOZORDER))))) (defvar *port-mirror-sheet-alist* nil) @@ -529,8 +535,7 @@ ;; Set the "inside" size of a top-level sheet. ;; Top-level sheet has to account for sizes of window decorations. (fix-coordinates left top right bottom) - (multiple-value-bind (wleft wtop wright wbottom) (mirror-region* port -sheet) + (multiple-value-bind (wleft wtop wright wbottom) (mirror-region* port sheet) (when (and (= left wleft) (= top wtop) (= right wright) (= bottom wbottom)) ;; We seem to get infinite recursion if we don't check for this. diff --git a/aclpc/acl-port.lisp b/aclpc/acl-port.lisp index 08aa92f9..d3634c17 100644 --- a/aclpc/acl-port.lisp +++ b/aclpc/acl-port.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: acl-port.lisp,v 1.9 1999/02/25 08:23:25 layer Exp $ +;; $Id: acl-port.lisp,v 1.10 1999/05/04 01:21:00 layer Exp $ #|**************************************************************************** * * @@ -137,30 +137,35 @@ (define-constructor make-acl-event-queue queue () ) -;; reinstated the text-style->acl-font-mapping table (and commented -;; out font-cache-style/font slots) because we now need to have -;; multiple logical fonts open simultaneously for the life time of any -;; controls for which a :text-style is specified. Before, only the -;; Windows system font was being used and text-style-mapping was only -;; used to put stuff in device contexts which only lived inside a -;; with-dc - besides which the *original-font*, *created-font* logic -;; was suspect. (cim 10/14/96) - (defclass acl-port (basic-port) - ((dc-cache :initform (make-hash-table) :accessor port-dc-cache) - (text-style->acl-font-mapping :initform (make-hash-table)) + (;; Cache used by dc-image-for-ink for mapping inks to device contexts: + (dc-cache :initform (make-hash-table) :accessor port-dc-cache) + ;; Virtual key to keysym: (vk->keysym :initform (make-hash-table)) - (keysym->keysym :initform (make-hash-table)) + ;; Cached value of (win:GetDeviceCaps dc win:LOGPIXELSY) : logpixelsy + ;; Where window events get put: (event-queue :initform (make-acl-event-queue)) + ;; Most recently activated window or control: (mirror-with-focus :initform nil :accessor acl-port-mirror-with-focus) - (pointer-sheet :initform nil) - (motion-pending :initform nil) + ;; Cache used by realize-cursor: (cursor-cache :initform nil) + ;; Support for pointer grabbing: (grab-cursor :initform nil :accessor port-grab-cursor) + ;; Default foreground, background colors: (resources :initform nil :accessor port-default-resources) + ;; Four slots for cached pointer state: (pointer-x :initform 0) - (pointer-y :initform 0))) + (pointer-y :initform 0) + (pointer-sheet :initform nil) + (motion-pending :initform nil) + ;; Cached mapping of CLIM text styles to operating system fonts: + (text-style->acl-font-mapping :initform (make-hash-table)) + ;; Drawing text at an angle is implemented by asking the + ;; operating system to rotate a font to the required angle: + (rotated-font-htable :initform (make-hash-table) + :accessor port-rotated-font-htable) + )) (defmethod restart-port ((port acl-port)) ;; No need to devote a thread to receiving messages @@ -303,10 +308,131 @@ (:very-large 18) (:huge 24))) -;;--- hacked to allow text-styles to be specified as lists -;;--- there's probably a more efficient way... -(defmethod text-style-mapping ((port acl-port) (style list) - &optional (character-set *standard-character-set*) etc) +(defmethod port-find-rotated-font ((port acl-port) + plain-font font-rotation-angle) + ;; Find the rotated-font corresponding to plain-font + ;; rotated at the appropriate angle. + ;; If it doesn't exist, create it and cache a record + ;; of it. + (let ((htable (port-rotated-font-htable port))) + (let ((base-font-list (gethash plain-font htable))) + (let ((font-pair (and base-font-list + (find font-rotation-angle base-font-list + :test #'= + :key #'first)))) + (cond (font-pair + (second font-pair)) + (t + (let ((new-font (port-duplicate-rotated-windows-font + port plain-font font-rotation-angle))) + (push (list font-rotation-angle new-font) + (gethash plain-font htable)) + new-font))))))) + +(defmethod port-duplicate-rotated-windows-font + ((port acl-port) plain-font font-rotation-angle) + (let ((text-style (port-acl-font->text-style port plain-font))) + (cond (text-style + (text-style-mapping-1 + port text-style + :font-rotation-angle font-rotation-angle)) + (t + ;;; Make a best guess. + (let ((old-height (acl-font-height plain-font)) + (italic-flag (acl-font-italic plain-font)) + (underline-flag (acl-font-underlined plain-font)) + (weight-flag (acl-font-weight plain-font))) + (make-windows-font + old-height + :escapement font-rotation-angle + :orientation font-rotation-angle + :italic (not (= italic-flag 0)) + :underline (not (= underline-flag 0)) + :weight weight-flag + )))))) + +(defun pos-to-font-angle (x0 y0 x1 y1) + (let ((dx (if (null x1) 0 (- x1 x0))) + (dy (if (null y1) 0 (- y0 y1)))) + (cond ((= dy 0) + (if (< dx 0) + -1800 + 0)) + ((= dx 0) + (if (< dy 0) + -900 + 900)) + (t + (let* ((angfact #.(/ 180 pi)) + (ang (* (atan dy dx) angfact))) + (round (* 10 ang))))))) + +(defmethod port-acl-font->text-style ((port acl-port) acl-font) + (with-slots (text-style->acl-font-mapping) port + (when text-style->acl-font-mapping + (catch :font-found + (maphash #'(lambda (KEY VAL) + (if (eql VAL ACL-FONT) + (throw :font-found KEY))) + text-style->acl-font-mapping))))) + +(defmethod text-style-mapping-1 + ((port acl-port) (style text-style) &key font-rotation-angle) + (multiple-value-bind (weight italic) + (let ((face (text-style-face style))) + (typecase face + (cons + (values (if (member :bold face) win:FW_BOLD win:FW_NORMAL) + (member :italic face))) + (otherwise + (case face + (:roman (values win:FW_NORMAL nil)) + (:bold (values win:FW_BOLD nil)) + (:italic (values win:FW_NORMAL t)) + (otherwise (values win:FW_BOLD nil)))))) + (multiple-value-bind (family face-name) + (case (text-style-family style) + (:fix (values (logior win:FIXED_PITCH win:FF_MODERN) + #+ignore + "courier")) + (:serif (values (logior win:VARIABLE_PITCH win:FF_ROMAN) + "times new roman")) + (:sans-serif (values (logior win:VARIABLE_PITCH win:FF_SWISS) + "arial")) + ;;--- some of these specify ugly ugly linedrawn fonts + (otherwise (values (logior win:DEFAULT_PITCH win:FF_DONTCARE) + (string (text-style-family style))))) + (let ((size (text-style-size style)) + (point-size nil)) + (when (numberp size) + (setq point-size size)) + (unless point-size + (setq point-size + (second (assoc size *acl-logical-size-alist*)))) + (unless point-size + (format *trace-output* + "~& Warning: ~S does not specify size, using 12" style) + (setq point-size 12)) + (if font-rotation-angle + (make-windows-font + (- (round (* point-size (slot-value port 'logpixelsy)) 72)) + :weight weight + :italic italic + :pitch-and-family family + :face face-name + :escapement font-rotation-angle + :orientation font-rotation-angle) + (make-windows-font + (- (round (* point-size (slot-value port 'logpixelsy)) 72)) + :weight weight + :italic italic + :pitch-and-family family + :face face-name + )))))) + +(defmethod text-style-mapping + ((port acl-port) (style list) + &optional (character-set *standard-character-set*) etc) (text-style-mapping port (apply #'make-text-style style) character-set etc)) @@ -317,47 +443,7 @@ (with-slots (text-style->acl-font-mapping) port (or (gethash style text-style->acl-font-mapping) (setf (gethash style text-style->acl-font-mapping) - (multiple-value-bind (weight italic) - (let ((face (text-style-face style))) - (typecase face - (cons - (values (if (member :bold face) win:FW_BOLD win:FW_NORMAL) - (member :italic face))) - (otherwise - (case face - (:roman (values win:FW_NORMAL nil)) - (:bold (values win:FW_BOLD nil)) - (:italic (values win:FW_NORMAL t)) - (otherwise (values win:FW_BOLD nil)))))) - (multiple-value-bind (family face-name) - (case (text-style-family style) - (:fix (values (logior win:FIXED_PITCH win:FF_MODERN) - #+ignore - "courier")) - (:serif (values (logior win:VARIABLE_PITCH win:FF_ROMAN) - "times new roman")) - (:sans-serif (values (logior win:VARIABLE_PITCH win:FF_SWISS) - "arial")) - ;;--- some of these specify ugly ugly linedrawn fonts - (otherwise (values (logior win:DEFAULT_PITCH win:FF_DONTCARE) - (string (text-style-family style))))) - (let ((size (text-style-size style)) - (point-size nil)) - (when (numberp size) - (setq point-size size)) - (unless point-size - (setq point-size - (second (assoc size *acl-logical-size-alist*)))) - (unless point-size - (format *trace-output* - "~& Warning: ~S is not a known size, using 12" size) - (setq point-size 12)) - (make-windows-font - (- (round (* point-size (slot-value port 'logpixelsy)) 72)) - :weight weight - :italic italic - :pitch-and-family family - :face face-name)))))))) + (text-style-mapping-1 port style))))) (defmethod text-style-mapping ((device acl-port) (style silica::device-font) @@ -379,7 +465,8 @@ (array (make-array (1+ last-character)))) (loop for i from first-character to last-character do (setf (char string 0) (code-char i)) - (cond ((win:getTextExtentPoint dc string 1 tepsize) + (cond ((excl:with-native-string (string string) + (win:getTextExtentPoint dc string 1 tepsize)) (setf (aref array i) (ct:cref win:size tepsize cx))) (t ;; Why does this clause ever run? getlasterror=10035. @@ -411,21 +498,22 @@ win-font) (unless win-font (setq win-font - (win:createFont height ; logical height - width ; logical average width - escapement ; angle of escapement (tenths of degrees) - orientation ; normally the same as escapement - weight ; font weight (FW_NORMAL=400, FW_BOLD=700) - (if italic 1 0) - (if underline 1 0) - (if strikeout 1 0) - charset ; if you want chinese or greek - output-precision - clip-precision - quality - pitch-and-family - (or face "") - ))) + (excl:with-native-string (vface (or face "")) + (win:createFont height ; logical height + width ; logical average width + escapement ; angle of escapement (tenths of degrees) + orientation ; normally the same as escapement + weight ; font weight (FW_NORMAL=400, FW_BOLD=700) + (if italic 1 0) + (if underline 1 0) + (if strikeout 1 0) + charset ; if you want chinese or greek + output-precision + clip-precision + quality + pitch-and-family + vface + )))) (when (zerop win-font) (check-last-error "CreateFont")) (make-device-font win-font)) diff --git a/aclpc/acl-prel.lisp b/aclpc/acl-prel.lisp index a854f2a9..c68d07fc 100644 --- a/aclpc/acl-prel.lisp +++ b/aclpc/acl-prel.lisp @@ -15,7 +15,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: acl-prel.lisp,v 1.8 1999/02/25 08:23:25 layer Exp $ +;; $Id: acl-prel.lisp,v 1.9 1999/05/04 01:21:00 layer Exp $ #|**************************************************************************** * * @@ -46,23 +46,25 @@ (scroll-mode (combobox-scroll-bars items))) (declare (ignore id)) (let* ((hwnd - (win:CreateWindowEx - 0 ; extended-style - "COMBOBOX" ; classname - (nstringify label) ; windowname - (logior - (if (member scroll-mode '(:vertical :both t :dynamic)) - win:WS_VSCROLL - 0) - (if (member scroll-mode '(:horizontal :both t :dynamic)) - win:WS_HSCROLL - 0) - win:WS_CHILD - win:WS_TABSTOP - win:CBS_DROPDOWNLIST) - 0 0 0 0 - parent (ct::null-handle win::hmenu) - *hinst* (symbol-name (gensym))))) + (excl:with-native-string (x "COMBOBOX") + (excl:with-native-string (label (nstringify label)) + (win:CreateWindowEx + 0 ; extended-style + x ; classname + label ; windowname + (logior + (if (member scroll-mode '(:vertical :both t :dynamic)) + win:WS_VSCROLL + 0) + (if (member scroll-mode '(:horizontal :both t :dynamic)) + win:WS_HSCROLL + 0) + win:WS_CHILD + win:WS_TABSTOP + win:CBS_DROPDOWNLIST) + 0 0 0 0 + parent (ct::null-handle win::hmenu) + *hinst* (symbol-name (gensym))))))) (if (ct:null-handle-p hwnd hwnd) ;; failed (cerror "proceed" "failed") @@ -78,7 +80,8 @@ (dolist (item items) (setf item-name (funcall name-key item)) (incf index) - (win:SendMessage hwnd win:CB_INSERTSTRING index item-name) + (excl:with-native-string (item-name item-name) + (win:SendMessage hwnd win:CB_INSERTSTRING index item-name)) )) (win:SendMessage hwnd win:CB_SETCURSEL (or value 0) 0) (win:SendMessage hwnd CB_SETTOPINDEX (or value 0) 0))) @@ -121,15 +124,17 @@ win:WS_CLIPSIBLINGS)) (exstyle win:WS_EX_CLIENTEDGE) (hwnd - (win:CreateWindowEx exstyle - "LISTBOX" ; classname - (nstringify label) ; windowname - style - 0 0 0 0 - parent - (ct::null-handle win::hmenu) - *hinst* - (symbol-name (gensym))))) + (excl:with-native-string (classname "LISTBOX") + (excl:with-native-string (windowname (nstringify label)) + (win:CreateWindowEx exstyle + classname ; classname + windowname ; windowname + style + 0 0 0 0 + parent + (ct::null-handle win::hmenu) + *hinst* + (symbol-name (gensym))))))) (if (ct:null-handle-p hwnd hwnd) ;; failed (cerror "proceed" "failed") @@ -152,7 +157,8 @@ (ct:cset (:char 256) cstr ((fixnum i)) (char-int (char item-name i)))) (incf index) - (win:SendMessage hwnd win:LB_INSERTSTRING index item-name) + (excl:with-native-string (item-name item-name) + (win:SendMessage hwnd win:LB_INSERTSTRING index item-name)) )) (if (eq mode :nonexclusive) (let ((i 0)) @@ -186,21 +192,23 @@ (defun scrollbar-open (parent left top width height orientation) (let* ((hwnd - (win:CreateWindowEx - 0 ; style - "SCROLLBAR" ; classname - (nstringify "") ; windowname - (logior (if (eql orientation :horizontal) - win::SBS_HORZ win::SBS_VERT) - win::WS_CHILD - win::WS_BORDER - win::WS_CLIPCHILDREN - win::WS_CLIPSIBLINGS) ; style - 0 0 0 0 ; x, y, width, height - parent - (ct:null-handle win::hmenu) - *hinst* - (symbol-name (gensym))))) + (excl:with-native-string (classname "SCROLLBAR") + (excl:with-native-string (windowname (nstringify "")) + (win:CreateWindowEx + 0 ; style + classname ; classname + windowname ; windowname + (logior (if (eql orientation :horizontal) + win::SBS_HORZ win::SBS_VERT) + win::WS_CHILD + win::WS_BORDER + win::WS_CLIPCHILDREN + win::WS_CLIPSIBLINGS) ; style + 0 0 0 0 ; x, y, width, height + parent + (ct:null-handle win::hmenu) + *hinst* + (symbol-name (gensym))))))) (if (ct:null-handle-p hwnd hwnd) ;; failed (cerror "proceed" "failed") @@ -230,19 +238,21 @@ ;; Both push buttons and radio buttons are created here. (let* ((nlabel (cleanup-button-label label)) (hwnd - (win:CreateWindowEx 0 - "BUTTON" ; classname - (nstringify nlabel) ; windowname - (logior buttonstyle - win:WS_TABSTOP - win:WS_CHILD - win:WS_CLIPCHILDREN - win:WS_CLIPSIBLINGS) ; style - 0 0 0 0 - parent - (ct::null-handle win::hmenu) - *hinst* - (symbol-name (gensym))))) + (excl:with-native-string (classname "BUTTON") + (excl:with-native-string (windowname (nstringify nlabel) ) + (win:CreateWindowEx 0 + classname ; classname + windowname ; windowname + (logior buttonstyle + win:WS_TABSTOP + win:WS_CHILD + win:WS_CLIPCHILDREN + win:WS_CLIPSIBLINGS) ; style + 0 0 0 0 + parent + (ct::null-handle win::hmenu) + *hinst* + (symbol-name (gensym))))))) (if (ct:null-handle-p hwnd hwnd) ;; failed (cerror "proceed" "failed") @@ -266,37 +276,40 @@ (scroll-mode nil)) (declare (ignore id)) (let* ((hwnd - (win:CreateWindowEx - win:WS_EX_CLIENTEDGE - "EDIT" ; classname - (nstringify label) ; windowname - (logior editstyle - win:WS_CHILD - win:WS_BORDER - win:WS_TABSTOP - (if (member scroll-mode '(:horizontal :both t :dynamic)) - win:WS_HSCROLL - 0) - (if (member scroll-mode '(:vertical :both t :dynamic)) - win:WS_VSCROLL - 0) + (excl:with-native-string (classname "EDIT") + (excl:with-native-string (windowname (nstringify label)) + (win:CreateWindowEx + win:WS_EX_CLIENTEDGE + classname ; classname + windowname ; windowname + (logior editstyle + win:WS_CHILD + win:WS_BORDER + win:WS_TABSTOP + (if (member scroll-mode '(:horizontal :both t :dynamic)) + win:WS_HSCROLL + 0) + (if (member scroll-mode '(:vertical :both t :dynamic)) + win:WS_VSCROLL + 0) - win:WS_CLIPCHILDREN - win:WS_CLIPSIBLINGS) ; style - 0 0 0 0 - parent - (ct::null-handle win::hmenu) - *hinst* - (symbol-name (gensym))))) + win:WS_CLIPCHILDREN + win:WS_CLIPSIBLINGS) ; style + 0 0 0 0 + parent + (ct::null-handle win::hmenu) + *hinst* + (symbol-name (gensym))))))) (if (ct:null-handle-p hwnd hwnd) ;; failed (cerror "proceed" "failed") ;; else succeed if we can init the DC (progn (if (stringp value) - (win:SetWindowText - hwnd - (silica::xlat-newline-return value))) + (excl:with-native-string (s1 (silica::xlat-newline-return value)) + (win:SetWindowText + hwnd + s1))) ;; Override the default window proc. (progn ;+++ (setf std-ctrl-proc-address @@ -365,19 +378,60 @@ (defmethod get-texture (device-context pixel-map bitmapinfo) ;; The value of this function becomes the dc-image-bitmap. ;; It gets applied to the device context using SELECT-OBJECT. - (unless (and device-context (not (zerop device-context))) - (error "Device context not valid")) - (let* (texture-handle) - ;; Create nondiscardable Device Dependent Bitmap. - ;; The Windows docs suggest we should be using device independent bitmaps. - (setq texture-handle - (win:CreateDIBitmap - device-context - bitmapinfo - win:CBM_INIT ; initialize bitmap bits - pixel-map - bitmapinfo - win:DIB_RGB_COLORS)) + ;; Pixel-map is an array of integers. The element type is + ;; specific to bits-per-pixel specified in the BMP file. + ;; + ;; Create nondiscardable Device Dependent Bitmap. + ;; The Windows docs suggest we should be using device independent bitmaps. + (let* ((dc (win:GetDC 0)) + (texture-handle + (win:CreateDIBitmap + dc + bitmapinfo + win:CBM_INIT ; initialize bitmap bits + pixel-map + bitmapinfo + win:DIB_RGB_COLORS))) + (when (zerop texture-handle) + ;;Below is Charley Cox's May 6 message from bug5991 (common graphics) + ;; + ;;The workaround I have installed to open-texture (the only place that + ;;calls CreateDIBitmap) occurs when an initial call to CreateDIBitmap + ;;fails. If a failure occurs, open-texture does an on-the-spot copy of + ;;the pixmap array into a malloc'd block and then tries calling + ;;CreateDIBitmap again. Afterwards, it frees the malloc'd block. + ;; + ;;This workaround has fixed all the failure cases I was able to + ;;reproduce, and I have not seen any failures since its installation. I + ;;have also since not seen any StretchDIBits failures. + ;; + ;;I'm not really happy not knowing what was causing CreateDIBitmap's + ;;failure. The GetLastError code was not being set, and single stepping + ;;all the way through did not reveal anything. It's possible we may + ;;revisit this in the future. + (let (width height bits-per-pixel) + (let ((d (array-dimensions pixel-map))) + (setq width (first d) height (second d))) + (setq bits-per-pixel 8) ; kludge + (let* ((image-size + ;; Formula from msdn document: SAMPLE: DIBs and Their Uses + (* (ash + (logand (+ (* width bits-per-pixel) 31) + #.(lognot 31)) + -3) + height)) + (malloc-texture-array + (ff:allocate-fobject `(:array :char ,image-size) :c))) + (unless (zerop malloc-texture-array) + (memcpy malloc-texture-array pixel-map image-size)) + (setq texture-handle + (win:CreateDIBitmap + device-context + bitmapinfo + win:CBM_INIT ; initialize bitmap bits + pixel-map + bitmapinfo + win:DIB_RGB_COLORS))))) (when (zerop texture-handle) (check-last-error "CreateDIBitmap")) texture-handle)) @@ -485,3 +539,4 @@ (values (funcall parser string) string)))) (win:CloseClipboard)) (check-last-error "OpenClipboard"))) + diff --git a/aclpc/acl-widget.lisp b/aclpc/acl-widget.lisp index 231e7d45..20675f68 100644 --- a/aclpc/acl-widget.lisp +++ b/aclpc/acl-widget.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: acl-widget.lisp,v 1.11 1999/02/25 08:23:25 layer Exp $ +;; $Id: acl-widget.lisp,v 1.12 1999/05/04 01:21:00 layer Exp $ #|**************************************************************************** * * @@ -178,7 +178,8 @@ (let ((str (acl-clim::nstringify (funcall name-key item))) (pos (position item items))) ;;(break "insert gadget item [~a @ ~a]" str pos) - (win:SendMessage mirror win:LB_INSERTSTRING pos str))) + (excl:with-native-string (str str) + (win:SendMessage mirror win:LB_INSERTSTRING pos str)))) (win:InvalidateRect mirror ct:hnull win:TRUE)))) ;; make sure it updates (defmethod acl-clim::command-event :around ((gadget hlist-pane) @@ -375,7 +376,8 @@ ;; Don't redraw till I tell you: (win:SendMessage mirror win:WM_SETREDRAW 0 0) ;; Here's the text: - (win:SetWindowText mirror (xlat-newline-return new)) + (excl:with-native-string (s1 (xlat-newline-return new)) + (win:SetWindowText mirror s1)) ;; Try to preserve the scroll position: (win:SendMessage mirror win:EM_LINESCROLL leftchar topline) ;; Redraw now: @@ -388,10 +390,12 @@ (let* ((wl (win:SendMessage mirror win:WM_GETTEXTLENGTH 0 0)) - (teb (make-string wl)) + (teb + #+removed (make-string wl) + (make-array wl :element-type '(unsigned-byte 8))) (tlen (win:GetWindowText mirror teb (1+ wl)))) (declare (ignorable tlen)) - (setf teb (unxlat-newline-return teb)) + (setf teb (unxlat-newline-return (excl:mb-to-string teb))) (setf value teb) ;; By the way, does anyone know why ;; the second value is returned? -smh @@ -606,7 +610,8 @@ (defmethod (setf gadget-label) :after (str (pane hpbutton-pane)) (with-slots (mirror) pane (when mirror - (win:SetWindowText mirror str)))) + (excl:with-native-string (str str) + (win:SetWindowText mirror str))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -809,7 +814,8 @@ (let ((str (acl-clim::nstringify (funcall name-key item))) (pos (position item items))) ;;(break "insert gadget item [~a @ ~a]" str pos) - (win:SendMessage mirror win:CB_INSERTSTRING pos str))) + (excl:with-native-string (str str) + (win:SendMessage mirror win:CB_INSERTSTRING pos str)))) ;; make sure it updates (win:InvalidateRect mirror ct:hnull win:TRUE) (note-sheet-region-changed pane)))) @@ -1325,15 +1331,17 @@ (exstyle win:WS_EX_CLIENTEDGE) (window nil)) (setq window - (win:CreateWindowEx exstyle - *clim-class* - *win-name* - winstyle - left top width height - (or parent 0) - 0 ; menu - *hinst* - (symbol-name (gensym)) )) + (excl:with-native-string (*clim-class* *clim-class*) + (excl:with-native-string (*win-name* *win-name*) + (win:CreateWindowEx exstyle + *clim-class* + *win-name* + winstyle + left top width height + (or parent 0) + 0 ; menu + *hinst* + (symbol-name (gensym)) )))) (when (zerop window) (or (check-last-error "CreateWindowEx") (error "CreateWindowEx: unknown error"))) diff --git a/aclpc/pkgdcl.lisp b/aclpc/pkgdcl.lisp index ac64317d..24b9791f 100644 --- a/aclpc/pkgdcl.lisp +++ b/aclpc/pkgdcl.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: pkgdcl.lisp,v 1.4 1999/02/25 08:23:27 layer Exp $ +;; $Id: pkgdcl.lisp,v 1.5 1999/05/04 01:21:01 layer Exp $ (in-package :common-lisp-user) @@ -30,8 +30,9 @@ ;;(require :for) ; for FOR macro (require :winapi) (require :winapi-dev) - (load "user32.dll") - + ;; Kevin: (FEATUREP (:VERSION>= 5 (0 1) :PRE-BETA2)) throws an error + (or (ignore-errors (load "user32.dll" :system-library t)) + (load "user32.dll")) ;; Turn this off as long as clim-utils is a locked package. (setq excl:*enable-package-locked-errors* nil) ) diff --git a/aclpc/winwidgh.lisp b/aclpc/winwidgh.lisp index 7b2fd033..5b8c8be3 100644 --- a/aclpc/winwidgh.lisp +++ b/aclpc/winwidgh.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: winwidgh.lisp,v 1.5 1999/02/25 08:23:27 layer Exp $ +;; $Id: winwidgh.lisp,v 1.6 1999/05/04 01:21:03 layer Exp $ (in-package :acl-clim) @@ -95,3 +95,7 @@ (ff:def-foreign-call (CallNextHookEx "CallNextHookExA") ((a :int) (b :int) (c :int) (d :int)) :returning :int) + +(ff:def-foreign-call memcpy + ((to (* :char)) (from (* :char)) (nbytes :int)) + :returning :int) diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index 5737e3ab..997d3e4e 100644 --- a/clim/accept-values.lisp +++ b/clim/accept-values.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: accept-values.lisp,v 1.85 1999/02/25 08:23:27 layer Exp $ +;; $Id: accept-values.lisp,v 1.86 1999/05/04 01:21:03 layer Exp $ (in-package :clim-internals) @@ -1670,21 +1670,22 @@ (updating-output (stream :unique-id query-identifier :id-test #'equal :cache-value (cons active-p cache-value) :cache-test #'(lambda (x y) - (and (eq (car x) (car y)) + (and (consp x) (consp y) + (eq (car x) (car y)) (funcall cache-test (cdr x) (cdr y))))) (labels ((update-gadget (record gadget) - (declare (ignore record)) ;;-- This sucks - (setf (gadget-label gadget) (compute-prompt)) - (if active-p - (activate-gadget gadget) - (deactivate-gadget gadget))) + (declare (ignore record)) ;;-- This sucks + (setf (gadget-label gadget) (compute-prompt)) + (if active-p + (activate-gadget gadget) + (deactivate-gadget gadget))) (compute-prompt () (if (stringp prompt) prompt - ;;-- Does this suck or what??? - ;;-- If you do a - ;;surrounding-output-with-border without - ;;this write-string output does not get bordered. + ;;-- Does this suck or what??? + ;;-- If you do a + ;;surrounding-output-with-border without + ;;this write-string output does not get bordered. (let ((*original-stream* nil)) (apply #'pixmap-from-menu-item stream prompt #'funcall nil @@ -1692,30 +1693,30 @@ (view-gadget-initargs view))))) (doit (stream) (with-output-as-gadget (stream :update-gadget #'update-gadget) - (let ((record (stream-current-output-record (encapsulating-stream-stream stream))) - (client (make-instance 'accept-values-command-button - :continuation continuation - :documentation documentation - :resynchronize resynchronize))) - (make-pane-from-view - 'push-button - view () - :id record :client client - :activate-callback #'(lambda (button) - (when (accept-values-query-valid-p nil record) ;---can't be right - (let ((sheet (sheet-parent button))) - (process-command-event - sheet - (allocate-event 'presentation-event - :sheet sheet - :echo nil - :presentation-type 'command - :value `(com-avv-command-button ,client ,record) - :frame *application-frame*))))) - :label (compute-prompt) - :name :accept-values-command-button - :help-callback documentation - :active active-p))))) + (let ((record (stream-current-output-record (encapsulating-stream-stream stream))) + (client (make-instance 'accept-values-command-button + :continuation continuation + :documentation documentation + :resynchronize resynchronize))) + (make-pane-from-view + 'push-button + view () + :id record :client client + :activate-callback #'(lambda (button) + (when (accept-values-query-valid-p nil record) ;---can't be right + (let ((sheet (sheet-parent button))) + (process-command-event + sheet + (allocate-event 'presentation-event + :sheet sheet + :echo nil + :presentation-type 'command + :value `(com-avv-command-button ,client ,record) + :frame *application-frame*))))) + :label (compute-prompt) + :name :accept-values-command-button + :help-callback documentation + :active active-p))))) (let ((align-prompts (slot-value stream 'align-prompts))) (if align-prompts (formatting-row (stream) diff --git a/clim/frames.lisp b/clim/frames.lisp index cb196cab..17308959 100644 --- a/clim/frames.lisp +++ b/clim/frames.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: frames.lisp,v 1.92 1999/02/25 08:23:29 layer Exp $ +;; $Id: frames.lisp,v 1.93 1999/05/04 01:21:04 layer Exp $ (in-package :clim-internals) @@ -862,7 +862,8 @@ (frame-standard-output frame)))) (typecase si (output-protocol-mixin si) - (t (frame-top-level-sheet frame)))))) + (t (frame-top-level-sheet frame))))) + (*avv-refreshed* nil)) ;; The read-eval-print loop for applications... (letf-globally (((frame-actual-pointer-documentation-pane frame) *pointer-documentation-output*)) @@ -870,6 +871,12 @@ ;; Redisplay all the panes (catch-abort-gestures ("Return to ~A command level" (frame-pretty-name frame)) (redisplay-frame-panes frame) + (when (not *avv-refreshed*) + ;;; This needs to happen after the + ;;; call to redisplay-frame-panes + ;;; but only do it the first time. + (force-refresh-avv-streams FRAME) + (setq *avv-refreshed* t)) (when interactor (fresh-line *standard-input*) (if (stringp prompt) @@ -881,6 +888,24 @@ ;; Need this check in case the user aborted out of a command menu (when command (execute-frame-command frame command))))))))) + +(defmethod force-refresh-avv-streams (frame) + ;;; NOTE: Not using get-frame-pane-to-avv-stream-table. + ;;; Don't create the hashtable if it's not already there. + (let ((ht (frame-pane-to-avv-stream-table frame))) + (when ht + (maphash #'(lambda (pane pair) + pane + (let ((avv-stream (car pair)) + (avv-record (cdr pair))) + (and avv-stream + avv-record + (port avv-stream) + (sheet-medium avv-stream) + (redisplay avv-record + avv-stream + :check-overlapping t)))) + ht)))) ;; Generic because someone might want :BEFORE or :AFTER (defmethod frame-exit ((frame standard-application-frame)) @@ -1143,20 +1168,19 @@ ) (read-command (frame-command-table frame) :stream stream)) - -#+(or aclpc acl86win32) -(defvar *frame*) - (defmacro with-menu-disabled (frame &body body) #-mswindows (declare (ignore frame)) + #-mswindows `(progn ,@body) #+mswindows `(unwind-protect - (progn (enable-menu-items ,frame nil) ,@body) - (enable-menu-items ,frame t) - (setq *frame* ,frame)) - #-mswindows `(progn ,@body)) + (progn + (disable-all-menu-items ,frame) + ,@body) + (re-enable-menu-items ,frame))) (defmethod execute-frame-command ((frame standard-application-frame) command) + (apply (command-name command) (command-arguments command)) + #+ignore ;; from jeff on 4/8/99 (with-menu-disabled frame (apply (command-name command) (command-arguments command)))) diff --git a/clim/interactive-defs.lisp b/clim/interactive-defs.lisp index 9ce74255..d3d7fdbb 100644 --- a/clim/interactive-defs.lisp +++ b/clim/interactive-defs.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: interactive-defs.lisp,v 1.30 1998/08/06 23:15:58 layer Exp $ +;; $Id: interactive-defs.lisp,v 1.31 1999/05/04 01:21:05 layer Exp $ (in-package :clim-internals) @@ -228,7 +228,8 @@ (defvar *default-input-editing-stream-class* #+Allegro (excl:ics-target-case - (:+ics 'japanese-input-editing-stream) + (:+ics #+mswindows 'standard-input-editing-stream + #-mswindows 'japanese-input-editing-stream) (:-ics 'standard-input-editing-stream)) #-Allegro 'standard-input-editing-stream) diff --git a/demo/bitmap-editor.lisp b/demo/bitmap-editor.lisp index eb9f5b55..07076150 100644 --- a/demo/bitmap-editor.lisp +++ b/demo/bitmap-editor.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: bitmap-editor.lisp,v 1.22 1999/02/25 08:23:30 layer Exp $ +;; $Id: bitmap-editor.lisp,v 1.23 1999/05/04 01:21:05 layer Exp $ (in-package :clim-demo) @@ -84,16 +84,11 @@ "Delete Color" (delete-current-color frame))))))))) - (defun replace-current-color (frame) - (declare (ignore frame)) - ;;--- Exercise for the reader - ) + (notify-user frame "Bitmap editor operation not yet implemented")) (defun delete-current-color (frame) - (declare (ignore frame)) - ;;--- Exercise for the reader - ) + (notify-user frame "Bitmap editor operation not yet implemented")) (defun add-new-color (frame) (let ((fr (make-application-frame 'color-chooser))) diff --git a/instclimol.lisp b/instclimol.lisp deleted file mode 100644 index 864714c4..00000000 --- a/instclimol.lisp +++ /dev/null @@ -1,33 +0,0 @@ -;; -*- mode: common-lisp; package: system -*- -;; -;; -[Mon Jul 6 15:37:15 1998 by layer]- -;; -;; copyright (c) 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 -;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. -;; - -;; $Id: instclimol.lisp,v 1.11 1998/08/06 23:15:36 layer Exp $ - -;; -;; Load the OpenLook version of CLIM -;; - -(in-package :system) - -(load-application (require :climol) :devel system::*devel*) - -(format t "~&; Finished loading CLIM OL~%") -(force-output) diff --git a/make-symbolic-links.sh b/make-symbolic-links.sh deleted file mode 100644 index 22a6bd5a..00000000 --- a/make-symbolic-links.sh +++ /dev/null @@ -1,50 +0,0 @@ -#!/bin/sh -# -# $Header: /repo/cvs.copy/clim2/Attic/make-symbolic-links.sh,v 1.6 1997/05/31 01:00:23 tomj Exp $ -# -# make a tree of links -# - -# 'original' must be changed whenever the source tree is moved -# It must be a pathname accessible from any machine on the net - -original=/net/romeo/home1/tomj/clim2 -linkdir=$1 - -if test -z "$linkdir"; then - linkdir=. -fi - -echo "linking directory tree $linkdir to $original" - -# remove any existing links - -if test -d $linkdir; then - echo "$linkdir already exists - removing old links" - find $linkdir -type l -print | xargs /bin/rm -f -else - echo "creating $linkdir" - mkdir $linkdir -fi - -# create the directory tree - -for dir in `(cd $original; - find * -type d -a ! -name CVS -print)` ; do - if test ! -d $linkdir/$dir; then - echo "creating $linkdir/$dir" - mkdir $linkdir/$dir - fi -done - -# and now do the links - -echo "creating new links" - -for file in `(cd $original; - find * -type f ! -name .\* ! -name \*~ ! -name \#\*\# \ - -print \ - -o -name CVS -prune)` ; do - ln -s $original/$file $linkdir/$file -done - diff --git a/makedist.sh b/makedist.sh deleted file mode 100644 index 9d259e54..00000000 --- a/makedist.sh +++ /dev/null @@ -1,23 +0,0 @@ - -set -xe - -make clean -make RECORD_XREF_INFO=nil RECORD_SOURCE_FILE_INFO=nil CL=../src/lisp - -rm -fr dist temp.zip temp.exe -mkdir dist dist/code dist/src dist/src/clim dist/src/clim/demo -cp -p climnt.fasl climps.fasl climdemo.fasl climg.fasl dist/code -cp -p readme.win32 dist/clim221.txt -cp -p demo/*.lisp dist/src/clim/demo -cp -p buildclim.cl dist - -# next 2 for beta only: -cp -p ../src/winapi/winapi.fasl dist/code -cp -p ../src/winapi/winapi-dev.fasl dist/code - -/winzip/winzip32 -min -a -r -sclim.me -ex temp.zip dist -/winzipse/wzipse32 temp.zip -y -3 -win32 -le \ - -d "c:\Program Files\acl50b" -c notepad clim221.txt - -mv temp.zip clim221.zip -mv temp.exe clim221.exe diff --git a/readme.win32 b/readme.win32 deleted file mode 100644 index 0b1e8003..00000000 --- a/readme.win32 +++ /dev/null @@ -1,76 +0,0 @@ - CLIM 2.2.1 for ACL 5.0.beta - Windows 95 and NT 4.0 - -Files in this release: - -clim221.txt - This file. -code/climnt.fasl -code/climg.fasl -code/climps.fasl -code/climdemo.fasl - The above are the fasl files making up the product. -code/winapi.fasl -code/winapi-dev.fasl - The above are updated fasl with respect to 5.0.beta. -src/clim/demo/ - The source files to the CLIM demos. - -To use CLIM on Windows evaluate this form: - (require :climnt) - -To run the CLIM demos, evaluate these forms: - (require :climdemo) - (clim-demo:start-demo) - -There are several known problems with the current release. - -1. This version of CLIM only works in a case insensitive Lisp. We - hope to fix this for the final release. - -2. In this version, you must call run-frame-top-level in the same - thread or Lisp "process" that you call - make-application-frame. This is a limitation imposed by Windows - and is related to the way that SendMessage() must work. Windows - wants a window to be closely linked to the thread that created it. - This limitation is not present in UNIX versions of CLIM, and as a - result UNIX clim code may not run without some modification. An - error will be signalled if this constraint is violated. This - limitation was not present in the alpha release of CLIM for NT - because all Lisp "processes" ran in a single operating system - thread. - - For example, you must replace this: - (let ((frame (make-application-frame 'mine))) - (mp:process-run-function #'run-frame-top-level frame)) - - with something like this: - (mp:process-run-function - #'(lambda () - (run-frame-top-level (make-application-frame 'mine)))) - -Changes since the alpha release of CLIM: - -1. CLIM is not distributed as a Lisp image file anymore. It is - distributed as a set of fasl files. You can build a clim.dxl by - loading <acl dir>/buildclim.cl. It will create a clim.exe and - clim.dxl. You can then run CLIM by executing clim.exe. - - You can also build applications using generate-application and - putting the appropriate require's (of :climnt) in your sources. - -2. Windows 95 is supported. - -3. CLIM applications are about 10 megabytes smaller. - -4. CLIM follows more of the Windows User Interface guidelines. This - includes windows that are LtGray, dialog boxes that are - application-modal, and menus that are "native." - -5. select-file now uses the familiar windows dialog boxes via calls - to GetOpenFileName() and GetSaveFileName(). Use the keyword - :DIALOG-TYPE with a value of either :OPEN or :SAVE to control - which one you want. - -6. notify-user now uses the familiar windows dialog boxes via calls - to MessageBox(). diff --git a/silica/graphics.lisp b/silica/graphics.lisp index 448bac3f..de654da0 100644 --- a/silica/graphics.lisp +++ b/silica/graphics.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: graphics.lisp,v 1.34 1998/08/06 23:16:59 layer Exp $ +;; $Id: graphics.lisp,v 1.35 1999/05/04 01:21:07 layer Exp $ (in-package :silica) @@ -306,22 +306,32 @@ (defun map-endpoint-sequence (function positions) (declare (dynamic-extent function)) - (if (listp positions) - (loop - (when (null positions) (return)) - (let* ((x1 (pop positions)) - (y1 (pop positions)) - (x2 (pop positions)) - (y2 (pop positions))) - (funcall function x1 y1 x2 y2))) - (let ((length (length positions)) - #+Genera (positions positions)) - (declare (type vector positions)) - (do ((i 0 (+ i 4))) - ((>= i length)) - (funcall function (aref positions i) (aref positions (1+ i)) - (aref positions (+ i 2)) (aref positions (+ i 3)))))) - nil) + (let ((lastx nil) (lasty nil)) + (cond ((listp positions) + (setq lastx (pop positions)) + (setq lasty (pop positions)) + (loop + (when (null positions) (return)) + (let* ((x (pop positions)) + (y (pop positions))) + (funcall function lastx lasty x y) + (setq lastx x lasty y)))) + (t + (let ((length (length positions)) + (i 0)) + (declare (type vector positions) (fixnum i)) + (assert (evenp length)) + (setq lastx (aref positions i)) + (setq lasty (aref positions (1+ i))) + (incf i 2) + (loop + (when (>= i length) (return)) + (let* ((x (aref positions i)) + (y (aref positions (1+ i)))) + (funcall function lastx lasty x y) + (setq lastx x lasty y) + (incf i 2)))))) + nil)) ;; Transforms all of the positions in the sequence. This returns the ;; original sequence if the transformation is the identity and COPY-P diff --git a/sys/odrawpat.lisp b/sys/odrawpat.lisp index 077795d4..22b5acd6 100644 --- a/sys/odrawpat.lisp +++ b/sys/odrawpat.lisp @@ -15,7 +15,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: odrawpat.lisp,v 1.2 1998/08/06 23:17:06 layer Exp $ +;; $Id: odrawpat.lisp,v 1.3 1999/05/04 01:21:07 layer Exp $ (in-package :acl-clim) @@ -63,29 +63,31 @@ (nobutton nil) (label "")) (let* ((hwnd - (CreateWindowEx + (excl:with-native-string (classname "BUTTON") + (excl:with-native-string (windowname (nstringify label)) + (CreateWindowEx 0 ; extended-style - "BUTTON" ; classname - (nstringify label) ; windowname + classname ; classname + windowname ; windowname (logior buttonstyle - ;HBS_DOWNPICS ; special picture while pressed - ;HBS_AUTOADVANCE - ;HBS_TEXTINDENT - ; (if (not active) win:bn_disable 0) - (if (typep label 'acl-clim::acl-pixmap) win:bs_ownerdraw 0) - (if nobutton HBS_NOBUTTON 0) - WS_CHILD - WS_BORDER - WS_CLIPCHILDREN - WS_CLIPSIBLINGS) ; style + ;HBS_DOWNPICS ; special picture while pressed + ;HBS_AUTOADVANCE + ;HBS_TEXTINDENT + ; (if (not active) win:bn_disable 0) + (if (typep label 'acl-clim::acl-pixmap) win:bs_ownerdraw 0) + (if nobutton HBS_NOBUTTON 0) + WS_CHILD + WS_BORDER + WS_CLIPCHILDREN + WS_CLIPSIBLINGS) ; style 0 0 0 0 parent (let ((hmenu (ccallocate hmenu))) (setf (handle-value hmenu hmenu) id) - ; (or id (next-child-id parent)) + ; (or id (next-child-id parent)) hmenu) *hinst* - "x"))) + "x"))))) (format *terminal-io* "~%use ownerdraw label ~S" label) (if (null-handle-p hwnd hwnd) diff --git a/test/test-suite.lisp b/test/test-suite.lisp index 92e0ebe1..a6fa2c1f 100644 --- a/test/test-suite.lisp +++ b/test/test-suite.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-USER; Base: 10; Lowercase: Yes -*- -;; $Id: test-suite.lisp,v 1.85 1999/02/25 08:23:40 layer Exp $ +;; $Id: test-suite.lisp,v 1.86 1999/05/04 01:21:09 layer Exp $ (in-package :clim-user) @@ -668,6 +668,11 @@ people, shall not perish from the earth. (sample (rest shape))) (format-graphics-sample stream label sample))))))) +(defun rectangle-with-text (medium x1 y1 x2 y2 text &rest keys) + (apply #'draw-rectangle* medium x1 y1 x2 y2 keys) + (draw-line* medium x1 y1 x2 y2 :ink +flipping-ink+) + (draw-text* medium text x1 y1 :ink +flipping-ink+)) + (define-test (basic-graphics-inks graphics) (stream) "Test basic graphics inks" (formatting-graphics-samples (stream "Colors" 6) @@ -691,7 +696,12 @@ people, shall not perish from the earth. (let ((sample '(draw-polygon* (0 0 45 100 100 0)))) (dotimes (i 6) (format-graphics-sample stream (format nil "Ink ~D" i) sample - :ink (make-contrasting-inks 6 i)))))) + :ink (make-contrasting-inks 6 i))))) + (formatting-graphics-samples (stream "Flipping" 10) + (let ((sample '(rectangle-with-text 0 0 200 100 "Flip"))) + (format-graphics-sample stream "Black" sample :ink +black+) + (format-graphics-sample stream "White" sample :ink +white+) + (format-graphics-sample stream "Unfilled" sample :ink +black+ :filled nil)))) (define-test (points-and-lines graphics) (stream) "Test drawing points" diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index d0a778d0..9c894de5 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -15,7 +15,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xt-graphics.lisp,v 1.98 1999/02/25 08:23:45 layer Exp $ +;; $Id: xt-graphics.lisp,v 1.99 1999/05/04 01:21:10 layer Exp $ (in-package :tk-silica) @@ -1646,11 +1646,16 @@ (flet ((compute-rotation (x y towards-x towards-y) (decf towards-x x) (decf towards-y y) - #+OLD ; ARE YOU KIDDING? THIS SURE IS THE LONG WAY AROUND THE BARN...JPM + #+OLD ; ARE YOU KIDDING? THIS SURE IS THE LONG WAY AROUND THE BARN...JPM (MOD (ROUND (ATAN TOWARDS-Y TOWARDS-X) (/ PI 2.0)) 4) - (IF (>= TOWARDS-X 0) - (IF (>= TOWARDS-Y 0) 0 2) - (IF (>= TOWARDS-Y 0) 1 3)))) + (cond ((> towards-x 0) + (cond ((> towards-y 0) 1) + ((= towards-y 0) 0) + (t 3))) + ((= towards-x 0) + (cond ((>= towards-y 0) 1) + (t 3))) + (t 2)))) (let* ((rotation (compute-rotation x y towards-x towards-y)) (min-char (xt::font-range font)) (ascent (xt::font-ascent font)) diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index eab4edf2..8a270c30 100644 --- a/tk-silica/xt-silica.lisp +++ b/tk-silica/xt-silica.lisp @@ -15,7 +15,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xt-silica.lisp,v 1.111 1999/02/25 08:23:46 layer Exp $ +;; $Id: xt-silica.lisp,v 1.112 1999/05/04 01:21:10 layer Exp $ (in-package :xm-silica) @@ -1332,20 +1332,21 @@ (char-int #\A) (char-int #\a))))) character)) - ;; I believe this use of character bit attributes - ;; is unnecessary because all that information is - ;; in the keysym. JPM 1/13/99. - #+ignore (setq character - (cltl1:make-char + (clim-make-char character (logior (if (logtest x +control-key+) 1 0) (if (logtest x +meta-key+) 2 0) - (if (logtest x +super-key+) 4 0) - (if (logtest x +hyper-key+) 8 0)))))) + (if (logtest x +super-key+) 4 0) + (if (logtest x +hyper-key+) 8 0)))))) (values character (xt-keysym->keysym keysym))))) +(defun clim-make-char (character &optional (bits 0)) + ;; Like cltl1:make-char but prevents the need to (require :cltl1) + (if (zerop bits) + character + (code-char (char-code character) bits))) (defun state->modifiers (x) (declare (optimize (speed 3) (safety 0)) diff --git a/utils/defun-utilities.lisp b/utils/defun-utilities.lisp index 856c3f68..83b10fb7 100644 --- a/utils/defun-utilities.lisp +++ b/utils/defun-utilities.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: defun-utilities.lisp,v 1.15 1999/02/25 08:23:46 layer Exp $ +;; $Id: defun-utilities.lisp,v 1.16 1999/05/04 01:21:12 layer Exp $ (in-package :clim-utils) @@ -117,3 +117,28 @@ (pushnew 'defun-inline zwei:*irrelevant-functions*) (pushnew 'defun-inline zwei:*irrelevant-defining-forms*)) +;; +;; Backwards compatibility for new ics functions during beta2 development +;; +#+allegro +(in-package :excl) +#+allegro +(progn + #-(version>= 5 (0 1) :pre-beta2 7) + (defmacro with-native-string ((native-string-var string-exp) + &body body) + `(let ((,native-string-var ,string-exp)) + ,@body)) + + #-(version>= 5 (0 1) :pre-beta2 7) + (eval-when (compile load eval) (export 'with-native-string)) + + #-(version>= 5 (0 1) :pre-beta2 7) + (defun mb-to-string (mb-vector) + (let* ((lgth (1- (length mb-vector))) + (string (make-string lgth))) + (dotimes (i lgth string) + (setf (schar string i) (aref mb-vector i))))) + + #-(version>= 5 (0 1) :pre-beta2 7) + (eval-when (compile load eval) (export 'mb-to-string))) diff --git a/utils/designs.lisp b/utils/designs.lisp index 670d1aed..47254aeb 100644 --- a/utils/designs.lisp +++ b/utils/designs.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: designs.lisp,v 1.25 1998/08/06 23:17:33 layer Exp $ +;; $Id: designs.lisp,v 1.26 1999/05/04 01:21:12 layer Exp $ (in-package :clim-utils) @@ -330,13 +330,32 @@ ;;; Palettes +;;; Portability note: It is not possible to get a palette-full +;;; error on #+mswindows. The operating system will automatically +;;; give you the closest matching color. JPM 2/24/99. + +(defparameter *palette-full-error-message* + "The color palette is full. ~%~ +Try closing color-intensive applications such as Netscape, or try~%~ +setting the colormap X resource to yes to get a private colormap,~%~ +then restart your application.") + +(defparameter *palette-full-dynamic-error-message* + "The color palette is full ~%~ +and find-closest-matching-color does not apply to dynamic colors.~%~ +Try closing color-intensive applications such as Netscape, or try~%~ +setting the colormap X resource to yes to get a private colormap,~%~ +then restart your application.") + (eval-when (#-Allegro compile load eval) (define-condition palette-full (error) ((palette :initarg :palette :reader palette-full-palette) (color :initarg :color :reader palette-full-color)) (:report (lambda (condition stream) - (format stream "The palette ~S is full" - (palette-full-palette condition))))) + (let ((color (palette-full-color condition))) + (if (typep color 'dynamic-color) + (format stream *palette-full-dynamic-error-message*) + (format stream *palette-full-error-message*)))))) ) ;eval-when (defvar *use-closest-color* :warn) diff --git a/utils/packages.lisp b/utils/packages.lisp index 04c1e5ad..00170549 100644 --- a/utils/packages.lisp +++ b/utils/packages.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: packages.lisp,v 1.90 1999/02/25 08:23:46 layer Exp $ +;; $Id: packages.lisp,v 1.91 1999/05/04 01:21:12 layer Exp $ (in-package :common-lisp-user) @@ -3289,7 +3289,7 @@ (cl:defvar *clim-major-version* 2) (cl:defvar *clim-minor-version* 2) (cl:defvar *clim-generation-version* 2) -(cl:defvar *clim-build-version* 5) +(cl:defvar *clim-build-version* 6) (cl:defparameter *clim-version* (cl:format () "~d.~d.~d.~a" -- GitLab