December 2006 - graphic-forms-cvs@common-lisp.net

[graphic-forms-cvs] r422 - in trunk: docs/manual src/uitoolkit/system
by junrue＠common-lisp.net 23 Dec '06

23 Dec '06

Author: junrue Date: Sat Dec 23 01:31:46 2006 New Revision: 422 Added: trunk/docs/manual/protocols.xml Modified: trunk/docs/manual/Makefile trunk/docs/manual/gf-data.xsl trunk/docs/manual/gfw-symbols.xml trunk/docs/manual/glossary.xml trunk/docs/manual/graphic-forms.xml trunk/docs/manual/miscellaneous-topics.xml trunk/src/uitoolkit/system/system-constants.lisp Log: more documentation, some of which related to status-bar and friends, and some just general doc update Modified: trunk/docs/manual/Makefile ============================================================================== --- trunk/docs/manual/Makefile (original) +++ trunk/docs/manual/Makefile Sat Dec 23 01:31:46 2006 @@ -10,7 +10,7 @@ CHM-DEPS = gfs-tmp-pkg.xml gfg-tmp-pkg.xml gfw-tmp-pkg.xml gfc-tmp-pkg.xml \ constants.xml api.xml \ catalog.xml glossary.xml graphic-forms.xml image-data-plugins.xml \ - introduction.xml legal.xml miscellaneous-topics.xml + introduction.xml legal.xml protocols.xml miscellaneous-topics.xml COMMON-DEPS = gf-data.xsl gf-package.xsl clhs-table.xml win32-api-table.xml TMP-XML = gfs-tmp-pkg.xml gfs-tmp-syms.xml gfg-tmp-pkg.xml gfg-tmp-syms.xml \ Modified: trunk/docs/manual/gf-data.xsl ============================================================================== --- trunk/docs/manual/gf-data.xsl (original) +++ trunk/docs/manual/gf-data.xsl Sat Dec 23 01:31:46 2006 @@ -2,7 +2,7 @@  <xsl:stylesheet xmlns:exsl="http://exslt.org/common" Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Sat Dec 23 01:31:46 2006 @@ -532,6 +532,7 @@ <hierarchy> <inheritedby> <reftopic>gfw:window</reftopic> + <reftopic>gfw:status-bar</reftopic> </inheritedby> </hierarchy> This is a mix-in for widgets that employ a <reftopic>gfw:layout-manager</reftopic> @@ -709,6 +710,7 @@ <inheritedby> <reftopic>gfw:menu</reftopic> <reftopic>gfw:list-box</reftopic> + <reftopic>gfw:status-bar</reftopic> </inheritedby> </hierarchy> This is a mix-in for widgets that contain and display sub-elements. @@ -790,6 +792,7 @@ <reftopic>gfw:font-dialog</reftopic> <reftopic>gfw:menu</reftopic> <reftopic>gfw:window</reftopic> + <reftopic>gfw:status-bar</reftopic> </inheritedby> </hierarchy> This is the base class for all windowed user interface objects whose @@ -1444,6 +1447,9 @@ <reftopic>gfs:dispose</reftopic> <reftopic>gfw:owner</reftopic> <reftopic>gfw:text</reftopic> + <reftopic>gfw:obtain-horizontal-scrollbar</reftopic> + <reftopic>gfw:obtain-vertical-scrollbar</reftopic> + <reftopic>gfw:obtain-status-bar</reftopic> </seealso> </class> @@ -2049,9 +2055,82 @@ </initargs> <seealso> <reftopic>gfs:dispose</reftopic> - <reftopic>gfw:dialog</reftopic> + <reftopic>gfw:update-native-style</reftopic> + <reftopic>gfw:parent</reftopic> + <reftopic>gfw:style-of</reftopic> + <reftopic>gfw:list-item</reftopic> <reftopic>gfw:auto-vscroll-p</reftopic> <reftopic>gfw:append-item</reftopic> + <reftopic>gfw:delete-item</reftopic> + <reftopic>gfw:item-count</reftopic> + <reftopic>gfw:items-of</reftopic> + <reftopic>gfw:update-from-items</reftopic> + <reftopic>gfw:item-index</reftopic> + </seealso> + </class> + + <class name="status-bar"> + <description> + <hierarchy> + <inherits> + <reftopic>gfw:widget</reftopic> + <reftopic>gfw:layout-managed</reftopic> + <reftopic>gfw:item-manager</reftopic> + </inherits> + </hierarchy> + This class represents the status bar widget with which <reftopic>gfw:top-level</reftopic> + instances may be configured. Application code does not instantiate this class directly. + </description> + <initargs> + <argument name=":parent"> + <description> + This initarg specifies the parent of the control. + </description> + </argument> + <argument name=":handle"> + <description> + See <reftopic>gfs:native-object</reftopic>. + </description> + </argument> + </initargs> + <seealso> + <reftopic>gfs:dispose</reftopic> + <reftopic>gfw:update-native-style</reftopic> + <reftopic>gfw:parent</reftopic> + <reftopic>gfw:style-of</reftopic> + <reftopic>gfw:status-item</reftopic> + <reftopic>gfw:append-item</reftopic> + <reftopic>gfw:delete-item</reftopic> + <reftopic>gfw:item-count</reftopic> + <reftopic>gfw:items-of</reftopic> + <reftopic>gfw:update-from-items</reftopic> + <reftopic>gfw:item-index</reftopic> + </seealso> + </class> + + <class name="status-item"> + <description> + <hierarchy> + <inherits> + <reftopic>gfw:item</reftopic> + </inherits> + </hierarchy> + This class represents an element of a <reftopic>gfw:status-bar</reftopic>. + </description> + <initargs> + <argument name=":parent"> + <description> + This initarg specifies the parent of the control. + </description> + </argument> + <argument name=":data"> + <description> + See <reftopic>gfw:item</reftopic>. + </description> + </argument> + </initargs> + <seealso> + <reftopic>gfs:dispose</reftopic> </seealso> </class> @@ -2946,7 +3025,11 @@ </para> </description> <seealso> + <reftopic>gfw:append-item</reftopic> + <reftopic>gfw:delete-item</reftopic> + <reftopic>gfw:item-count</reftopic> <reftopic>gfw:items-of</reftopic> + <reftopic>gfw:item-index</reftopic> </seealso> </generic-function> @@ -3700,6 +3783,29 @@ </seealso> </generic-function> + <generic-function name="obtain-status-bar"> + <syntax> + <arguments> + <argument name="self"> + <description> + An object configured with a statusbar. + </description> + </argument> + </arguments> + <return> + <reftopic>gfw:status-bar</reftopic> + </return> + </syntax> + <description> + Returns the <reftopic>gfw:status-bar</reftopic> + attached to the bottom of <arg0/>, if <arg0/> is configured to + have one. + </description> + <seealso> + <reftopic>gfw:status-item</reftopic> + </seealso> + </generic-function> + <generic-function name="menu-bar"> <syntax with-setf="t"> <arguments> Modified: trunk/docs/manual/glossary.xml ============================================================================== --- trunk/docs/manual/glossary.xml (original) +++ trunk/docs/manual/glossary.xml Sat Dec 23 01:31:46 2006 @@ -1,7 +1,7 @@  <glossary id="glossary"><title>Glossary</title> <indexterm><primary>Glossary</primary></indexterm> @@ -11,7 +11,7 @@ <glossentry id="accelerator"><glossterm>accelerator</glossterm> <glossdef> <para> - An accelerator is a key sequence assigned to an application + An <emphasis>accelerator</emphasis> is a key sequence assigned to an application function allowing a user to bypass navigation of the menu or control hierarchy normally required to invoke the function. Some accelerators are established by Windows style guidelines, such as control-c for @@ -27,7 +27,7 @@ <glossentry id="auto-scrolling"><glossterm>auto-scrolling</glossterm> <glossdef> <para> - Auto-scrolling is a feature whereby scrolling occurs as a side + <emphasis>Auto-scrolling</emphasis> is a feature whereby scrolling occurs as a side effect of user input so content can remain visible, thus avoiding the need to explicitly manipulate scrollbars to achieve the same result. </para> @@ -44,9 +44,9 @@ <glossentry id="control"><glossterm>control</glossterm> <glossdef> <para> - A control is a system-defined window class whose role is to accept - user input and possibly generate notification events based on such - input. + A <emphasis>control</emphasis> is a system-defined window class whose + role is to accept user input and possibly generate notification events + based on such input. </para> </glossdef> </glossentry> @@ -58,9 +58,9 @@ <glossentry id="default action"><glossterm>default action</glossterm> <glossdef> <para> - Conceptually, a default action is a secondary event initiated by - user input that is a logical follow-up to a previous event. Examples - of such user gestures include double-clicking an item in a list box + Conceptually, a <emphasis>default action</emphasis> is a secondary event + initiated by user input that is a logical follow-up to a previous event. + Examples of such user gestures include double-clicking an item in a list box control, or pressing enter when an edit control has the keyboard focus. The response to a default action makes use of context established by the preceding event (e.g., the selection set by an initial click @@ -72,8 +72,8 @@ <glossentry id="dialog"><glossterm>dialog</glossterm> <glossdef> <para> - A dialog is a mechanism for collecting user input or showing - information. The system defines common dialogs for tasks like + A <emphasis>dialog</emphasis> is a mechanism for collecting user input + or showing information. The system defines common dialogs for tasks like choosing files, fonts, or colors. Custom dialogs can be defined by application code. </para> @@ -87,8 +87,8 @@ <glossentry id="extension"><glossterm>extension</glossterm> <glossdef> <para> - An extension is code providing additional functionality beyond the - original scope of a system. An extension framework encourages + An <emphasis>extension</emphasis> is code providing additional functionality + beyond the original scope of a system. An extension framework encourages modularity. More importantly, it is a conscious design choice to allow a system to be stretched beyond what the original designers may have anticipated. @@ -126,9 +126,9 @@ <glossdef> <para> A collection of menu items presented within a single rectangular - region. Menus are often anchored to a menu bar, but may also be - invoked in a context-sensitive manner via the mouse or an - <glossseealso otherterm="accelerator"/>. + region. <emphasis>Menus</emphasis> are often anchored to a menu bar, + but may also be invoked in a context-sensitive manner via the mouse + or an <glossseealso otherterm="accelerator"/>. </para> </glossdef> </glossentry> @@ -136,8 +136,8 @@ <glossentry id="mix-in"><glossterm>mix-in class</glossterm> <glossdef> <para> - A mix-in class represents a specific abstraction that complements - the role(s) of other class(es) in a class hierarchy. + A <emphasis>mix-in</emphasis> class represents a specific abstraction + that complements the role(s) of other class(es) in a class hierarchy. </para> </glossdef> </glossentry> @@ -145,10 +145,10 @@ <glossentry id="mnemonic"><glossterm>mnemonic</glossterm> <glossdef> <para> - A mnemonic is a key sequence (usually a single character modified - by the <Alt> key) enabling mouse-free navigation of a menu or - control hierarchy to invoke an application function. Depending on - the user's system settings, mnemonic characters may be hidden until + A <emphasis>mnemonic</emphasis> is a key sequence (usually a single + character modified by the <Alt> key) enabling mouse-free navigation + of a menu or control hierarchy to invoke an application function. Depending + on the user's system settings, mnemonic characters may be hidden until the user presses the <Alt> key. </para> <glossseealso otherterm="accelerator"/> @@ -167,15 +167,26 @@ <glossentry id="plugin"><glossterm>plugin</glossterm> <glossdef> <para> - A plugin is a unit of code integrated into a larger system in order - to implement a specific instance of an established category of - services. A plugin framework encourages modularity within a - defined scope of functionality. + A <emphasis>plugin</emphasis> is a unit of code integrated into + a larger system in order to implement a specific instance of an + established category of services. A plugin framework encourages + modularity within a defined scope of functionality. </para> <glossseealso otherterm="extension"/> </glossdef> </glossentry> + <glossentry id="protocol"><glossterm>protocol</glossterm> + <glossdef> + <para> + In Common Lisp, a <emphasis>protocol</emphasis> refers to a group + of logically-related functions (usually generic functions, since + protocols are often designed to be extensible). The Metaobject + Protocol (MOP) is a popular and sophisticated example. + </para> + </glossdef> + </glossentry> + </glossdiv> <glossdiv id="glossary-Q"><title>Q</title> Modified: trunk/docs/manual/graphic-forms.xml ============================================================================== --- trunk/docs/manual/graphic-forms.xml (original) +++ trunk/docs/manual/graphic-forms.xml Sat Dec 23 01:31:46 2006 @@ -14,6 +14,7 @@ <!ENTITY gfgpkg SYSTEM "gfg-tmp-pkg.xml">  <!ENTITY gfspkg SYSTEM "gfs-tmp-pkg.xml">  <!ENTITY gfwpkg SYSTEM "gfw-tmp-pkg.xml">  + <!ENTITY protocols SYSTEM "protocols.xml"> <!ENTITY misctopics SYSTEM "miscellaneous-topics.xml"> <!ENTITY imdataplugins SYSTEM "image-data-plugins.xml"> <!ENTITY glossary SYSTEM "glossary.xml"> @@ -33,6 +34,7 @@ &legal; &introduction; &api; + &protocols; &misctopics; &glossary; Modified: trunk/docs/manual/miscellaneous-topics.xml ============================================================================== --- trunk/docs/manual/miscellaneous-topics.xml (original) +++ trunk/docs/manual/miscellaneous-topics.xml Sat Dec 23 01:31:46 2006 @@ -1,7 +1,7 @@  <chapter id="misc-topics"> <title>Miscellaneous Topics</title> Added: trunk/docs/manual/protocols.xml ============================================================================== --- (empty file) +++ trunk/docs/manual/protocols.xml Sat Dec 23 01:31:46 2006 @@ -0,0 +1,16 @@ + +<chapter id="protocols"> + <title>Protocols</title> + + <para role="normal"> + This chapter's sections discuss the <glossterm linkend="protocol">protocols</glossterm> + representing major functional areas of Graphic-Forms. + </para> + + + +</chapter> Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sat Dec 23 01:31:46 2006 @@ -951,24 +951,24 @@ ;;; statusbar constants ;;; -(defconstant +sb-SETPARTS+ #x0404) ; (WM_USER+4) -(defconstant +sb-GETPARTS+ #x0406) ; (WM_USER+6) -(defconstant +sb-GETBORDERS+ #x0407) ; (WM_USER+7) -(defconstant +sb-SETMINHEIGHT+ #x0408) ; (WM_USER+8) -(defconstant +sb-SIMPLE+ #x0409) ; (WM_USER+9) -(defconstant +sb-GETRECT+ #x040A) ; (WM_USER+10) -(defconstant +sb-ISSIMPLE+ #x040E) ; (WM_USER+14) -(defconstant +sb-SETICON+ #x040F) ; (WM_USER+15) -(defconstant +sb-SETTIPTEXTA+ #x0410) ; (WM_USER+16) -(defconstant +sb-SETTIPTEXTW+ #x0411) ; (WM_USER+17) -(defconstant +sb-GETTIPTEXTA+ #x0412) ; (WM_USER+18) -(defconstant +sb-GETTIPTEXTW+ #x0413) ; (WM_USER+19) -(defconstant +sb-GETICON+ #x0414) ; (WM_USER+20) -(defconstant +sb-SETUNICODEFORMAT+ #x2005) ; CCM_SETUNICODEFORMAT -(defconstant +sb-GETUNICODEFORMAT+ #x2006) ; CCM_GETUNICODEFORMAT +(defconstant +sb-setparts+ #x0404) ; (WM_USER+4) +(defconstant +sb-getparts+ #x0406) ; (WM_USER+6) +(defconstant +sb-getborders+ #x0407) ; (WM_USER+7) +(defconstant +sb-setminheight+ #x0408) ; (WM_USER+8) +(defconstant +sb-simple+ #x0409) ; (WM_USER+9) +(defconstant +sb-getrect+ #x040A) ; (WM_USER+10) +(defconstant +sb-issimple+ #x040E) ; (WM_USER+14) +(defconstant +sb-seticon+ #x040F) ; (WM_USER+15) +(defconstant +sb-settiptexta+ #x0410) ; (WM_USER+16) +(defconstant +sb-settiptextw+ #x0411) ; (WM_USER+17) +(defconstant +sb-gettiptexta+ #x0412) ; (WM_USER+18) +(defconstant +sb-gettiptextw+ #x0413) ; (WM_USER+19) +(defconstant +sb-geticon+ #x0414) ; (WM_USER+20) +(defconstant +sb-setunicodeformat+ #x2005) ; CCM_SETUNICODEFORMAT +(defconstant +sb-getunicodeformat+ #x2006) ; CCM_GETUNICODEFORMAT -(defconstant +sbars-SIZEGRIP+ #x0100) -(defconstant +sbars-TOOLTIPS+ #x0800) +(defconstant +sbars-sizegrip+ #x0100) +(defconstant +sbars-tooltips+ #x0800) (defconstant +sbs-horz+ #x0000) (defconstant +sbs-vert+ #x0001)

1 0

[graphic-forms-cvs] r421 - in trunk: docs/manual src/uitoolkit/system
by junrue＠common-lisp.net 23 Dec '06

23 Dec '06

Author: junrue Date: Fri Dec 22 22:19:32 2006 New Revision: 421 Modified: trunk/docs/manual/gfw-symbols.xml trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp Log: preparation for status-bar implementation Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Fri Dec 22 22:19:32 2006 @@ -1412,6 +1412,7 @@ One or more of the following optional styles: <enum> <argument name=":horizontal-scrollbar"/> + <argument name=":statusbar"/> <argument name=":vertical-scrollbar"/> </enum> </description> Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Fri Dec 22 22:19:32 2006 @@ -922,6 +922,10 @@ (defconstant +ps-geometric+ #x00010000) (defconstant +ps-type-mask+ #x000F0000) +;;; +;;; scrollbar constants +;;; + (defconstant +sb-horz+ 0) (defconstant +sb-vert+ 1) (defconstant +sb-ctl+ 2) @@ -943,6 +947,29 @@ (defconstant +sb-right+ 7) (defconstant +sb-endscroll+ 8) +;;; +;;; statusbar constants +;;; + +(defconstant +sb-SETPARTS+ #x0404) ; (WM_USER+4) +(defconstant +sb-GETPARTS+ #x0406) ; (WM_USER+6) +(defconstant +sb-GETBORDERS+ #x0407) ; (WM_USER+7) +(defconstant +sb-SETMINHEIGHT+ #x0408) ; (WM_USER+8) +(defconstant +sb-SIMPLE+ #x0409) ; (WM_USER+9) +(defconstant +sb-GETRECT+ #x040A) ; (WM_USER+10) +(defconstant +sb-ISSIMPLE+ #x040E) ; (WM_USER+14) +(defconstant +sb-SETICON+ #x040F) ; (WM_USER+15) +(defconstant +sb-SETTIPTEXTA+ #x0410) ; (WM_USER+16) +(defconstant +sb-SETTIPTEXTW+ #x0411) ; (WM_USER+17) +(defconstant +sb-GETTIPTEXTA+ #x0412) ; (WM_USER+18) +(defconstant +sb-GETTIPTEXTW+ #x0413) ; (WM_USER+19) +(defconstant +sb-GETICON+ #x0414) ; (WM_USER+20) +(defconstant +sb-SETUNICODEFORMAT+ #x2005) ; CCM_SETUNICODEFORMAT +(defconstant +sb-GETUNICODEFORMAT+ #x2006) ; CCM_GETUNICODEFORMAT + +(defconstant +sbars-SIZEGRIP+ #x0100) +(defconstant +sbars-TOOLTIPS+ #x0800) + (defconstant +sbs-horz+ #x0000) (defconstant +sbs-vert+ #x0001) (defconstant +sbs-topalign+ #x0002) @@ -954,6 +981,12 @@ (defconstant +sbs-sizebox+ #x0008) (defconstant +sbs-sizegrip+ #x0010) +(defconstant +sbt-ownerdraw+ #x1000) +(defconstant +sbt-noborders+ #x0100) +(defconstant +sbt-popout+ #x0200) +(defconstant +sbt-rtlreading+ #x0400) +(defconstant +sbt-notabparsing+ #x0800) + (defconstant +sif-range+ #x0001) (defconstant +sif-page+ #x0002) (defconstant +sif-pos+ #x0004) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Fri Dec 22 22:19:32 2006 @@ -187,10 +187,24 @@ (defctype dllversioninfo-pointer :pointer) +(defcstruct drawitemstruct + (ctltype UINT) + (ctlid UINT) + (itemid UINT) + (itemaction UINT) + (itemstate UINT) + (hwnd HANDLE) + (hdc HANDLE) + (itemleft LONG) + (itemtop LONG) + (itemright LONG) + (itembottom LONG) + (itemdata :pointer)) + (defcstruct drawtextparams - (cbsize UINT) - (tablength INT) - (leftmargin INT) + (cbsize UINT) + (tablength INT) + (leftmargin INT) (rightmargin INT) (lengthdrawn UINT))

1 0

[graphic-forms-cvs] r420 - trunk/docs/manual
by junrue＠common-lisp.net 21 Dec '06

21 Dec '06

Author: junrue Date: Thu Dec 21 00:00:01 2006 New Revision: 420 Modified: trunk/docs/manual/gfs-symbols.xml Log: documented null-handle-p Modified: trunk/docs/manual/gfs-symbols.xml ============================================================================== --- trunk/docs/manual/gfs-symbols.xml (original) +++ trunk/docs/manual/gfs-symbols.xml Thu Dec 21 00:00:01 2006 @@ -228,6 +228,7 @@ <reftopic>gfs:handle</reftopic> <reftopic>gfs:disposed-error</reftopic> <reftopic>gfs:disposed-p</reftopic> + <reftopic>gfs:null-handle-p</reftopic> </seealso> </class> @@ -584,6 +585,30 @@ </description> </function> + <function name="null-handle-p"> + <syntax> + <arguments> + <argument name="handle"> + <description> + A <emphasis>native handle</emphasis> represented within + Graphic-Forms using the CFFI :pointer type. + </description> + </argument> + </arguments> + <return> + <refclhs>boolean</refclhs> + </return> + </syntax> + <description> + Returns T if <arg0/> is null (meaning that its foreign address is zero); + NIL otherwise. + </description> + <seealso> + <reftopic>gfs:handle</reftopic> + <reftopic>gfs:native-object</reftopic> + </seealso> + </function> + <function name="make-point"> <syntax> <arguments> @@ -1157,6 +1182,7 @@ <reftopic>gfs:dispose</reftopic> <reftopic>gfs:disposed-p</reftopic> <reftopic>gfs:disposed-error</reftopic> + <reftopic>gfs:null-handle-p</reftopic> </seealso> </slot-reader>

1 0

[graphic-forms-cvs] r419 - in trunk: . src/uitoolkit/system
by junrue＠common-lisp.net 21 Dec '06

21 Dec '06

Author: junrue Date: Wed Dec 20 23:31:33 2006 New Revision: 419 Modified: trunk/NEWS.txt trunk/README.txt trunk/src/uitoolkit/system/comctl32.lisp trunk/src/uitoolkit/system/kernel32.lisp trunk/src/uitoolkit/system/metrics.lisp trunk/src/uitoolkit/system/native-object.lisp trunk/src/uitoolkit/system/shell32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-utils.lisp Log: implemented manual DLL loading and function pointer querying; fixed comctl32 and shell32 version querying; changed gfs:null-handle-p to an inlined function from a macro Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Wed Dec 20 23:31:33 2006 @@ -1,6 +1,9 @@ . Graphic-Forms has been ported to Allegro CL 8.0. +. GFS:OBTAIN-SYSTEM-METRICS now includes version information for comctl32.dll + and shell32.dll. + ============================================================================== Release 0.7.0 of Graphic-Forms, a Common Lisp library for Windows GUI Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Wed Dec 20 23:31:33 2006 @@ -17,7 +17,7 @@ http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/ *note: ASDF is bundled with SBCL* - - CFFI (cffi-060925 or later) + - CFFI (cffi-061208 or later) http://common-lisp.net/project/cffi/ - Closer to MOP Modified: trunk/src/uitoolkit/system/comctl32.lisp ============================================================================== --- trunk/src/uitoolkit/system/comctl32.lisp (original) +++ trunk/src/uitoolkit/system/comctl32.lisp Wed Dec 20 23:31:33 2006 @@ -38,10 +38,18 @@ (load-foreign-library "comctl32.dll") +;;; See this thread: +;;; +;;; http://common-lisp.net/pipermail/cffi-devel/2006-December/000971.html +;;; +;;; for a discussion of why the following is commented out. +;;; +#| (defcfun ("DllGetVersion" comctl-dll-get-version) HRESULT (info :pointer)) +|# (defcfun ("InitCommonControlsEx" init-common-controls) Modified: trunk/src/uitoolkit/system/kernel32.lisp ============================================================================== --- trunk/src/uitoolkit/system/kernel32.lisp (original) +++ trunk/src/uitoolkit/system/kernel32.lisp Wed Dec 20 23:31:33 2006 @@ -39,11 +39,29 @@ (load-foreign-library "kernel32.dll") (defcfun + ("FreeLibrary" free-library) + BOOL + (hmodule HANDLE)) + +(defcfun ("GetLastError" get-last-error) DWORD) (defcfun ("GetModuleHandleA" get-module-handle) HANDLE - (module-name LPTR)) ; FIXME: ought to be LPTSTR but I can't see how to define - ; a null string pointer + (module-name LPTSTR)) + +(defcfun + ("GetProcAddress" get-proc-address) + :pointer + (hmodule HANDLE) + (proc-name LPTSTR)) + +(defcfun + ("LoadLibraryExA" load-library) + HANDLE + (file-name LPTSTR) + (hfile HANDLE) ; currently reserved and must be a NULL pointer + (flags DWORD)) + Modified: trunk/src/uitoolkit/system/metrics.lisp ============================================================================== --- trunk/src/uitoolkit/system/metrics.lisp (original) +++ trunk/src/uitoolkit/system/metrics.lisp Wed Dec 20 23:31:33 2006 @@ -33,12 +33,21 @@ (in-package :graphic-forms.uitoolkit.system) -(defun obtain-dll-version-info (foreign-func) - (cffi:with-foreign-object (ptr 'dllversioninfo) - (cffi:with-foreign-slots ((size vermajor verminor buildnum) ptr dllversioninfo) - (setf size (cffi:foreign-type-size 'dllversioninfo)) - (funcall foreign-func ptr) - (list vermajor verminor buildnum)))) +(defun obtain-dll-version-info (dll-path) + (let ((hmodule (load-library-wrapper dll-path)) + (version (list 0 0 0))) + (unless (null-handle-p hmodule) + (unwind-protect + (let ((func-ptr (retrieve-function-pointer hmodule "DllGetVersion"))) + (unless (cffi:null-pointer-p func-ptr) + (cffi:with-foreign-object (info-ptr 'gfs::dllversioninfo) + (cffi:with-foreign-slots ((gfs::size gfs::vermajor gfs::verminor gfs::buildnum) + info-ptr gfs::dllversioninfo) + (setf gfs::size (cffi:foreign-type-size 'gfs::dllversioninfo)) + (cffi:foreign-funcall func-ptr gfs::dllversioninfo info-ptr gfs::hresult) + (setf version (list gfs::vermajor gfs::verminor gfs::buildnum)))))) + (gfs::free-library hmodule))) + version)) (defun obtain-system-metrics () "Query system metrics and return them via a hash table." @@ -118,7 +127,7 @@ ;; A list of integers describing the version of comctl32.dll. ;; (setf (gethash :comctl32-version table) - (obtain-dll-version-info #'comctl-dll-get-version)) + (obtain-dll-version-info "comctl32.dll")) ;; ;; :cursor-size ;; @@ -353,7 +362,7 @@ ;; A list of integers describing the version of comctl32.dll. ;; (setf (gethash :shell32-version table) - (obtain-dll-version-info #'shell-dll-get-version)) + (obtain-dll-version-info "shell32.dll")) ;; ;; :shutting-down ;; Modified: trunk/src/uitoolkit/system/native-object.lisp ============================================================================== --- trunk/src/uitoolkit/system/native-object.lisp (original) +++ trunk/src/uitoolkit/system/native-object.lisp Wed Dec 20 23:31:33 2006 @@ -36,5 +36,6 @@ (defmethod disposed-p ((obj native-object)) (null (handle obj))) -(defmacro null-handle-p (handle) - `(cffi:null-pointer-p ,handle)) +(declaim (inline null-handle-p)) +(defun null-handle-p (handle) + (cffi:null-pointer-p handle)) Modified: trunk/src/uitoolkit/system/shell32.lisp ============================================================================== --- trunk/src/uitoolkit/system/shell32.lisp (original) +++ trunk/src/uitoolkit/system/shell32.lisp Wed Dec 20 23:31:33 2006 @@ -38,7 +38,15 @@ (load-foreign-library "shell32.dll") +;;; See this thread: +;;; +;;; http://common-lisp.net/pipermail/cffi-devel/2006-December/000971.html +;;; +;;; for a discussion of why the following is commented out. +;;; +#| (defcfun ("DllGetVersion" shell-dll-get-version) HRESULT (info :pointer)) +|# Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Wed Dec 20 23:31:33 2006 @@ -1687,6 +1687,14 @@ (defconstant +colormgmtcaps+ 121) ;;; +;;; LoadLibraryEx flags +;;; +(defconstant +dont-resolve-dll-references+ #x00000001) +(defconstant +load-library-as-datafile+ #x00000002) +(defconstant +load-with-altered-search-path+ #x00000008) +(defconstant +load-ignore-code-authz-level+ #x00000010) + +;;; ;;; Background modes (Get/SetBkMode) ;;; (defconstant +transparent+ 1) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Wed Dec 20 23:31:33 2006 @@ -163,6 +163,25 @@ (defun make-lparam (hi lo) (logior (ash (logand lo #xFFFF) 16) (logand hi #xFFFF))) +(defun load-library-wrapper (dll-path) + (let ((hmodule (cffi:null-pointer))) + (cffi:with-foreign-string (str-ptr dll-path) + (setf hmodule (load-library str-ptr (cffi:null-pointer) 0))) + (when (null-handle-p hmodule) + (warn 'toolkit-warning :detail (format nil "could not load ~s" dll-path))) + hmodule)) + +(defun retrieve-function-pointer (hmodule func-name) + (let ((func-ptr (cffi:null-pointer))) + (if (null-handle-p hmodule) + (error 'toolkit-error :detail "null module handle")) + (cffi:with-foreign-string (str-ptr func-name) + (setf func-ptr (gfs::get-proc-address hmodule str-ptr))) + (if (gfs:null-handle-p func-ptr) + (let ((detail (format nil "could not get function pointer for ~s" func-name))) + (warn 'gfs:toolkit-warning :detail detail))) + func-ptr)) + ;;; ;;; convenience macros ;;;

1 0

[graphic-forms-cvs] r418 - trunk/etc
by junrue＠common-lisp.net 18 Dec '06

18 Dec '06

Author: junrue Date: Mon Dec 18 00:59:57 2006 New Revision: 418 Modified: trunk/etc/lisp.exe.manifest Log: this manifest works correctly, at least with clisp Modified: trunk/etc/lisp.exe.manifest ============================================================================== --- trunk/etc/lisp.exe.manifest (original) +++ trunk/etc/lisp.exe.manifest Mon Dec 18 00:59:57 2006 @@ -1,10 +1,10 @@ <?xml version="1.0" encoding="UTF-8" standalone="yes"?> <assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> - <assemblyIdentity processorArchitecture="x86" name="clisp" type="win32"/> - <description>GNU CLISP</description> - <dependency> - <dependentAssembly> - <assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" processorArchitecture="x86" publicKeyToken="6595b64144ccf1df" language="*"/> - </dependentAssembly> - </dependency> + <assemblyIdentity version="1.0.0.0" processorArchitecture="X86" name="clisp" type="win32"/> + <description>GNU CLISP</description> + <dependency> + <dependentAssembly> + <assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" processorArchitecture="X86" publicKeyToken="6595b64144ccf1df" language="*"/> + </dependentAssembly> + </dependency> </assembly>

1 0

[graphic-forms-cvs] r417 - in trunk: . docs/manual src/uitoolkit/system
by junrue＠common-lisp.net 18 Dec '06

18 Dec '06

Author: junrue Date: Mon Dec 18 00:22:52 2006 New Revision: 417 Added: trunk/src/uitoolkit/system/shell32.lisp Modified: trunk/docs/manual/gfc-symbols.xml trunk/docs/manual/gfs-symbols.xml trunk/docs/manual/legal.xml trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/system/comctl32.lisp trunk/src/uitoolkit/system/metrics.lisp trunk/src/uitoolkit/system/system-types.lisp Log: enhanced obtain-system-metrics to include version info for comctl32.dll and shell32.dll, but still need to track down why duplicate version info is returned Modified: trunk/docs/manual/gfc-symbols.xml ============================================================================== --- trunk/docs/manual/gfc-symbols.xml (original) +++ trunk/docs/manual/gfc-symbols.xml Mon Dec 18 00:22:52 2006 @@ -17,6 +17,51 @@  + <class name="listener-panel"> + <description> + <hierarchy> + <inherits> + <reftopic>gfw:panel</reftopic> + </inherits> + </hierarchy> + This class implements a text-based input/output component which + can serve as a REPL. Its size and location can be + maintained by its parent's layout manager; however, note that best + visual results are achieved when the panel is allowed to maintain + integral height and width. + </description> + <initargs> + <argument name=":callbacks"> + <description> + See <reftopic>gfw:event-source</reftopic>. + </description> + </argument> + <argument name=":dispatcher"> + <description> + See <reftopic>gfw:event-source</reftopic>. + </description> + </argument> + <argument name=":handle"> + <description> + See <reftopic>gfs:native-object</reftopic>. + </description> + </argument> + <argument name=":parent"> + <description> + See <reftopic>gfw:panel</reftopic>. + </description> + </argument> + <argument name=":style"> + <description> + </description> + </argument> + </initargs> + <seealso> + <reftopic>gfs:dispose</reftopic> + <reftopic>gfw:parent</reftopic> + </seealso> + </class> +   Modified: trunk/docs/manual/gfs-symbols.xml ============================================================================== --- trunk/docs/manual/gfs-symbols.xml (original) +++ trunk/docs/manual/gfs-symbols.xml Mon Dec 18 00:22:52 2006 @@ -370,6 +370,13 @@ button type. </description> </argument> + <argument name=":comctl32-version"> + <description> + A <refclhs>list</refclhs> whose first element is an integer specifying + comctl32.dll's major version number. The second element is the DLL's + minor version number, and the third element is the DLL's build number. + </description> + </argument> <argument name=":cursor-size"> <description> A <reftopic>gfs:size</reftopic> describing the dimensions of a cursor @@ -535,6 +542,13 @@ arrow bitmap. </description> </argument> + <argument name=":shell32-version"> + <description> + A <refclhs>list</refclhs> whose first element is an integer specifying + shell32.dll's major version number. The second element is the DLL's + minor version number, and the third element is the DLL's build number. + </description> + </argument> <argument name=":shutting-down"> <description> T if the current session is shutting down; NIL otherwise. Modified: trunk/docs/manual/legal.xml ============================================================================== --- trunk/docs/manual/legal.xml (original) +++ trunk/docs/manual/legal.xml Mon Dec 18 00:22:52 2006 @@ -1,12 +1,12 @@  <chapter id="legal"> <title>Legal Notices</title> <para> - Copyright © 2006, Jack D. Unrue <jdunrue at gmail dot com> + Copyright © 2006-2007, Jack D. Unrue <jdunrue at gmail dot com> </para> <para role="normal"> Redistribution and use in source and binary forms, with or without Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Dec 18 00:22:52 2006 @@ -67,8 +67,9 @@ (:file "system-types") (:file "datastructs") (:file "clib") - (:file "comdlg32") (:file "comctl32") + (:file "comdlg32") + (:file "shell32") (:file "gdi32") (:file "kernel32") (:file "user32") Modified: trunk/src/uitoolkit/system/comctl32.lisp ============================================================================== --- trunk/src/uitoolkit/system/comctl32.lisp (original) +++ trunk/src/uitoolkit/system/comctl32.lisp Mon Dec 18 00:22:52 2006 @@ -39,6 +39,11 @@ (load-foreign-library "comctl32.dll") (defcfun + ("DllGetVersion" comctl-dll-get-version) + HRESULT + (info :pointer)) + +(defcfun ("InitCommonControlsEx" init-common-controls) BOOL (init LPTR)) Modified: trunk/src/uitoolkit/system/metrics.lisp ============================================================================== --- trunk/src/uitoolkit/system/metrics.lisp (original) +++ trunk/src/uitoolkit/system/metrics.lisp Mon Dec 18 00:22:52 2006 @@ -33,6 +33,13 @@ (in-package :graphic-forms.uitoolkit.system) +(defun obtain-dll-version-info (foreign-func) + (cffi:with-foreign-object (ptr 'dllversioninfo) + (cffi:with-foreign-slots ((size vermajor verminor buildnum) ptr dllversioninfo) + (setf size (cffi:foreign-type-size 'dllversioninfo)) + (funcall foreign-func ptr) + (list vermajor verminor buildnum)))) + (defun obtain-system-metrics () "Query system metrics and return them via a hash table." (let ((table (make-hash-table))) @@ -106,6 +113,13 @@ (make-size :width (get-system-metrics +sm-cxsmsize+) :height (get-system-metrics +sm-cysmsize+)))) ;; + ;; :comctl32-version + ;; + ;; A list of integers describing the version of comctl32.dll. + ;; + (setf (gethash :comctl32-version table) + (obtain-dll-version-info #'comctl-dll-get-version)) + ;; ;; :cursor-size ;; ;; The size of the cursor image in pixels. @@ -334,6 +348,13 @@ (make-size :width (get-system-metrics +sm-cxhscroll+) :height (get-system-metrics +sm-cyvscroll+))) ;; + ;; :shell32-version + ;; + ;; A list of integers describing the version of comctl32.dll. + ;; + (setf (gethash :shell32-version table) + (obtain-dll-version-info #'shell-dll-get-version)) + ;; ;; :shutting-down ;; ;; T if the current session is shutting down; NIL otherwise. Added: trunk/src/uitoolkit/system/shell32.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/system/shell32.lisp Mon Dec 18 00:22:52 2006 @@ -0,0 +1,44 @@ +;;;; +;;;; shell32.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.system) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :cffi)) + +(load-foreign-library "shell32.dll") + +(defcfun + ("DllGetVersion" shell-dll-get-version) + HRESULT + (info :pointer)) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Mon Dec 18 00:22:52 2006 @@ -45,33 +45,33 @@ :unicode :ascii)) -(defctype ATOM :unsigned-short) ; shadowed in gfs: package -(defctype BOOL :int) -(defctype BOOLEAN :char) ; shadowed in gfs: package -(defctype BYTE :unsigned-char) +(defctype ATOM :unsigned-short) ; shadowed in gfs: package +(defctype BOOL :int) +(defctype BOOLEAN :char) ; shadowed in gfs: package +(defctype BYTE :unsigned-char) (defctype COLORREF :unsigned-long) -(defctype DWORD :unsigned-long) -(defctype HANDLE :pointer) -(defctype INT :int) -(defctype LANGID :short) -(defctype LONG :long) -(defctype LPARAM :long) -(defctype LPCSTR :pointer) -(defctype LPCTSTR :pointer) -(defctype LPFN :long) ; FIXME: not currently used; maybe should be :pointer instead -(defctype LPRECT :pointer) -(defctype LPSTR :pointer) -(defctype LPTR :pointer) -(defctype LPTSTR :pointer) -(defctype LPVOID :long) -(defctype LRESULT :unsigned-long) -(defctype SHORT :unsigned-short) -(defctype TCHAR :char) -(defctype UINT :unsigned-int) -(defctype ULONG :unsigned-long) -(defctype USHORT :unsigned-short) -(defctype WORD :short) -(defctype WPARAM :unsigned-int) +(defctype DWORD :unsigned-long) +(defctype HANDLE :pointer) +(defctype HRESULT :unsigned-int) +(defctype INT :int) +(defctype LANGID :short) +(defctype LONG :long) +(defctype LPARAM :long) +(defctype LPCSTR :pointer) +(defctype LPCTSTR :pointer) +(defctype LPRECT :pointer) +(defctype LPSTR :pointer) +(defctype LPTR :pointer) +(defctype LPTSTR :pointer) +(defctype LPVOID :long) +(defctype LRESULT :unsigned-long) +(defctype SHORT :unsigned-short) +(defctype TCHAR :char) +(defctype UINT :unsigned-int) +(defctype ULONG :unsigned-long) +(defctype USHORT :unsigned-short) +(defctype WORD :short) +(defctype WPARAM :unsigned-int) #+sbcl (sb-alien:define-alien-type enumchildproc @@ -178,6 +178,15 @@ (minsize INT) (maxsize INT)) +(defcstruct dllversioninfo + (size DWORD) + (vermajor DWORD) + (verminor DWORD) + (buildnum DWORD) + (platform DWORD)) + +(defctype dllversioninfo-pointer :pointer) + (defcstruct drawtextparams (cbsize UINT) (tablength INT) @@ -209,7 +218,7 @@ (defcstruct initcommoncontrolsex (size DWORD) - (icc DWORD)) + (icc DWORD)) (defcstruct logbrush (style UINT)

1 0

[graphic-forms-cvs] r416 - in trunk: . docs/manual src/demos/textedit src/demos/unblocked
by junrue＠common-lisp.net 17 Dec '06

17 Dec '06

Author: junrue Date: Sun Dec 17 00:59:28 2006 New Revision: 416 Added: trunk/docs/manual/gfc-symbols.xml Modified: trunk/README.txt trunk/docs/manual/Makefile trunk/docs/manual/api.xml trunk/docs/manual/graphic-forms.xml trunk/docs/manual/graphic-forms.xsl trunk/docs/manual/introduction.xml trunk/graphic-forms-tests.asd trunk/graphic-forms-uitoolkit.asd trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/unblocked-window.lisp Log: bump up version string Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Sun Dec 17 00:59:28 2006 @@ -1,6 +1,6 @@ -Graphic-Forms README for version 0.7.0 (1 December 2006) -Copyright (c) 2006, Jack D. Unrue +Graphic-Forms README for version 0.8.0 (xx xxxxxx 2007) +Copyright (c) 2006-2007, Jack D. Unrue Graphic-Forms is a user interface library implemented in Common Lisp focusing on the Windows(R) platform. Graphic-Forms is licensed under the terms of the Modified: trunk/docs/manual/Makefile ============================================================================== --- trunk/docs/manual/Makefile (original) +++ trunk/docs/manual/Makefile Sun Dec 17 00:59:28 2006 @@ -2,19 +2,20 @@ # # Makefile # -# Copyright (c) 2006, Jack D. Unrue +# Copyright (c) 2006-2007, Jack D. Unrue # -VERSION = 0.7 +VERSION = 0.8 -CHM-DEPS = gfs-tmp-pkg.xml gfg-tmp-pkg.xml gfw-tmp-pkg.xml \ +CHM-DEPS = gfs-tmp-pkg.xml gfg-tmp-pkg.xml gfw-tmp-pkg.xml gfc-tmp-pkg.xml \ constants.xml api.xml \ catalog.xml glossary.xml graphic-forms.xml image-data-plugins.xml \ introduction.xml legal.xml miscellaneous-topics.xml COMMON-DEPS = gf-data.xsl gf-package.xsl clhs-table.xml win32-api-table.xml TMP-XML = gfs-tmp-pkg.xml gfs-tmp-syms.xml gfg-tmp-pkg.xml gfg-tmp-syms.xml \ - gfw-tmp-pkg.xml gfw-tmp-syms.xml tmp.xml + gfw-tmp-pkg.xml gfw-tmp-syms.xml gfc-tmp-pkg.xml gfc-tmp-syms.xml \ + tmp.xml XSLT-PROC = xsltproc --nonet @@ -24,6 +25,12 @@ -hhc htmlhelp.hhp; exit 0 # muffle Error Ignored msg due to hhc exit value 1 find . $ -name "*~" -o -name "*.html" -o -name "*.hhk" -o -name "*.hhc" -o -name "*.hhp" $ -exec rm {} \; +gfc-tmp-syms.xml: gfc-symbols.xml $(COMMON-DEPS) + $(XSLT-PROC) --output $@ gf-data.xsl gfc-symbols.xml + +gfc-tmp-pkg.xml: gfc-tmp-syms.xml gfc-symbols.xml $(COMMON-DEPS) + $(XSLT-PROC) --stringparam symbol-file gfc-tmp-syms.xml --output $@ gf-package.xsl gfc-symbols.xml + gfs-tmp-syms.xml: gfs-symbols.xml $(COMMON-DEPS) $(XSLT-PROC) --output $@ gf-data.xsl gfs-symbols.xml Modified: trunk/docs/manual/api.xml ============================================================================== --- trunk/docs/manual/api.xml (original) +++ trunk/docs/manual/api.xml Sun Dec 17 00:59:28 2006 @@ -1,7 +1,7 @@  <chapter id="api"> <title>API Reference</title> @@ -11,6 +11,7 @@ </para> &constants; + &gfcpkg; &gfgpkg; &gfspkg; &gfwpkg; Added: trunk/docs/manual/gfc-symbols.xml ============================================================================== --- (empty file) +++ trunk/docs/manual/gfc-symbols.xml Sun Dec 17 00:59:28 2006 @@ -0,0 +1,28 @@ +<?xml version="1.0"?> + + +<package name="gfc" fullname="graphic-forms.uitoolkit.custom"> + + <description> + The symbols in this package correspond to custom components built on top + of the rest of the library which don't necessarily have an immediate + native peer. + </description> + +  + +  + +  + +  + +  + +  + +</package> Modified: trunk/docs/manual/graphic-forms.xml ============================================================================== --- trunk/docs/manual/graphic-forms.xml (original) +++ trunk/docs/manual/graphic-forms.xml Sun Dec 17 00:59:28 2006 @@ -2,7 +2,7 @@  <!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ @@ -10,6 +10,7 @@ <!ENTITY introduction SYSTEM "introduction.xml"> <!ENTITY api SYSTEM "api.xml"> <!ENTITY constants SYSTEM "constants.xml"> + <!ENTITY gfcpkg SYSTEM "gfc-tmp-pkg.xml">  <!ENTITY gfgpkg SYSTEM "gfg-tmp-pkg.xml">  <!ENTITY gfspkg SYSTEM "gfs-tmp-pkg.xml">  <!ENTITY gfwpkg SYSTEM "gfw-tmp-pkg.xml">  Modified: trunk/docs/manual/graphic-forms.xsl ============================================================================== --- trunk/docs/manual/graphic-forms.xsl (original) +++ trunk/docs/manual/graphic-forms.xsl Sun Dec 17 00:59:28 2006 @@ -2,7 +2,7 @@  <xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform" version="1.0"> @@ -31,7 +31,7 @@ --> <xsl:template name="user.footer.content"> <div class="footer"> - Copyright © 2006, Jack D. Unrue + Copyright © 2006-2007, Jack D. Unrue </div> </xsl:template> Modified: trunk/docs/manual/introduction.xml ============================================================================== --- trunk/docs/manual/introduction.xml (original) +++ trunk/docs/manual/introduction.xml Sun Dec 17 00:59:28 2006 @@ -1,7 +1,7 @@  <chapter id="introduction"> <title>Introduction</title> @@ -46,6 +46,7 @@ <title>Prerequisites</title> <bridgehead renderas="sect2">Supported Common Lisp Implementations</bridgehead> <itemizedlist mark="bullet" spacing="compact"> + <listitem>Allegro CL 8.0</listitem> <listitem>CLISP 2.40 or later</listitem> <listitem>LispWorks 4.4.6</listitem> <listitem> @@ -80,7 +81,7 @@ <listitem> <ulink url="http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf"/> <para role="normal"> - Note that ASDF is bundled with SBCL. + Note that ASDF is bundled with Allegro CL and SBCL. </para> </listitem> </varlistentry> Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Dec 17 00:59:28 2006 @@ -3,7 +3,7 @@ ;;;; ;;;; graphic-forms-tests.asd ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -56,7 +56,7 @@ (defsystem graphic-forms-tests :description "Graphic-Forms UI Toolkit Tests" - :version "0.7.0" + :version "0.8.0" :author "Jack D. Unrue" :licence "BSD" :components Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sun Dec 17 00:59:28 2006 @@ -3,7 +3,7 @@ ;;;; ;;;; graphic-forms-uitoolkit.asd ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -41,7 +41,7 @@ (defsystem graphic-forms-uitoolkit :description "Graphic-Forms UI Toolkit" - :version "0.7.0" + :version "0.8.0" :author "Jack D. Unrue" :licence "BSD" :depends-on ("cffi" "lw-compat" "closer-mop" "macro-utilities" "binary-data") Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Sun Dec 17 00:59:28 2006 @@ -1,7 +1,7 @@ ;;;; ;;;; textedit-window.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -159,7 +159,7 @@ (declare (ignore disp item)) (let* ((*default-pathname-defaults* (parse-namestring gfsys::*textedit-dir*)) (image-path (merge-pathnames "about.bmp"))) - (about-demo *textedit-win* image-path "About TextEdit" "TextEdit version 0.7"))) + (about-demo *textedit-win* image-path "About TextEdit" "TextEdit version 0.8"))) (defun textedit-startup () (let ((menubar (gfw:defmenu ((:item "&File" :callback #'manage-textedit-file-menu Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Dec 17 00:59:28 2006 @@ -1,7 +1,7 @@ ;;;; ;;;; unblocked-window.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -87,7 +87,7 @@ (declare (ignore disp item)) (let* ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*)) (image-path (merge-pathnames "about.bmp"))) - (about-demo *unblocked-win* image-path "About UnBlocked" "UnBlocked version 0.7"))) + (about-demo *unblocked-win* image-path "About UnBlocked" "UnBlocked version 0.8"))) (defun unblocked-startup () (let ((menubar (gfw:defmenu ((:item "&File"

1 0

[graphic-forms-cvs] r415 - in trunk: . docs/manual docs/website
by junrue＠common-lisp.net 17 Dec '06

17 Dec '06

Author: junrue Date: Sat Dec 16 23:39:12 2006 New Revision: 415 Modified: trunk/NEWS.txt trunk/README.txt trunk/docs/manual/legal.xml trunk/docs/website/index.html Log: ACL port: doc updates Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Sat Dec 16 23:39:12 2006 @@ -1,3 +1,8 @@ + +. Graphic-Forms has been ported to Allegro CL 8.0. + +============================================================================== + Release 0.7.0 of Graphic-Forms, a Common Lisp library for Windows GUI programming, is now available. This is an alpha release, meaning that the feature set and API have not yet stabilized. Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Sat Dec 16 23:39:12 2006 @@ -43,8 +43,8 @@ Supported Common Lisp Implementations ------------------------------------- -Graphic-Forms currently supports CLISP 2.40 or higher, LispWorks 4.4.6, -and SBCL 0.9.15 or higher (with a small patch). +Graphic-Forms currently supports Allegro CL 8.0, CLISP 2.40 or higher, +LispWorks 4.4.6, and SBCL 0.9.15 or higher (with a small patch). Known Problems Modified: trunk/docs/manual/legal.xml ============================================================================== --- trunk/docs/manual/legal.xml (original) +++ trunk/docs/manual/legal.xml Sat Dec 16 23:39:12 2006 @@ -41,8 +41,8 @@ <bridgehead renderas="sect2">Trademarks</bridgehead> <para role="normal"> - Windows® is a registered trademark of Microsoft Corporation. LispWorks - is a trademark of LispWorks Ltd. All other trademarks used are owned by their - respective owners. + Windows® is a registered trademark of Microsoft Corporation. Allegro CL® + is a registered trademark of Franz Inc. LispWorks® is a registered trademark of + LispWorks Ltd. All other trademarks used are owned by their respective owners. </para> </chapter> Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Sat Dec 16 23:39:12 2006 @@ -38,7 +38,7 @@ The current version is <a href="http://sourceforge.net/project/showfiles.php?group_id=163034"> - 0.7.0</a>, released on 1 December 2006. + 0.8.0</a>, released on xx xxxxxxx 2007. Graphic-Forms is in the alpha stage of development, meaning new features are still being added and existing features require @@ -47,6 +47,7 @@ The supported Lisp implementations are: <ul> + <li><a href="http://franz.com/">Allegro CL 8.0</a> or later</li> <li><a href="http://clisp.cons.org/">CLISP 2.40</a> or later</li> <li><a href="http://www.lispworks.com/">LispWorks 4.4.6</a></li> <li><a href="http://www.sbcl.org/">SBCL 0.9.15</a> or later</li> @@ -67,7 +68,8 @@ Trademarks Windows® is a registered trademark of <a href="http://www.microsoft.com/">Microsoft</a>. - LispWorks is a trademark of <a href="http://www.lispworks.com/">LispWorks Ltd</a>. All other + Allegro CL® is a registered trademark of <a href="http://franz.com/">Franz Inc</a>. + LispWorks® is a registered trademark of <a href="http://www.lispworks.com/">LispWorks Ltd</a>. All other trademarks used are owned by their respective owners. <a href="http://sourceforge.net"><IMG src="http://sourceforge.net/sflogo.php?group_id=20959" width="88" height="31" border="0" alt="SourceForge Logo"></a>

1 0

[graphic-forms-cvs] r414 - in trunk/src/uitoolkit: system widgets
by junrue＠common-lisp.net 17 Dec '06

17 Dec '06

Author: junrue Date: Sat Dec 16 23:12:03 2006 New Revision: 414 Modified: trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/display.lisp trunk/src/uitoolkit/widgets/window.lisp Log: ACL port: fix mistakes in callback definitions Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sat Dec 16 23:12:03 2006 @@ -220,14 +220,6 @@ |# #+allegro -(eval-when (:compile-toplevel :load-toplevel :execute) - (ff:defun-foreign-callable enum-child-windows-callback ((hwnd :foreign-address) - (lparam :long)) - (declare (:convention :stdcall))) - - (ff:register-foreign-callable 'enum-child-windows-callback :reuse t)) - -#+allegro (ff:def-foreign-call (enum-child-windows "EnumChildWindows") ((hwnd :foreign-address) (func :foreign-address) @@ -277,16 +269,6 @@ |# #+allegro -(eval-when (:compile-toplevel :load-toplevel :execute) - (ff:defun-foreign-callable enum-display-monitors-callback ((hmonitor :foreign-address) - (hdc :foreign-address) - (monitorrect :foreign-address) - (data :long)) - (declare (:convention :stdcall))) - - (ff:register-foreign-callable 'enum-display-monitors-callback :reuse t)) - -#+allegro (ff:def-foreign-call (enum-display-monitors "EnumDisplayMonitors") ((hdc :foreign-address) (cliprect :foreign-address) @@ -341,14 +323,6 @@ |# #+allegro -(eval-when (:compile-toplevel :load-toplevel :execute) - (ff:defun-foreign-callable enum-thread-windows-callback ((hwnd :foreign-address) - (lparam :long)) - (declare (:convention :stdcall))) - - (ff:register-foreign-callable 'enum-thread-windows-callback :reuse t)) - -#+allegro (ff:def-foreign-call (enum-thread-windows "EnumThreadWindows") ((thread-id :unsigned-long) (func :foreign-address) Modified: trunk/src/uitoolkit/widgets/display.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/display.lisp (original) +++ trunk/src/uitoolkit/widgets/display.lisp Sat Dec 16 23:12:03 2006 @@ -37,6 +37,23 @@ ;;; helper functions ;;; +(defun display-visitor (hmonitor hdc monitorrect data) + (declare (ignore hdc monitorrect)) + (call-display-visitor-func (thread-context) hmonitor data) + 1) + +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (ff:defun-foreign-callable enum-display-monitors-callback ((hmonitor :foreign-address) + (hdc :foreign-address) + (monitorrect :foreign-address) + (data :long)) + (declare (:convention :stdcall)) + (call-display-visitor-func (thread-context) hmonitor data)) + + (defvar *monitors-enum-proc* + (ff:register-foreign-callable 'enum-display-monitors-callback :reuse t))) + #+lispworks (fli:define-foreign-callable ("display_visitor" :result-type :integer :calling-convention :stdcall) @@ -48,11 +65,6 @@ (call-display-visitor-func (thread-context) hmonitor data) 1) -(defun display-visitor (hmonitor hdc monitorrect data) - (declare (ignore hdc monitorrect)) - (call-display-visitor-func (thread-context) hmonitor data) - 1) - #+sbcl (defvar *monitors-enum-proc* (sb-alien::alien-callback @@ -97,7 +109,10 @@ (let ((tc (thread-context))) (setf (display-visitor-func tc) func) (unwind-protect -#+(or allegro clisp) +#+allegro + (let ((ptr (cffi:null-pointer))) + (gfs::enum-display-monitors ptr ptr (cffi:pointer-address *monitors-enum-proc*) 0)) +#+clisp (gfs::enum-display-monitors nil nil #'display-visitor nil) #+lispworks (let ((ptr (fli:make-pointer :address 0))) @@ -127,6 +142,16 @@ (call-top-level-visitor-func tc win))) 1) +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (ff:defun-foreign-callable enum-thread-windows-callback ((hwnd :foreign-address) + (lparam :long)) + (declare (:convention :stdcall)) + (top-level-window-visitor hwnd lparam)) + + (defvar *enum-thread-wnd-proc* + (ff:register-foreign-callable 'enum-thread-windows-callback :reuse t))) + #+lispworks (fli:define-foreign-callable ("top_level_window_visitor" :result-type :integer :calling-convention :stdcall) @@ -152,7 +177,11 @@ (let ((tc (thread-context))) (setf (top-level-visitor-func tc) func) (unwind-protect -#+(or allegro clisp) +#+allegro + (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) + (cffi:pointer-address *enum-thread-wnd-proc*) + 0) +#+clisp (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) #'top-level-window-visitor 0) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sat Dec 16 23:12:03 2006 @@ -79,6 +79,16 @@ (setf (child-visitor-results tc) (push (call-child-visitor-func tc parent child) tmp-list)))))) 1) +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (ff:defun-foreign-callable enum-child-windows-callback ((hwnd :foreign-address) + (lparam :long)) + (declare (:convention :stdcall)) + (child-window-visitor hwnd lparam)) + + (defvar *enum-child-proc* + (ff:register-foreign-callable 'enum-child-windows-callback :reuse t))) + #+lispworks (fli:define-foreign-callable ("child_window_visitor" :result-type :integer :calling-convention :stdcall) @@ -329,7 +339,11 @@ (hwnd (gfs:handle self))) (setf (child-visitor-func tc) func) (unwind-protect -#+(or allegro clisp) +#+allegro + (gfs::enum-child-windows hwnd + (cffi:pointer-address *enum-child-proc*) + (cffi:pointer-address hwnd)) +#+clisp (gfs::enum-child-windows hwnd #'child-window-visitor (cffi:pointer-address hwnd))

1 0

[graphic-forms-cvs] r413 - in trunk/src/uitoolkit: system widgets
by junrue＠common-lisp.net 17 Dec '06

17 Dec '06

Author: junrue Date: Sat Dec 16 22:47:24 2006 New Revision: 413 Modified: trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/display.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: AllegroCL 8.0 port Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sat Dec 16 22:47:24 2006 @@ -219,13 +219,19 @@ (lparam LPARAM)) |# -#+lispworks -(fli:define-foreign-function - (enum-child-windows "EnumChildWindows") - ((hwnd :pointer) - (func :pointer) - (lparam :long)) - :result-type :int) +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (ff:defun-foreign-callable enum-child-windows-callback ((hwnd :foreign-address) + (lparam :long)) + (declare (:convention :stdcall))) + + (ff:register-foreign-callable 'enum-child-windows-callback :reuse t)) + +#+allegro +(ff:def-foreign-call (enum-child-windows "EnumChildWindows") + ((hwnd :foreign-address) + (func :foreign-address) + (lparam :long))) #+clisp (ffi:def-call-out enum-child-windows @@ -242,6 +248,14 @@ (lparam ffi:long)) (:return-type ffi:int)) +#+lispworks +(fli:define-foreign-function + (enum-child-windows "EnumChildWindows") + ((hwnd :pointer) + (func :pointer) + (lparam :long)) + :result-type :int) + #+sbcl (sb-alien:define-alien-routine ("EnumChildWindows" enum-child-windows) sb-alien:int (hwnd sb-alien:system-area-pointer) @@ -262,14 +276,22 @@ (data LPARAM)) |# -#+lispworks -(fli:define-foreign-function - (enum-display-monitors "EnumDisplayMonitors") - ((hdc :pointer) - (cliprect :pointer) - (enumproc :pointer) - (data :long)) - :result-type :int) +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (ff:defun-foreign-callable enum-display-monitors-callback ((hmonitor :foreign-address) + (hdc :foreign-address) + (monitorrect :foreign-address) + (data :long)) + (declare (:convention :stdcall))) + + (ff:register-foreign-callable 'enum-display-monitors-callback :reuse t)) + +#+allegro +(ff:def-foreign-call (enum-display-monitors "EnumDisplayMonitors") + ((hdc :foreign-address) + (cliprect :foreign-address) + (func :foreign-address) + (data :foreign-address))) #+clisp (ffi:def-call-out enum-display-monitors @@ -289,6 +311,15 @@ (data ffi:c-pointer)) (:return-type ffi:int)) +#+lispworks +(fli:define-foreign-function + (enum-display-monitors "EnumDisplayMonitors") + ((hdc :pointer) + (cliprect :pointer) + (enumproc :pointer) + (data :long)) + :result-type :int) + #+sbcl (sb-alien:define-alien-routine ("EnumDisplayMonitors" enum-display-monitors) sb-alien:int (hdc sb-alien:system-area-pointer) @@ -309,13 +340,19 @@ (lparam LPARAM)) |# -#+lispworks -(fli:define-foreign-function - (enum-thread-windows "EnumThreadWindows") - ((threadid (:unsigned :long)) - (func :pointer) - (lparam :long)) - :result-type :int) +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (ff:defun-foreign-callable enum-thread-windows-callback ((hwnd :foreign-address) + (lparam :long)) + (declare (:convention :stdcall))) + + (ff:register-foreign-callable 'enum-thread-windows-callback :reuse t)) + +#+allegro +(ff:def-foreign-call (enum-thread-windows "EnumThreadWindows") + ((thread-id :unsigned-long) + (func :foreign-address) + (lparam :long))) #+clisp (ffi:def-call-out enum-thread-windows @@ -332,6 +369,14 @@ (lparam ffi:long)) (:return-type ffi:int)) +#+lispworks +(fli:define-foreign-function + (enum-thread-windows "EnumThreadWindows") + ((threadid (:unsigned :long)) + (func :pointer) + (lparam :long)) + :result-type :int) + #+sbcl (sb-alien:define-alien-routine ("EnumThreadWindows" enum-thread-windows) sb-alien:int (id sb-alien:unsigned-long) Modified: trunk/src/uitoolkit/widgets/display.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/display.lisp (original) +++ trunk/src/uitoolkit/widgets/display.lisp Sat Dec 16 22:47:24 2006 @@ -97,14 +97,14 @@ (let ((tc (thread-context))) (setf (display-visitor-func tc) func) (unwind-protect -#+sbcl - (let ((ptr (cffi:null-pointer))) - (gfs::enum-display-monitors ptr ptr (sb-alien:alien-sap *monitors-enum-proc*) 0)) +#+(or allegro clisp) + (gfs::enum-display-monitors nil nil #'display-visitor nil) #+lispworks (let ((ptr (fli:make-pointer :address 0))) (gfs::enum-display-monitors ptr ptr (fli:make-pointer :symbol-name "display_visitor") 0)) -#+clisp - (gfs::enum-display-monitors nil nil #'display-visitor nil) +#+sbcl + (let ((ptr (cffi:null-pointer))) + (gfs::enum-display-monitors ptr ptr (sb-alien:alien-sap *monitors-enum-proc*) 0)) (setf (display-visitor-func tc) nil)) (let ((tmp (reverse (display-visitor-results tc)))) (setf (display-visitor-results tc) nil) @@ -152,17 +152,17 @@ (let ((tc (thread-context))) (setf (top-level-visitor-func tc) func) (unwind-protect -#+sbcl +#+(or allegro clisp) (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) - (sb-alien:alien-sap *enum-thread-wnd-proc*) + #'top-level-window-visitor 0) #+lispworks (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) (fli:make-pointer :symbol-name "top_level_window_visitor") 0) -#+clisp +#+sbcl (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) - #'top-level-window-visitor + (sb-alien:alien-sap *enum-thread-wnd-proc*) 0) (setf (top-level-visitor-func tc) nil)) (let ((tmp (reverse (top-level-visitor-results tc)))) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Sat Dec 16 22:47:24 2006 @@ -62,10 +62,12 @@ ;; ;; TODO: change this once we understand SBCL MT support ;; -#+(or clisp sbcl) +;; TODO: support Allegro MT +;; +#+(or allegro clisp sbcl) (defvar *the-thread-context* nil) -#+(or clisp sbcl) +#+(or allegro clisp sbcl) (defun thread-context () (when (null *the-thread-context*) (setf *the-thread-context* (make-instance 'thread-context)) @@ -76,7 +78,7 @@ (format *error-output* "~a~%" e)))) *the-thread-context*) -#+(or clisp sbcl) +#+(or allegro clisp sbcl) (defun dispose-thread-context () (let ((hwnd (utility-hwnd *the-thread-context*))) (unless (gfs:null-handle-p hwnd) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sat Dec 16 22:47:24 2006 @@ -87,7 +87,7 @@ (translate-and-dispatch msg-ptr) nil))) -#+(or clisp sbcl) +#+(or allegro clisp sbcl) (defun startup (thread-name start-fn) (declare (ignore thread-name)) (funcall start-fn) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sat Dec 16 22:47:24 2006 @@ -306,7 +306,6 @@ (gfs:make-point :x gfs::x :y gfs::y)))))) (defmethod (setf location) :before ((pnt gfs:point) (self widget)) - (declare (ignore pnt)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) @@ -433,7 +432,6 @@ (client-size self)) (defmethod (setf size) :before ((size gfs:size) (self widget)) - (declare (ignore size)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sat Dec 16 22:47:24 2006 @@ -329,17 +329,17 @@ (hwnd (gfs:handle self))) (setf (child-visitor-func tc) func) (unwind-protect -#+sbcl +#+(or allegro clisp) (gfs::enum-child-windows hwnd - (sb-alien:alien-sap *enum-child-proc*) + #'child-window-visitor (cffi:pointer-address hwnd)) #+lispworks (gfs::enum-child-windows hwnd (fli:make-pointer :symbol-name "child_window_visitor") (cffi:pointer-address hwnd)) -#+clisp +#+sbcl (gfs::enum-child-windows hwnd - #'child-window-visitor + (sb-alien:alien-sap *enum-child-proc*) (cffi:pointer-address hwnd)) (setf (child-visitor-func tc) nil)) (let ((tmp (reverse (child-visitor-results tc))))

1 0