diff --git a/ChangeLog.n b/ChangeLog.n index b382383c2d27fda622c713431bf689f46578bc2e..c67abd173b3df2cb993a0286c603e5cde0652711 100644 --- a/ChangeLog.n +++ b/ChangeLog.n @@ -1,3 +1,50 @@ +************************************************************* +4.3.devel.12 + +Mon Jan 22 22:21:03 1996 Duane Rettig (duane at clay) + +Added files: + + * Makefile.alpha + * Makefile.sunx86 + +Changed files: + + * misc/MyDrawingA.c: + * misc/climgccursor.c: + * misc/xtsupport.c: Add Dec Alpha pragmas + + * tk/convenience.lisp: Use second return from + make-arglist-for-class + * tk/widget.lisp: + + * tk/font.lisp: Use typed with-ref-par; use long32 accessor + + * tk/foreign.lisp: + * tk/graphics.cl: + * tk/make-classes.lisp: + * tk/xlib.lisp: + * tk/xm-font-list.lisp: + * tk/xm-widgets.lisp: Use typed with-ref-par + + * tk/gcontext.lisp: Add Dec Alpha + + * tk/macros.lisp: Fix with-ref-par to use typed cstructs instead + of unsigned-lon arrays. + + * tk/resources.lisp: Fix resources for 64 bits + + * tk/xt-defs.lisp: Make xt-arg-val long instead of void * + + * tk-silica/xt-graphics.lisp: Use unsigned-long-array + + * tk-silica/xt-silica.lisp: Use typed with-ref-par + + * xlib/ffi.lisp: Fix int/long distinction + + * xlib/xlib-defs.lisp: Add Dec Alpha + + ************************************************************* 4.3.devel.10 (4.3.beta) diff --git a/Makefile.alpha b/Makefile.alpha new file mode 100644 index 0000000000000000000000000000000000000000..690de92cbf0add970807418bbd4bdbe641d6723b --- /dev/null +++ b/Makefile.alpha @@ -0,0 +1,27 @@ +# $fiHeader: Makefile.alpha,v 1.6 1995/05/17 19:47:10 colin Exp $ +# +# Makefile.alpha for CLIM 2.0 +# + +include Makefile.defs + +Makefile=Makefile.alpha + +CFLAGS = -O -G 0 -taso -xtaso -xtaso_short -resumption_safe + +TKLIB=-lXm +XTLIB=-lXt +XLIB=-lX11 + +XINCLUDES=-I/usr/include + +PRODUCT-OBJS= $(PRODUCT-GENERIC-OBJS) $(STATIC-XM-OBJS) $(SHARED-XM-OBJS) + +PICFLAGS = +SHAREFLAGS = +MAKE_SHARED = make_shared + +SAVEEXP = echo no exports file in this port +RESTEXP = echo no exports file in this port + +include Makefile.generic diff --git a/Makefile.sunx86 b/Makefile.sunx86 new file mode 100644 index 0000000000000000000000000000000000000000..41162a8b94a57531b62df6b5d34c784e548fa0d8 --- /dev/null +++ b/Makefile.sunx86 @@ -0,0 +1,43 @@ +# $fiHeader: Makefile.sun4-svr4,v 1.8 1995/10/17 05:00:59 colin Exp $ +# +# Makefile.sun4-svr4 for CLIM 2.0 +# + +include Makefile.defs + +# temp hack for sole +TMP=/tmp + +Makefile=Makefile.sun4-svr4 + +# 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/openwin/include -I/usr/dt/include + +TKLIB=-lXm +XTLIB=-lXt +XLIB=-lX11 + +SET_LIBRARY_PATH= \ + LD_LIBRARY_PATH=/usr/dt/lib:/usr/openwin/lib:/usr/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=-lgen + +PICFLAGS = -K pic +SHAREFLAGS = -G +MAKE_SHARED = ld + +SAVEEXP = echo no exports file in this port +RESTEXP = echo no exports file in this port + +include Makefile.generic diff --git a/misc/MyDrawingA.c b/misc/MyDrawingA.c index faa51592b594665ec0606893b75829f7d46b6d9d..25979588086d902651abcf92b3493b0723cd84bf 100644 --- a/misc/MyDrawingA.c +++ b/misc/MyDrawingA.c @@ -1,4 +1,4 @@ -/* -[]- +/* -[Thu Dec 7 14:48:54 1995 by duane]- * * copyright (c) 1992 Franz Inc, Berkeley, CA All rights reserved. * @@ -19,11 +19,14 @@ * $fiHeader: MyDrawingA.c,v 1.5 1993/07/27 01:47:40 colin Exp $ */ +#if defined(__alpha) +# pragma pointer_size (save) +# pragma pointer_size (long) +#endif #include <Xm/XmP.h> #include "MyDrawingAP.h" - /******************************************************************************/ /* This sucks */ @@ -149,3 +152,7 @@ XmCreateMyDrawingArea( return( XtCreateWidget( name, xmMyDrawingAreaWidgetClass, p, args, n)) ; } + +#if defined(__alpha) +# pragma pointer_size (restore) +#endif diff --git a/misc/climgccursor.c b/misc/climgccursor.c index 7072b3efb80818813e90335980e141dbb8b8c1db..f2b7b3f4a412871a342478cd680aa895214033a9 100644 --- a/misc/climgccursor.c +++ b/misc/climgccursor.c @@ -1,9 +1,18 @@ +#if defined(__alpha) +# pragma pointer_size (save) +# pragma pointer_size (long) +#endif + #include <X11/Intrinsic.h> #include <X11/StringDefs.h> #include <signal.h> #include <X11/cursorfont.h> +#if defined(__alpha) +# pragma pointer_size (restore) +#endif + static Widget gc_widget = (Widget)NULL; static Cursor widget_cursor = 0; diff --git a/misc/xtsupport.c b/misc/xtsupport.c index 1a0cffd6a7deed332b24a969fd2d3eb6c1b39c25..4cbe4e5a2ef23bf877562d29f311768acc6d5115 100644 --- a/misc/xtsupport.c +++ b/misc/xtsupport.c @@ -1,5 +1,10 @@ /* $fiHeader: xtsupport.c,v 1.11 1995/04/07 01:09:14 georgej Exp $ */ +#if defined(__alpha) +# pragma pointer_size (save) +# pragma pointer_size (long) +#endif + #include <X11/Intrinsic.h> #include <signal.h> @@ -8,6 +13,10 @@ #include <X11/CoreP.h> #include <X11/Xos.h> +#if defined(__alpha) +# pragma pointer_size (restore) +#endif + /* All the following are defintions from various X11R5 Xlib and Xt */ /* files. Their purpose is solely to enable XtAppIntervalNextTimer to */ /* be compiled. */ diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index 7b2933a613ab19200b87df018acabb6f7cad0efc..eb1ce5e8141e3a886c0ca0d0f43827b13b0e8e3a 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -1,6 +1,6 @@ ;; -*- mode: common-lisp; package: tk-silica -*- ;; -;; -[Mon Sep 26 02:04:49 1994 by smh]- +;; -[Thu Dec 28 00:27:15 1995 by duane]- ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA All rights reserved. @@ -883,12 +883,13 @@ (defmethod decode-color-in-palette ((color dynamic-color) (palette xt-palette)) (let ((dynamic-color-cache (palette-dynamic-color-cache palette))) (or (gethash color dynamic-color-cache) - (let ((pixel (aref (handler-case - (tk::alloc-color-cells - (palette-colormap palette) 1 0) - (tk::x-colormap-full () - (palette-full-error palette color))) - 0))) + (let ((pixel (tk::unsigned-long-array + (handler-case + (tk::alloc-color-cells + (palette-colormap palette) 1 0) + (tk::x-colormap-full () + (palette-full-error palette color))) + 0))) (update-palette-entry palette pixel (dynamic-color-color color)) (push palette (dynamic-color-palettes color)) (setf (gethash color dynamic-color-cache) pixel))))) @@ -942,13 +943,13 @@ (palette-colormap palette) 1 total-nplanes) (tk::x-colormap-full () (palette-full-error palette))) - (let ((pixel (aref pixels 0)) + (let ((pixel (tk::unsigned-long-array pixels 0)) (count 0) (planes nil)) (dolist (nplanes layer-nplanes) (let ((plane-masks nil)) (dotimes (i nplanes) - (push (aref masks count) plane-masks) + (push (tk::unsigned-long-array masks count) plane-masks) (incf count)) (push plane-masks planes))) (let ((pixel-planes (cons pixel planes))) diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index 79f2c63b0c39a893d37c4cac9b8249d1f85df557..8c9b9cc8d3e7f9eafb0af1b8b302bb518a68f82f 100644 --- a/tk-silica/xt-silica.lisp +++ b/tk-silica/xt-silica.lisp @@ -1,6 +1,6 @@ ;; -*- mode: common-lisp; package: xm-silica -*- ;; -;; -[Mon Sep 20 09:29:51 1993 by layer]- +;; -[Thu Dec 14 20:13:58 1995 by duane]- ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA All rights reserved. @@ -587,7 +587,14 @@ (let ((button (x-button->silica-button (x11::xbuttonevent-button event))) (pointer (port-pointer port))) - + #+debug + (format excl:*initial-terminal-io* + "~%event ~s type: ~s button: ~s x: ~s y: ~s" + event + (x11::xevent-type event) + (x11::xbuttonevent-button event) + (x11::xbuttonevent-x event) + (x11::xbuttonevent-y event)) (distribute-event port (allocate-event 'pointer-button-press-event @@ -1632,9 +1639,9 @@ the geometry of the children. Instead the parent has control. ")) (let ((ussp (slot-value sheet 'silica::user-specified-size-p)) (uspp (slot-value sheet 'silica::user-specified-position-p)) (size-hints (x11::xallocsizehints))) - (tk::with-ref-par ((supplied 0)) + (tk::with-ref-par ((supplied 0 :unsigned-long)) (when (zerop - (x11::xgetwmnormalhints display window size-hints supplied)) + (x11::xgetwmnormalhints display window size-hints &supplied)) (warn "top-level-sheet had no size hints?!") (return-from enable-mirror)) (let ((flags (x11::xsizehints-flags size-hints))) diff --git a/tk/convenience.lisp b/tk/convenience.lisp index ca51ec46d38363fbf302d11961fcfa40d14b8618..a814541519e248131b124c1d6f39176e13a4a2e8 100644 --- a/tk/convenience.lisp +++ b/tk/convenience.lisp @@ -43,19 +43,19 @@ &key (managed t) &allow-other-keys) (remf args :managed) (with-malloced-objects - (let* ((arglist (make-arglist-for-class - (find-class ',class) - parent - args)) - (o - (,c-function-name - parent - (note-malloced-object (string-to-char* name)) - arglist - (truncate (length arglist) 2)))) + (multiple-value-bind + (arglist n) + (make-arglist-for-class (find-class ',class) + parent + args) + (let ((o (,c-function-name + parent + (note-malloced-object (string-to-char* name)) + arglist + n))) (when managed (xt_manage_child o)) - o))))))) + o)))))))) (define-convenience-class xm-menu-bar (xm-row-column) "XmCreateMenuBar") (define-convenience-class xm-pulldown-menu (xm-row-column) "XmCreatePulldownMenu") diff --git a/tk/font.lisp b/tk/font.lisp index 913f9a1ccb254ea8fc08cf2c57e730a7a5ac3728..6f4e15267acf681fc5d692cd862c73dc52bcdaf9 100644 --- a/tk/font.lisp +++ b/tk/font.lisp @@ -124,30 +124,27 @@ (xcharstruct-vector-descent s n)))))) (defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list)) - (with-ref-par ((n 0)) - (let* ((names (x11:xlistfonts display - #+ics (fat-string-to-string8 pattern) - #-ics pattern - max-fonts - n)) - (n (aref n 0)) - (seq (make-sequence result-type n))) + (with-ref-par ((n 0 :int)) + (let ((names (x11:xlistfonts display + #+ics (fat-string-to-string8 pattern) + #-ics pattern + max-fonts + &n)) + (seq (make-sequence result-type n))) (prog1 (dotimes (i n seq) (setf (elt seq i) (char*-to-string (xfontname-list names i)))) (x11::xfreefontnames names))))) (defun list-font-names-with-info (display pattern &key (max-fonts 65535) (result-type 'list)) - (with-ref-par ((n 0) - (fonts 0)) - (let* ((names (x11:xlistfontswithinfo display - pattern - max-fonts - n - fonts)) - (n (aref n 0)) - (fonts (aref fonts 0)) - (seq (make-sequence result-type n))) + (with-ref-par ((n 0 :int) + (fonts 0 *)) + (let ((names (x11:xlistfontswithinfo display + pattern + max-fonts + &n + &fonts)) + (seq (make-sequence result-type n))) (prog1 (dotimes (i n seq) (setf (elt seq i) @@ -173,22 +170,23 @@ #+ics (defun create-font-set (display base-font-names) - (with-ref-par ((missing-list-ref 0) - (missing-count-ref 0) - (def-string-ref 0)) + (with-ref-par ((missing-list 0 *) + (missing-count 0 :int) + (def-string 0 *)) (let ((font-set (x11:xcreatefontset display (ff:string-to-char* base-font-names) - missing-list-ref - missing-count-ref - def-string-ref)) + &missing-list + &missing-count + &def-string)) (missing-charsets nil)) - (dotimes (i (aref missing-count-ref 0)) + (dotimes (i missing-count) (push (ff:char*-to-string - (sys:memref-int (aref missing-list-ref 0) 0 (* i 4) :unsigned-long)) + ;; needs work for 64bit machines + (sys:memref-int missing-list 0 (* i 4) :unsigned-long)) missing-charsets)) (values font-set missing-charsets - (unless (zerop (aref def-string-ref 0)) - (ff:char*-to-string (aref def-string-ref 0))))))) + (unless (zerop def-string) + (ff:char*-to-string def-string)))))) #+ics (defmethod initialize-instance :after ((fs font-set) &key @@ -206,19 +204,21 @@ #+ics (defun fonts-of-font-set (font-set) - (with-ref-par ((font-struct-list-return-ref 0) - (font-name-list-return-ref 0)) + (with-ref-par ((font-struct-list-return 0 *) + (font-name-list-return 0 *)) (let ((n (x11:xfontsoffontset font-set - font-struct-list-return-ref - font-name-list-return-ref)) + &font-struct-list-return + &font-name-list-return)) (fonts nil)) (dotimes (i n) (let ((name (ff:char*-to-string - (sys:memref-int (aref font-name-list-return-ref 0) + ;; needs work for 64bit machines + (sys:memref-int font-name-list-return 0 (* i 4) :unsigned-long)))) (push (intern-object-address - (sys:memref-int (aref font-struct-list-return-ref 0) + ;; needs work for 64bit machines + (sys:memref-int font-struct-list-return 0 (* i 4) :unsigned-long) 'font :name name) fonts))) @@ -227,12 +227,12 @@ #+ics (defun text-extents (font-set string) (let* ((euc (excl:string-to-euc string)) - (length (1- (length euc)))) - (with-ref-par ((overall-ink-return 0) - (overall-logical-return 0)) - (values (x11:xmbtextextents - font-set - (ff:euc-to-char* euc) - length - overall-ink-return - overall-logical-return))))) + (length (1- (length euc))) + (overall-ink-return (x11:make-xrectangle)) + (overall-logical-return (x11:make-xrectangle))) + (values (x11:xmbtextextents + font-set + (ff:euc-to-char* euc) + length + overall-ink-return + overall-logical-return)))) diff --git a/tk/foreign.lisp b/tk/foreign.lisp index 2e6440f81b07a210510afbf26295f06f78f12d34..252ee0bdcade79ace71e80aa710e473e2369d45f 100644 --- a/tk/foreign.lisp +++ b/tk/foreign.lisp @@ -61,7 +61,7 @@ (num-options 0) (argc 0) (argv 0)) - (let ((d (with-ref-par ((argc argc)) + (let ((d (with-ref-par ((argc argc :int)) (let ((temp (mp:process-quantum mp:*current-process*))) (unwind-protect (progn (setf (mp:process-quantum mp:*current-process*) *large-connection-quantum*) @@ -76,7 +76,7 @@ #+ics (fat-string-to-string8 application-class) #-ics application-class options - num-options argc argv)) + num-options &argc argv)) (setf (mp:process-quantum mp:*current-process*) temp) (mp:process-allow-schedule)))))) (if (zerop d) @@ -101,9 +101,9 @@ (defun get-application-name-and-class (display) - (with-ref-par ((name 0) - (class 0)) - (xt_get_application_name_and_class display name class) - (values (char*-to-string (aref name 0)) - (char*-to-string (aref class 0))))) + (with-ref-par ((name 0 *) + (class 0 *)) + (xt_get_application_name_and_class display &name &class) + (values (char*-to-string name) + (char*-to-string class)))) diff --git a/tk/gcontext.lisp b/tk/gcontext.lisp index bb16028292197e5941d2480f2431c5fafd3226e9..57b5f7eaf2be216c007f4aa8eb04c952b9c464ed 100644 --- a/tk/gcontext.lisp +++ b/tk/gcontext.lisp @@ -1,6 +1,6 @@ ;; -*- mode: common-lisp; package: tk -*- ;; -;; -[Thu May 11 02:24:34 1995 by duane]- +;; -[Thu Dec 28 00:25:24 1995 by duane]- ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA All rights reserved. @@ -447,7 +447,9 @@ x) (defun decode-font (gc x) - (if (= x #16rffffffff) + (if (= x + #+alpha #xffffffffffffffff + #-alpha #xffffffff) (error "cannot decode font") (let* ((display (object-display gc)) (font (find-object-from-xid x display nil))) @@ -455,7 +457,9 @@ (query-font display x))))) (defun decode-pixmap (gc x) - (and (/= #16rffffffff x) + (and (/= x + #+alpha #xffffffffffffffff + #-alpha #xffffffff) (intern-object-xid x 'pixmap diff --git a/tk/graphics.lisp b/tk/graphics.lisp index b64cd9390aa46f58b94b5f3dc32b5843e2390964..9e1c26fd27ed7e33f0a29adb70dbc42bd938a5c0 100644 --- a/tk/graphics.lisp +++ b/tk/graphics.lisp @@ -134,17 +134,17 @@ #+ignore (defun text-extents (font sequence &key (start 0) end translate) (unless end (setq end (length sequence))) - (with-ref-par ((direction 0) - (ascent 0) - (descent 0)) + (with-ref-par ((direction 0 :int) + (ascent 0 :int) + (descent 0 :int)) (let ((overall (make-x-char-struct))) (x11:xtextextents font (+ start (string-to-char* sequence)) (- end start) - direction - ascent - descent + &direction + &ascent + &descent overall) (values (x11::xcharstruct-width overall) diff --git a/tk/macros.lisp b/tk/macros.lisp index 998f931680365854808f3c81024c0490ace5e7f5..f815a83b471522813f7dfb5882baf2b12521c3df 100644 --- a/tk/macros.lisp +++ b/tk/macros.lisp @@ -23,32 +23,52 @@ (in-package :tk) -(defvar *temp-with-ref-par* nil) -(defvar *temp-with-signed-ref-par* nil) +(defmacro def-foreign-array-resource (name constructor) + `(progn + (clim-sys:defresource ,name (n) + :constructor (cons n (,constructor :number n)) + :matcher (not (< (car ,name) n))) + (defmacro ,(intern (format nil "~A-~A" 'with name)) + ((var n) &body body) + `(clim-sys:using-resource (,var ,',name ,n) + (let ((,var (cdr ,var))) + ,@body))))) + +(defmacro define-ref-par-types (&rest types) + (let ((forms nil)) + (dolist (type types) + (let ((type-array (intern (format nil "~A-~A" type 'array))) + (make-type-array (intern (format nil "~A-~A-~A" + 'make type 'array)))) + (setq forms + `(,@forms + (ff:def-c-type ,type-array 1 ,type) + (def-foreign-array-resource + ,type-array ,make-type-array))))) + `(progn ,@forms))) + +(define-ref-par-types + :unsigned-int :int :unsigned-long :long + *) (defmacro with-ref-par (bindings &body body) (if (null bindings) `(progn ,@body) (destructuring-bind - ((var value &optional signed) &rest more-bindings) bindings - (let ((val (gensym))) - `(let ((,val ,value) - (,var ,(if signed - `(or (pop *temp-with-signed-ref-par*) - (make-array 1 :element-type '(signed-byte 32))) - `(or (pop *temp-with-ref-par*) - (make-array 1 :element-type '(unsigned-byte 32)))))) - ,(if signed - `(declare (type (simple-array (signed-byte 32) (1)) ,var)) - `(declare (type (simple-array (unsigned-byte 32) (1)) ,var))) - (setf (aref ,var 0) ,val) - (multiple-value-prog1 - (with-ref-par ,more-bindings ,@body) - ,(if signed - `(push ,var *temp-with-signed-ref-par*) - `(push ,var *temp-with-ref-par*)))))))) - - + ((var value type) &rest more-bindings) + bindings + (let ((&var (intern (format nil "&~A" var))) + (val '#:val) + (with-type-array (intern (format nil "~A-~A-~A" 'with type 'array) + (find-package :tk))) + (type-array (intern (format nil "~A-~A" type 'array) + (find-package :tk)))) + `(let ((,val ,value)) + (,with-type-array (,&var 1) + (symbol-macrolet ((,var (,type-array ,&var 0))) + (setf ,var ,val) + (multiple-value-prog1 + (with-ref-par ,more-bindings ,@body))))))))) (defmacro object-display (object) `(locally (declare (optimize (speed 3) (safety 0))) diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp index 0ba3a4e4bf479ae5d8fef6c3b81a6044893871a1..ef56c33d332961d310050e1a8741016fe7fecabc 100644 --- a/tk/make-classes.lisp +++ b/tk/make-classes.lisp @@ -1,6 +1,6 @@ ;; -*- mode: common-lisp; package: tk -*- ;; -;; -[Wed Dec 14 02:35:23 1994 by duane]- +;; -[Thu Dec 7 14:49:13 1995 by duane]- ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA All rights reserved. @@ -33,34 +33,33 @@ ;; This is only called to fill in the cache, so it can be (real) slow. (defun get-resource-internal (class fn resource-class resource-name) - (let ((x (make-array 1 :element-type '(unsigned-byte 32))) - (y (make-array 1 :element-type '(unsigned-byte 32))) - (tk-resource-name (tkify-lisp-name resource-name)) - result) - ;;--- Perhaps we can just do this when we want to grab the resources. - ;;--- In this way we would only have to do one the display is - ;;--- opened and the toolkit initialized etc etc. - (xt_initialize_widget_class (class-handle class)) - (funcall fn (class-handle class) x y) - (let ((resources (aref x 0)) - (n (aref y 0))) - (setq result - (dotimes (i n) - (let* ((res (xt-resource-list resources i)) - (original-name (xt-resource-name res))) - (when (string-equal (char*-to-string original-name) - tk-resource-name) - (let ((*package* (find-package :tk))) - (return - (make-instance resource-class - :original-name original-name - :name resource-name - :class (lispify-resource-class - (char*-to-string (xt-resource-class res))) - :type (lispify-resource-type - (char*-to-string (xt-resource-type res)))))))))) - (xt_free resources)) - result)) + (with-ref-par ((resources 0 *) + (n 0 :unsigned-int)) + (let ((tk-resource-name (tkify-lisp-name resource-name)) + result) + ;;--- Perhaps we can just do this when we want to grab the resources. + ;;--- In this way we would only have to do one the display is + ;;--- opened and the toolkit initialized etc etc. + (xt_initialize_widget_class (class-handle class)) + (funcall fn (class-handle class) &resources &n) + (let ((resources resources)) + (setq result + (dotimes (i n) + (let* ((res (xt-resource-list resources i)) + (original-name (xt-resource-name res))) + (when (string-equal (char*-to-string original-name) + tk-resource-name) + (let ((*package* (find-package :tk))) + (return + (make-instance resource-class + :original-name original-name + :name resource-name + :class (lispify-resource-class + (char*-to-string (xt-resource-class res))) + :type (lispify-resource-type + (char*-to-string (xt-resource-type res)))))))))) + (xt_free resources)) + result))) ;; These are so we don't need the foreign functions at run time. (defun xt-get-resource-list (class res-return num-res-return) @@ -111,21 +110,20 @@ (get-constraint-resource-list class)) (defun get-resource-list-internal (class fn resource-class) - (let ((x (make-array 1 :element-type '(unsigned-byte 32))) - (y (make-array 1 :element-type '(unsigned-byte 32)))) - (funcall fn (class-handle class) x y) - (let ((resources (aref x 0)) - (n (aref y 0)) + (with-ref-par ((resources 0 *) + (n 0 :unsigned-int)) + (funcall fn (class-handle class) &resources &n) + (let ((resources resources) (r nil)) (dotimes (i n) (push (make-instance - resource-class - :original-name (xt-resource-name (xt-resource-list resources i)) - :name (lispify-resource-name (char*-to-string (xt-resource-name (xt-resource-list resources i)))) - :class (lispify-resource-class - (char*-to-string (xt-resource-class (xt-resource-list resources i)))) - :type (lispify-resource-type - (char*-to-string (xt-resource-type (xt-resource-list resources i))))) + resource-class + :original-name (xt-resource-name (xt-resource-list resources i)) + :name (lispify-resource-name (char*-to-string (xt-resource-name (xt-resource-list resources i)))) + :class (lispify-resource-class + (char*-to-string (xt-resource-class (xt-resource-list resources i)))) + :type (lispify-resource-type + (char*-to-string (xt-resource-type (xt-resource-list resources i))))) r)) (xt_free resources) r))) @@ -199,6 +197,8 @@ ((null cs) (nreverse r)) (destructuring-bind (handle class-ep) (car cs) + #+ignore + (format excl:*initial-terminal-io* ";; Initializing class ~s~%" class-ep) (let ((class (clos::ensure-class (lispify-class-name (widget-class-name handle)) diff --git a/tk/resources.lisp b/tk/resources.lisp index 017c13c825561db7937e1dd4e4f3072d64b34285..f60da826dfbd4f22b63a5997d6b89da502dac6ec 100644 --- a/tk/resources.lisp +++ b/tk/resources.lisp @@ -282,9 +282,6 @@ -;; Note that the current set-values implemenation only works for resources -;; that fit in a 32bit word. You were warned! - (defun fill-sv-cache (parent-class class resources) (let* ((len (length resources)) (arglist (make-xt-arglist :number len)) @@ -340,23 +337,27 @@ ((null resdess)) (destructuring-bind (convert-p type) (car resdess) - ;; Yuck -- the following should be handled somehow by cstructs... - (setf (sys:memref-int (xt-arglist arglist i) 4 0 :signed-long) + (setf (xt-arglist-value arglist i) (if convert-p (convert-resource-out widget type (car values)) (car values))))) (xt_set_values widget arglist length))))))) ;; This is used by initialize-instance methods for widgets... + (defun make-arglist-for-class (class parent args) (declare (optimize (speed 3) (safety 0))) (do ((new-args nil) keyword value) ((null args) - (make-array (length new-args) - :element-type '(unsigned-byte 32) - :initial-contents (nreverse new-args))) + (let* ((new-args (nreverse new-args)) + (n (truncate (length new-args) 2)) + (arglist (make-xt-arglist :number n :in-foreign-space nil))) + (dotimes (i n) + (setf (xt-arglist-name arglist i) (pop new-args) + (xt-arglist-value arglist i) (pop new-args))) + (values arglist n))) (setq keyword (pop args) value (pop args)) (let ((resource (or (find-class-resource class keyword) @@ -365,15 +366,11 @@ (push (resource-original-name resource) new-args) (let ((type (resource-type resource))) (push - (logand - #xffffffff - (if (resource-type-set-conversion-p type) - (convert-resource-out parent type value) - value)) + (if (resource-type-set-conversion-p type) + (convert-resource-out parent type value) + value) new-args)))))) - - ;; I would really prefer to define these as separate methods. However diff --git a/tk/widget.lisp b/tk/widget.lisp index f6d75452620eb3813215fcde0731dd1261ae2ed0..3394fa29afdd8c3cf9da4ff1defe07f55586681e 100644 --- a/tk/widget.lisp +++ b/tk/widget.lisp @@ -31,22 +31,23 @@ &allow-other-keys) (with-malloced-objects (let* ((class (find-class widget-class)) - (handle (class-handle class)) - (arglist (make-arglist-for-class class nil args))) - (register-address - (apply #'make-instance - class - :foreign-address - (xt_app_create_shell #+ics (fat-string-to-string8 application-name) - #-ics application-name - #+ics (fat-string-to-string8 application-class) - #-ics application-class - handle - display - arglist - (truncate (length arglist) 2)) - :display display - args))))) + (handle (class-handle class))) + (multiple-value-bind (arglist n) + (make-arglist-for-class class nil args) + (register-address + (apply #'make-instance + class + :foreign-address + (xt_app_create_shell #+ics (fat-string-to-string8 application-name) + #-ics application-name + #+ics (fat-string-to-string8 application-class) + #-ics application-class + handle + display + arglist + n) + :display display + args)))))) ;; These are so we don't need the foreign functions at run time. @@ -74,14 +75,15 @@ (assert parent) (with-malloced-objects (let* ((class (find-class-maybe widget-class)) - (handle (class-handle class)) - (arglist (make-arglist-for-class class parent args))) - (funcall fn - (note-malloced-object (string-to-char* name)) - handle - parent - arglist - (truncate (length arglist) 2))))) + (handle (class-handle class))) + (multiple-value-bind (arglist n) + (make-arglist-for-class class parent args) + (funcall fn + (note-malloced-object (string-to-char* name)) + handle + parent + arglist + n))))) (defun realize-widget (widget) (xt_realize_widget widget)) @@ -96,16 +98,22 @@ (not (zerop (xt_is_managed widget)))) (defun manage-children (children) - (xt_manage_children (map '(simple-array (signed-byte 32)) - #'ff:foreign-pointer-address - children) - (length children))) + (let ((n (length children)) + (i 0)) + (with-*-array (v n) + (dotimes (i n) + (setf (*-array v i) + (ff:foreign-pointer-address (pop children)))) + (xt_manage_children v n)))) (defun unmanage-children (children) - (xt_unmanage_children (map '(simple-array (signed-byte 32)) - #'ff:foreign-pointer-address - children) - (length children))) + (let ((n (length children)) + (i 0)) + (with-*-array (v n) + (dotimes (i n) + (setf (*-array v i) + (ff:foreign-pointer-address (pop children)))) + (xt_unmanage_children v n)))) (defun destroy-widget (widget) (xt_destroy_widget widget)) @@ -119,14 +127,15 @@ (defun create-popup-shell (name widget-class parent &rest args) (with-malloced-objects (let* ((class (find-class-maybe widget-class)) - (handle (class-handle class)) - (arglist (make-arglist-for-class class parent args))) - (incf *widget-count*) - (xt_create_popup_shell (note-malloced-object (string-to-char* name)) - handle - parent - arglist - (truncate (length arglist) 2))))) + (handle (class-handle class))) + (multiple-value-bind (arglist n) + (make-arglist-for-class class parent args) + (incf *widget-count*) + (xt_create_popup_shell (note-malloced-object (string-to-char* name)) + handle + parent + arglist + n))))) (defun find-class-maybe (x) (if (typep x 'clos::class) x @@ -286,12 +295,13 @@ (when *fallback-resources* (xt_app_set_fallback_resources context - (let* ((n (length *fallback-resources*)) - (v (make-array (1+ n) :element-type '(unsigned-byte 32)))) - (dotimes (i n) - (setf (aref v i) (ff:string-to-char* (nth i *fallback-resources*)))) - (setf (aref v n) 0) - v))) + (let ((n (length *fallback-resources*))) + (with-*-array (v (1+ n)) + (dotimes (i n) + (setf (*-array v i) + (ff:string-to-char* (nth i *fallback-resources*)))) + (setf (*-array v n) 0) + v)))) #+ics (xt_set_language_proc context 0 0) (let* ((display (apply #'make-instance 'display :context context diff --git a/tk/xlib.lisp b/tk/xlib.lisp index 6f5e2d2e0af78e439c537b96d4cbc2f1cef631ab..7703711db3105e0d0b666dcb3d6c9c3d1228bf1d 100644 --- a/tk/xlib.lisp +++ b/tk/xlib.lisp @@ -189,15 +189,15 @@ (setf (foreign-pointer-address db) (x11:xrmgetstringdatabase "")))) (defun get-resource (db name class) - (with-ref-par ((type-ref 0)) + (with-ref-par ((type 0 *)) (let ((xrmvalue (x11:make-xrmvalue))) (unless (zerop (x11:xrmgetresource db #+ics (fat-string-to-string8 name) #-ics name #+ics (fat-string-to-string8 class) #-ics class - type-ref xrmvalue)) - (let ((type (char*-to-string (aref type-ref 0)))) + &type xrmvalue)) + (let ((type (char*-to-string type))) (values (cond ((equal type "String") @@ -408,18 +408,15 @@ (values (x11:xcolor-pixel y) (make-instance 'color :foreign-address y)))))) -(defvar *pixel-array* - (make-array 1 :initial-element 0 :element-type '(unsigned-byte 32))) - (defun free-color-cells (colormap pixel planes) - (setf (aref *pixel-array* 0) pixel) - (x11:xfreecolors - (object-display colormap) - colormap - *pixel-array* - 1 - planes)) - + (with-unsigned-long-array (pixels 1) + (setf (unsigned-long-array pixels 0) pixel) + (x11:xfreecolors + (object-display colormap) + colormap + pixels + 1 + planes))) (defun allocate-named-color (colormap name) (let ((exact (x11::make-xcolor :in-foreign-space t)) @@ -460,6 +457,7 @@ pixel flags)) +#+ignore ;; moved to ./macros.lisp (defmacro def-foreign-array-resource (name constructor) `(progn (clim-sys:defresource ,name (n) @@ -485,21 +483,19 @@ ncolors)) (defun alloc-color-cells (colormap ncolors nplanes) - (let* ((masks (make-array nplanes - :initial-element 0 :element-type '(unsigned-byte 32))) - (pixels (make-array ncolors - :initial-element 0 :element-type '(unsigned-byte 32))) - (z (x11:xalloccolorcells - (object-display colormap) - colormap - 0 - masks - nplanes - pixels - ncolors))) - (when (zerop z) - (error 'x-colormap-full)) - (values pixels masks))) + (with-unsigned-long-array (masks nplanes) + (with-unsigned-long-array (pixels ncolors) + (let ((z (x11:xalloccolorcells + (object-display colormap) + colormap + 0 + masks + nplanes + pixels + ncolors))) + (when (zerop z) + (error 'x-colormap-full)) + (values pixels masks))))) (defun default-screen (display) @@ -511,10 +507,10 @@ (defun get-input-focus (display) (with-ref-par - ((focus 0) - (revert-to 0)) - (x11:xgetinputfocus display focus revert-to) - (values (aref focus 0) (aref revert-to 0)))) + ((focus 0 :unsigned-long) + (revert-to 0 :int)) + (x11:xgetinputfocus display &focus &revert-to) + (values focus revert-to))) (defun set-input-focus (display focus &optional (revert-to 0) (time 0)) (x11:xsetinputfocus display focus revert-to time)) @@ -522,41 +518,41 @@ (defun query-pointer (window) (with-ref-par - ((root 0) - (child 0) - (root-x 0 t) - (root-y 0 t) - (x 0 t) - (y 0 t) - (mask 0)) + ((root 0 :unsigned-long) + (child 0 :unsigned-long) + (root-x 0 :int) + (root-y 0 :int) + (x 0 :int) + (y 0 :int) + (mask 0 :unsigned-int)) (let ((display (object-display window))) (if (x11:xquerypointer display window - root - child - root-x - root-y - x - y - mask) + &root + &child + &root-x + &root-y + &x + &y + &mask) (values t (intern-object-xid - (aref root 0) + root 'window display :display display) (intern-object-xid - (aref child 0) + child 'window display :display display) - (aref root-x 0) - (aref root-y 0) - (aref x 0) - (aref y 0) - (aref mask 0)))))) + root-x + root-y + x + y + mask))))) @@ -654,9 +650,10 @@ (declare (optimize (speed 3) (safety 0))) (let ((buffer (or (excl:without-interrupts (pop *lookup-string-buffers*)) (excl::malloc 256)))) - (declare (type (unsigned-byte 32) buffer)) - (with-ref-par ((keysym 0)) - (let* ((nchars (x11:xlookupstring event buffer 256 keysym compose-status)) + (declare (type (unsigned-byte 8) buffer)) + ;; we assume the Xid type is the same as a pointer + (with-ref-par ((keysym 0 :unsigned-long)) + (let* ((nchars (x11:xlookupstring event buffer 256 &keysym compose-status)) (result (make-string nchars))) (declare (fixnum nchars) (simple-string result)) @@ -665,8 +662,7 @@ (setf (schar result i) (code-char (sys:memref-int buffer 0 i :unsigned-byte)))) (excl:without-interrupts (push buffer *lookup-string-buffers*)) - (values result - (aref keysym 0)))))) + (values result keysym))))) ;; image support @@ -810,11 +806,11 @@ (defun get-cut-buffer (display) (let ((string (make-string 1024))) (with-ref-par - ((actual-type 0) - (actual-format 0) - (nitems 0) - (bytes-after 0) - (prop 0)) + ((actual-type 0 :unsigned-long) + (actual-format 0 :int) + (nitems 0 :unsigned-long) + (bytes-after 0 :unsigned-long) + (prop 0 *)) (x11:xgetwindowproperty display (x11:xdefaultrootwindow display) @@ -823,9 +819,9 @@ 256 0 x11:anypropertytype - actual-type - actual-format - nitems - bytes-after - prop) - (char*-to-string (aref prop 0))))) + &actual-type + &actual-format + &nitems + &bytes-after + &prop) + (char*-to-string prop)))) diff --git a/tk/xm-font-list.lisp b/tk/xm-font-list.lisp index 5a986f1c690fde6d47222c54bf4c49f7a356f3c7..ed2e5f8c4f7fdc06aedf5c54da95720a7e82f9c8 100644 --- a/tk/xm-font-list.lisp +++ b/tk/xm-font-list.lisp @@ -97,21 +97,24 @@ (defun import-font-list (font-list) (let ((context - (with-ref-par ((context 0)) - (assert (not (zerop (xm_font_list_init_font_context context font-list)))) - (aref context 0))) + (with-ref-par ((context 0 *)) + (assert + (not (zerop (xm_font_list_init_font_context &context font-list)))) + context)) (res nil)) (with-ref-par - ((type 0)) + ;; this is actually an enumeration type (XmFontType) - let's + ;; guess at an int. in any case I don't think it matters (cim 12/14/95) + ((type 0 :unsigned-int)) (loop (let ((entry (xm_font_list_next_entry context))) (when (zerop entry) (return nil)) - (setf (aref type 0) 0) + (setf type 0) (push (list "" - (let ((font (xm_font_list_entry_get_font entry type))) - (if (eq (aref type 0) xm-font-is-fontset) + (let ((font (xm_font_list_entry_get_font entry &type))) + (if (eq type xm-font-is-fontset) ;; we should really make the whole backend ;; fontset aware so that we get the right ;; metrics - this will do for now (cim 3/9/95) diff --git a/tk/xm-widgets.lisp b/tk/xm-widgets.lisp index d1aaffeb020134fa1207224d6586cf9c62f4c172..0bef609bb756e55c14b7ee7a607bdf1b2e0f5685 100644 --- a/tk/xm-widgets.lisp +++ b/tk/xm-widgets.lisp @@ -85,12 +85,12 @@ (defmethod convert-resource-in ((parent t) (type (eql 'xm-string)) value) (and (not (zerop value)) - (with-ref-par ((string 0)) + (with-ref-par ((string 0 *)) ;;--- I think we need to read the book about ;;--- xm_string_get_l_to_r and make sure it works with multiple ;;-- segment strings - (xm_string_get_l_to_r value xm-font-list-default-tag string) - (char*-to-string (aref string 0))))) + (xm_string_get_l_to_r value xm-font-list-default-tag &string) + (char*-to-string string)))) (defmethod convert-resource-in ((parent t) (type (eql 'xm-string-table)) value) value) diff --git a/tk/xt-defs.lisp b/tk/xt-defs.lisp index 8b6547b9707ea9922e5d6e947af7f4ce665b267c..63d2fb54674148bb4f5bb95bbd0531f9f3225650 100644 --- a/tk/xt-defs.lisp +++ b/tk/xt-defs.lisp @@ -125,7 +125,7 @@ (def-c-type (class-array :no-defuns) 1 :unsigned-long) -(def-c-type (xt-arg-val :no-defuns) * :void) +(def-c-type (xt-arg-val :no-defuns) :long) (def-c-type (xt-arg :in-foreign-space :no-defuns) :struct (name * :char) diff --git a/xlib/ffi.lisp b/xlib/ffi.lisp index 9fbfd861af5c1bb80874a2eee96cf5656bf0a231..78fe6453790ec64983bc39b4d32a47bca9c26d33 100644 --- a/xlib/ffi.lisp +++ b/xlib/ffi.lisp @@ -188,8 +188,8 @@ (def-exported-foreign-synonym-type unsigned-short :unsigned-short) (def-exported-foreign-synonym-type int :int) (def-exported-foreign-synonym-type unsigned-int :unsigned-int) -(def-exported-foreign-synonym-type long :int) -(def-exported-foreign-synonym-type unsigned-long :unsigned-int) +(def-exported-foreign-synonym-type long :long) +(def-exported-foreign-synonym-type unsigned-long :unsigned-long) (def-exported-foreign-synonym-type float :single-float) (def-exported-foreign-synonym-type double :double-float) (def-exported-foreign-synonym-type void :int) @@ -198,7 +198,7 @@ (def-exported-foreign-synonym-type unsigned unsigned-int) (def-exported-foreign-synonym-type long-float double) -(def-exported-foreign-synonym-type caddr-t int) +(def-exported-foreign-synonym-type caddr-t :pointer) (def-exported-foreign-synonym-type u-char unsigned-char) (def-exported-foreign-synonym-type u-short unsigned-short) (def-exported-foreign-synonym-type u-int unsigned-int) diff --git a/xlib/xlib-defs.lisp b/xlib/xlib-defs.lisp index d0cbec83cfddea82ddf84f54bfae5a7c0da19fd8..0dffd1684624e68049eaa9ef4b515f59131685e7 100644 --- a/xlib/xlib-defs.lisp +++ b/xlib/xlib-defs.lisp @@ -619,11 +619,15 @@ (def-exported-foreign-synonym-type cursor xid) (def-exported-foreign-synonym-type colormap xid) (def-exported-foreign-synonym-type gcontext xid) -(def-exported-foreign-synonym-type keysym xid) +(def-exported-foreign-synonym-type keysym + #+alpha unsigned-int + #-alpha xid) (def-exported-foreign-synonym-type mask unsigned-long) (def-exported-foreign-synonym-type atom unsigned-long) (def-exported-foreign-synonym-type visualid unsigned-long) -(def-exported-foreign-synonym-type time unsigned-long) +(def-exported-foreign-synonym-type time + #+alpha unsigned-int + #-alpha unsigned-long) (def-exported-foreign-synonym-type keycode unsigned-char) #+ics