win32forth-cvs — CVS Commit List

[Win32forth-cvs] win32forth-stc/src/lib ADO.f, NONE, 1.1 AXControl.F, NONE, 1.1 FlashControl.F, NONE, 1.1 HTMLcontrol.F, NONE, 1.1 HtmlDisplayControl.f, NONE, 1.1 HtmlDisplayWindow.f, NONE, 1.1 PDFControl.F, NONE, 1.1

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src/lib
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv7404

Added Files:
	ADO.f AXControl.F FlashControl.F HTMLcontrol.F 
	HtmlDisplayControl.f HtmlDisplayWindow.f PDFControl.F 
Log Message:
Jos: Tom Dixon's COM-libs.

--- NEW FILE: HtmlDisplayControl.f ---
\    File: HtmlDisplayControl.f
\
\  Author: Dirk Busch (dbu)
\   Email: dir...@wi...
\
\ Created: Samstag, Juli 24 2004 - dbu
\ Updated: Samstag, Juli 31 2004 - dbu
\
\ Display HTML pages in a Window.

cr .( Loading Html Display Control...)

anew -HtmlDisplayControl.f

needs HtmlControl.f

INTERNAL
EXTERNAL

\ --------------------------------------------------------------------------------
\ HtmlDisplayControl class
\ --------------------------------------------------------------------------------

:class HtmlDisplayControl  <super HTMLControl DEPRECATED
\ *G This class was completly replaced by the HTMLControl class. \n
\ ** So use the HTMLControl instead.

;Class

: InitHtmlControl ( -- ) \ Init the Html Control, must be called once at startup
        ; DEPRECATED

: ExitHtmlControl ( -- ) \ Deinit the Html Control, must be called once at exit
        ; DEPRECATED

MODULE

--- NEW FILE: HTMLcontrol.F ---
\ $Id: HTMLcontrol.F,v 1.1 2007/05/16 20:29:06 jos_ven Exp $

\ HTML Control
\ Thomas Dixon

\ *D doc\classes\
\ *! HTMLcontrol
\ *T HTMLcontrol -- HTML control
\ *P This class is using the MSHTML ActiveX control
\ ** so you must install the MS Internet Explorer to use it.
\ *S Glossary

anew -HtmlControl.f

needs AXControl

\ Load MSHTML TypeLibrary
1 1 typelib {EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}

\ We Build off the Generic ActiveX Control
:CLASS HTMLControl           <SUPER AXControl
\ *G HTML control class.

  CELL bytes Web        \ pointer to IWebBrowser2 interface
  16 bytes xtra         \ xtra space for api calls

:M Start: ( Parent -- )
\ *G Start the control
        Start: super
        xtra WebBrowser call StringFromCLSID abort" Unable to Get WebBrowser CLSID!"
        xtra @ AXUCreate: self
        Web IWebBrowser2 QueryInterface: self
          abort" Unable to get the IWebBrowser2 Interface!"
        ;M

:M On_Done: ( -- )
        Web @ if
          Web COM IWebBrowser2 Release drop 0 Web ! then ;M

\ Browser Methods
:M GetLocationURL:      ( -- str len )
\ *G Retrieves the URL of the resource that the browser is currently displaying.
        xtra Web COM IWebBrowser2 GetLocationURL drop
        xtra @ dup >r zunicount >ascii r> call SysFreeString drop ;M

:M GetLocationName:     ( -- str len )
\ *G Retrieves the name of the resource that the browser is currently displaying.
        xtra Web COM IWebBrowser2 GetLocationName drop
        xtra @ dup >r zunicount >ascii r> call SysFreeString drop ;M

:M GetType:     ( -- str len )
\ *G Retrieves the type name of the contained document object.
        xtra Web COM IWebBrowser2 GetType drop
        xtra @ dup >r zunicount >ascii r> call SysFreeString drop ;M

:M Busy?:       ( -- flag )
\ *G Retrieves a boolean value that indicates whether the browser is engaged in a
\ ** downloading operation or other activity.
        xtra Web COM IWebBrowser2 GetBusy drop xtra @ 1 and ;M

:M Offline?:    ( -- flag )
\ *G Retrieves a Boolean value indicating whether the browser is currently operating
\ ** in offline mode.
        xtra Web COM IWebBrowser2 GetOffline drop xtra @ 1 and ;M

\ Navigation Functions

:M GoURL:       ( str len -- )
\ *G Navigates to a resource identified by a Uniform Resource
\ ** Locator (URL) or to the file identified by a full path.
        >unicode drop >r
        0 0 0 0 r> Web COM IWebBrowser2 Navigate drop ;M

:M SetURL:      ( zUrl -- )
\ *G Navigates to a resource identified by a Uniform Resource
\ ** Locator (URL) or to the file identified by a full path.
                zcount GoURL: self ;M

:M GoHome:      ( -- )
\ *G Navigates to the current home or start page.
        Web COM IWebBrowser2 GoHome drop ;M

:M GoSearch:    ( -- )
\ *G Navigates to the current search page.
        Web COM IWebBrowser2 GoSearch drop ;M

:M GoForward:   ( -- )
\ *G Navigates forward one item in the history list.
        Web COM IWebBrowser2 GoForward drop ;M

:M GoBack:      ( -- )
\ *G Navigates backward one item in the history list.
        Web COM IWebBrowser2 GoBack drop ;M

:M Refresh:     ( -- )
\ *G Reloads the file that the browser is currently displaying.
        Web COM IWebBrowser2 Refresh drop ;M

:M Stop:        ( -- )
\ *G Cancels any pending navigation or download operation and
\ ** stops any dynamic page elements, such as background sounds
\ ** and animations.
        Web COM IWebBrowser2 Stop drop ;M

;CLASS
\ *G End of HTML control class

\ We don't need the typelibrary anymore, so unload it now.
free-lasttypelib

\ *Z

--- NEW FILE: HtmlDisplayWindow.f ---
\    File: HtmlDisplayWindow.f
\
\  Author: Dirk Busch (dbu)
\   Email: dir...@wi...
\
\ Created: Samstag, Dezember 04 2004 - dbu
\ Updated: Samstag, Dezember 04 2004 - dbu
\
\ Display HTML pages in a Window.

cr .( Loading Html Display Window...)

anew -HtmlDisplayWindow.f

needs HtmlControl.f
needs SendMessage.f
needs Bitmap.f
needs Toolbar.f
needs RebarControl.f

INTERNAL

\ --------------------------------------------------------------------------------
\ Toolbar for the HtmlDisplayWindow
\ --------------------------------------------------------------------------------

load-bitmap HtmlDisplayBitmaps "apps\sciedit\res\toolbar.bmp"

\ Define tool tips (texts that gives a short description of the buttons function)
\ These correspond to bitmap images in the loaded bitmap
:ToolStrings HtmlDisplayToolTips
        ts," Back"
        ts," Forward"
;ToolStrings

\ Define button strings ( text that can optionally be displayed on the button
:ToolStrings HtmlDisplayToolStrings
        ts," Back"
        ts," Forward"
;ToolStrings

\ Define all toolbar buttons in this application.

NextId constant IDM_HTML_BACK
NextId constant IDM_HTML_FORWARD

:ToolBarTable HtmlDisplayTable
\  Bitmap index id                 Initial state    Initial style      tool string index
  22            IDM_HTML_BACK      TBSTATE_ENABLED  TBSTYLE_BUTTON     0 ToolBarButton,
  23            IDM_HTML_FORWARD   TBSTATE_ENABLED  TBSTYLE_BUTTON     1 ToolBarButton,
;ToolBarTable

:Class HtmlDisplayToolbar     <super Win32ToolBar

int hbitmap
72 constant LargeButtonWidth     \ for buttons with text
48 constant LargeButtonHeight
24 constant SmallButtonWidth     \ a little bigger than Windows default
18 constant SmallButtonHeight
30 constant #buttons
int ButtonText?
int FlatToolBar?

:M ClassInit:   ( -- )
                ClassInit: super
                0 to hbitmap
                false to ButtonText?
                true to FlatToolBar?
                ;M

:M Start:       ( parent -- )
                HtmlDisplayTable         IsButtonTable: self
                HtmlDisplayToolTips         IsToolTips: self

                ButtonText?
                if      HtmlDisplayToolStrings
                else    NULL
                then    IsButtonStrings: self

                Start: super

                \ set button size
                ButtonText?
                if      LargeButtonWidth LargeButtonHeight
                else    SmallButtonWidth SmallButtonHeight
                then    word-join 0 TB_SETBUTTONSIZE SendMessage:Self drop

                \ set bitmap size
                16 18 word-join 0 TB_SETBITMAPSIZE SendMessage:Self drop

                HtmlDisplayBitmaps usebitmap   \ create bitmap handle
                map-transparent               \ use system colors for background
                GetDc: self dup>r CreateDIBitmap to hbitmap
                r> ReleaseDc: self
                hbitmap \ do we have a handle?
                if   0 hbitmap #buttons AddBitmaps: self drop
                then
                ;M

:M WindowStyle: ( -- style )
                WindowStyle: super
                [ TBSTYLE_TOOLTIPS TBSTYLE_WRAPABLE or CCS_ADJUSTABLE or nostack1
                CCS_NOPARENTALIGN or CCS_NORESIZE or ] LITERAL or
                FlatToolBar?
                if      TBSTYLE_FLAT  or
                then
                ;M

:M On_Done:     ( -- )
                hbitmap
                if      hbitmap Call DeleteObject drop
                        0 to hbitmap
                then    On_Done: super
                ;M

:M On_ToolBarChange: ( -- f )                   \ User has changed toolbar
                Autosize: self false
                ;M

;Class

\ --------------------------------------------------------------------------------
\ Rebar for the HtmlDisplayWindow
\ --------------------------------------------------------------------------------

:Class HtmlDisplayRebar          <super RebarControl

HtmlDisplayToolbar HtmlToolbar

: add-toolbar   ( -- )
                eraseband-info

\                 New> HtmlDisplayToolbar to HtmlToolbar
                999 SetID: HtmlToolbar
                self Start: HtmlToolbar

                \ Set-up registry key for toolbar customization data...
                s" SOFTWARE\" pad place
                PROGREG count pad +place
                s" Settings" pad +place
                pad +null pad count drop \ Registry sub-key
                z" ToolBar"
                SetRegistryKey: HtmlToolbar

                \ restore any settings
\                false SaveRestore: HtmlToolbar

                [ RBBIM_CHILD RBBIM_CHILDSIZE or RBBIM_STYLE or RBBIM_SIZE or ] LITERAL
                to bfmask
                GetHandle: HtmlToolbar to hwndchild
                0 to cxMinChild
                25 to cyMinChild
                25 to cyChild       \ band height
                200 to cyMaxChild   \ max band height
                1 to cyIntegral
                200 to cx           \ band width
                RBBS_GRIPPERALWAYS   \ RBBS_VARIABLEHEIGHT or
                RBBS_CHILDEDGE or
                to fstyle
                InsertBand: self ;

:M Start:       ( parent -- )
                Start: super
                hwnd
                if   add-toolbar
                then ;M

:M WindowStyle: ( -- style )
                WindowStyle: super
                [ WS_CLIPSIBLINGS WS_CLIPCHILDREN or CCS_NODIVIDER or RBS_VARHEIGHT or RBS_BANDBORDERs or WS_BORDER or RBS_AUTOSIZE or ] literal or
                ;M

:M Close:       ( -- )
                Close: HtmlToolbar
                Close: super ;M

:M Height:      ( -- h )
                GetWindowRect: self
                nip swap - nip ;M

:M Show:        ( f -- )
                if SW_SHOW else SW_HIDE then Show: super ;M

:M Handle_Notify: ( )
                HtmlToolbar
                if   Handle_Notify: HtmlToolbar
                then ;M

:M On_Done:     ( -- )
                On_Done: super ;M

:M ClassInit:   ( -- )
                ClassInit: super
                ;M

;class

\ --------------------------------------------------------------------------------
\ HtmlDisplayWindow class
\ --------------------------------------------------------------------------------

EXTERNAL

:class HtmlDisplayWindow <super Window

HTMLControl      HtmlControl
HtmlDisplayRebar HtmlRebar
int              ShowToolbar?

:M On_Init:     ( -- )
                On_Init: super

                1001 SetId: HtmlControl
                self Start: HtmlControl

                1002 SetId: HtmlRebar
                self Start: HtmlRebar
                ;M

: AdjustWindowSize      { width height win -- }
                SWP_SHOWWINDOW SWP_NOZORDER or SWP_NOMOVE or
                height width
                0 0     \ ignore position
                0       \ ignore z-order
                win Call SetWindowPos drop ;

:M On_Size:     ( -- )
                tempRect.AddrOf GetClientRect: self

                Left: tempRect
                ShowToolbar? if Height: HtmlRebar 2 - else Top: tempRect then
                Right: tempRect
                Bottom: tempRect
                ShowToolbar? if Height: HtmlRebar - 1+ then
                Move: HtmlControl

                ShowToolbar? if Width Height: HtmlRebar GetHandle: HtmlRebar AdjustWindowSize then
                ;M

:M SetURL:      ( zUrl -- )
                SetURL: HtmlControl ;M

:M GoBack:      ( -- )
                GoBack: HtmlControl ;M

:M GoForward:   ( -- )
                GoForward: HtmlControl ;M

:M GoHome:      ( -- )
                GoHome: HtmlControl ;M

:M GoSearch:    ( -- )
                GoSearch: HtmlControl ;M

:M Refresh:     ( -- )
                Refresh: HtmlControl ;M

:M Stop:        ( -- )
                Stop: HtmlControl ;M

:M WM_NOTIFY    ( h m w l -- res )
                HtmlRebar
                if   Handle_Notify: HtmlRebar
                then ;M

:M ClassInit:   ( -- )
                ClassInit: super
                true to ShowToolbar?
                ;M

:M OnWmCommand: ( hwnd msg wparam lparam -- hwnd msg wparam lparam )
                over LOWORD IDM_HTML_BACK    = if GoBack: self exitm then
                over LOWORD IDM_HTML_FORWARD = if GoForward: self exitm then
                OnWmCommand: Super
                ;M

;class

MODULE

cr .( loaded)

--- NEW FILE: AXControl.F ---
\ $Id: AXControl.F,v 1.1 2007/05/16 20:29:06 jos_ven Exp $

\ ActiveX Control Class
\ Thomas Dixon

\ *D doc\classes\
\ *! AXControl
\ *T AXControl -- Base class for ActiveX controls

\ *P AXControl is a class that can be treated like any other control in
\ ** win32forth, except it is enabled to host an activex component. A short
\ ** example of it's usage:

\ *P window win         \n
\ ** start: win         \n
\ ** axcontrol ax       \n
\ ** win start: ax      \n
\ ** s" MSCAL.Calendar" axcreate: ax    \n
\ ** autosize: ax

\ *P The example here hosts a calandar control by it's progid.
\ ** In order to see this work properly, you need to have that activex
\ ** control installed on your machine.  ProgID's may also have some
\ ** version control to them. "MSCAL.Calendar.7" as the progid would
\ ** only host version 7 of the caladar control.
\ *P You may also use the string of the clsid that you want to use instead of
\ ** the progid, if it suits your purposes better.  Ex:
\ *P s" {8E27C92B-1264-101C-8A2F-040224009C02}" axcreate: ax    \n
\ ** autosize: ax
\ *P You may also use a url if you want:                        \n
\ ** s" http://www.google.com" axcreate: ax                     \n
\ ** autosize: ax
\ *P You may also give it html code, if it is proceeded by "MSHTML:"  Ex:  \n
\ ** s" MSHTML:<HTML><BODY>Hello World!</BODY></HTML>" axcreate: ax   \n
\ ** autosize: ax  \n
\ *P Just having the control there is nice, but the REAL trick is to
\ ** communicate with it and exchange data back and forth.  The way that
\ ** this is done is by  getting the control's interface and using it.

\ *S Glossary

anew -AXControl.F

needs fcom
needs childwnd

winlibrary atl.dll


:CLASS AXControl                <SUPER CHILD-WINDOW
\ *G AXControl Base class for ActiveX controls

:M AXUCreate: ( ustr -- )
\ *G calls unicode creation function
        0 0 rot hwnd swap call AtlAxCreateControl abort" Unable to Create ActiveX Control!"
        ;M

:M AXCreate:  ( str len -- )
\ *G Initialize the ActiveX control
        1+ asc>uni over + 0 swap 2 - w!  dup>r
        AXUCreate: self
        r> free drop
        ;M

:M QueryInterface:    ( ppv riid -- flag )
\ *G flag is true on error
        0 >r rp@ hwnd call AtlAxGetControl if r>drop true exitm then
        rp@ COM IUnknown IQueryInterface
        rp@ COM IUnknown IReleaseRef drop r>drop
        ;M

;CLASS
\ *G End of AXControl class

\ *Z

--- NEW FILE: ADO.f ---
\ *D doc\classes\
\ *! ADO
\ *T ADO -- ADO Classes for Database Interfacing
\ *Q Tom Dixon - August 2006
\ ** These classes were developed to make accessing databases easy and convienent
\ ** with win32forth.

needs fcom

2 5 typelib {00000205-0000-0010-8000-00AA006D2EA4} \ inlude ADO type library


create UComma 32 allot  u" ," UComma uniplace           \ Column Delimeter
create Ucrlf  32 allot  crlf$ count >unicode Ucrlf uniplace \ New Record Delimeter
create Unull 32 allot  u" " Unull uniplace     \ Null Character Replacement

\ *S  ADOConnection Class

:class ADOConnection               <SUPER Object
\ *G An ADO connection object controls the access of cursors to the database.
\ ** It is meant to control things such as tranactions, read/write properties
\ ** and error handling.
        CELL bytes Conn
        CELL bytes Errs
        16   bytes xtra
             int   mstr
             int   mstrlen

:M Freemstr: ( -- )
        mstr if mstr free drop 0 to mstr 0 to mstrlen then ;M

:M ~: (  --  )

        Conn @ if Conn COM _Connection Release drop 0 Conn ! then
        Freemstr: self ;M

:M Start: ( -- )
\ *G Initializes the ADO Connection Component.  Most methods will not execute properly
\ ** if this is not called when the object instance is created
        Conn @ 0= if
          Conn _Connection 1 0 Connection call CoCreateInstance
          abort" Unable to Create Connection Object!" then ;M

:M Connect: ( -- )
\ *G Connects to the data source specified by the connection string with the given
\ ** connection properties.
        0 0 0 0 Conn COM _Connection Open drop ;M

:M GetConn: ( -- IConn ) Conn @ ;M

:M Close: ( -- flag )
\ *G Closes the database connection.  The COM component still exists and a new
\ ** connection may be made if desired.
        Conn COM _Connection Close drop
        Freemstr: self ;M

:M BSTR>ASC: ( bstr -- str len )
        dup 0= if drop s" " exitm then
        Freemstr: self
        dup dup bstrlen ?dup if uni>asc else drop s" " then
        2dup to mstrlen to mstr
        rot bstrfree ;M

:M GetErrorCnt: ( -- cnt )
\ *G Return the number of errors in the FIFO error queue
        Errs Conn COM _Connection GetErrors
        abort" Unable to Get Errors!"
        xtra Errs COM Errors GetCount drop xtra @
        Errs COM Errors Release drop ;M

:M GetError: ( cnt -- n )
\ *G Return the error number of the 'cnt' error in the error queue
        Errs Conn COM _Connection GetErrors
        abort" Unable to Get Errors!"
        xtra 0 rot 0 VT_I4
        Errs COM Errors GetItem abort" Unable to get Error!"
        0 >r rp@ xtra COM Error GetNumber drop r>
        xtra COM Error Release drop
        Errs COM Errors Release drop ;M

:M Error>str: ( n -- str len )
\ *G Return the error string of the 'cnt' error in the error queue
        Errs Conn COM _Connection GetErrors
        abort" Unable to Get Errors!"
        xtra 0 rot 0 VT_I4
        Errs COM Errors GetItem abort" Unable to get Error!"
        0 >r rp@ xtra COM Error GetDescription drop
        r> bstr>asc: self
        xtra COM Error Release drop
        Errs COM Errors Release drop ;M

:M ClearErrors: ( -- )
\ *G Clears the FIFO error queue
        Errs Conn COM _Connection GetErrors
        abort" Unable to Get Errors!"
        Errs COM Errors Clear drop
        Errs COM Errors Release drop ;M

:M ERR: ( n -- ) \ thows an error on any problem
\ *G Displays and clears all errors in the queue
        GetErrorCnt: self 0 ?do
          i Error>str: self type cr
        loop
        clearerrors: self ;M

:M Transaction: ( -- )
\ *G Starts a transaction session for this connection.  All changes
\ ** performed on the database will not take effect until they are committed.
\ ** Some databases may not support this functionality.
        xtra Conn COM _Connection BeginTrans drop
        xtra @ drop \ nesting level - don't use right now...
        ;M
:M Commit: ( -- )
\ *G Commit all changes in the current transaction to the database.
        Conn COM _Connection CommitTrans drop ;M

:M RollBack: ( -- )
\ *G Drop all changes in the current transaction - no changes are made for the
\ ** transaction session.
        Conn COM _Connection RollbackTrans drop ;M

:M GetTimeOut: ( -- n )
\ *G Returns the timeout time (in seconds) that queries will give up.
        xtra Conn COM _Connection GetCommandTimeout drop
        xtra @ ;M

:M SetTimeOut: ( n -- )
\ *G Sets the timeout time (in seconds) that queries will give up.
        Conn COM _Connection PutCommandTimeout drop ;M

:M GetConnString: ( -- str len )
\ *G Return the connection string for the data source.  This may not necessarily
\ ** be the same string that was given to the object
        xtra Conn COM _Connection GetConnectionString drop
        xtra @ bstr>asc: self ;M

:M SetConnString: ( str len -- )
\ *G Set the connection string for the data source.  The connection string tells
\ ** the object what drivers to use, where the database is, user name, and password.
        Asc>bstr dup >r Conn COM _Connection PutConnectionString
        abort" Unable to set Connection String!" r> bstrfree ;M

:M GetProvider: ( -- str len )
\ *G Returns the provider for the connection.
        xtra Conn COM _Connection GetProvider drop
        xtra @ bstr>asc: self ;M

:M SetProvider: ( str len -- )
\ *G Sets the provider for the connection.  Can be set through the connection string
\ ** as well.
        Asc>bstr drop dup >r Conn COM _Connection PutProvider
        abort" Unable to set Provider!" r> bstrfree ;M

:M GetMode: ( -- n )
\ *G Returns the connection mode.
        xtra Conn COM _Connection GetMode drop
        xtra @ ;M

:M SetMode: ( n -- )
\ *G Sets the connection mode.  The connection mode indicates whether the database
\ ** is read-only, write-only, sharable, etc...\n
\ ** See the ConnectModeEnum constants below the class descriptions.
        Conn COM _Connection PutMode drop ;M

:M GetState: ( -- n )
\ *G Returns the current state of the connection object.
        xtra Conn COM _Connection GetState drop
        xtra @ ;M

;class




\ *S  ADOCursor Class

:class ADOCursor               <SUPER Object
\ *G An ADO cursor object represents a recordset of data, or data in a table-like
\ ** structure.  Data can be loaded, updated, inserted through this object.
        CELL bytes Rec
        CELL bytes flds
        CELL bytes fld
        16   bytes xtra
             int   CONNptr
             int   mstr
             int   mstrlen

:M Freemstr: ( -- )
        mstr if mstr free drop 0 to mstr 0 to mstrlen then ;M

:M ~: (  --  )
        Rec @ if Rec COM _Recordset Release drop 0 Rec ! then
        Freemstr: self ;M

:M Start: ( -- )
\ *G Initializes the ADO Recordset Component.  Most methods will not execute properly
\ ** if this is not called when the object instance is created
        Rec @ 0= if
          Rec _Recordset 1 0 RecordSet call CoCreateInstance
          abort" Unable to Create Recordset Object!" then ;M

:M BSTR>ASC: ( bstr -- str len )
        dup 0= if drop s" " exitm then
        Freemstr: self
        dup dup bstrlen ?dup if uni>asc else drop s" " then
        2dup to mstrlen to mstr
        rot bstrfree ;M

:M SetConnection: ( ADOConnection -- )
\ *G Sets the connection object for this cursor.  It is required before any query
\ ** is executed.
        to CONNptr ;M

:M GetCacheSize: ( -- n )
\ *G Returns the cache size of the cursor.  The value is the number of records in the
\ ** cache before updates are required.
        xtra rec COM _Recordset GetCacheSize drop xtra @ ;M

:M SetCacheSize: ( n -- )
\ *G Sets the cache size of the cursor.  The default is 1, or updates occur with every
\ ** new record edited.
        rec COM _Recordset PutCacheSize drop ;M

:M GetCursorType: ( -- ctype )
\ *G Returns the cursor type.
        xtra rec COM _Recordset GetCursorType drop xtra @ ;M

:M SetCursorType: ( ctype -- )
\ *G Sets the cursor type.  The cursor type determines what is allowed on the cursor
\ ** data and how data is seen in a multi-client environment.  The possible values are:
\ *L
\ *| adOpenUnspecified | The cursor type is unspecified.  Usually defaults to adOpenForwardOnly |
\ *| adOpenStatic | All movement methods are available.  Changes from other users are not visible |
\ *| adOpenForwardOnly | The cursor can only move forward.  The record count and other navigation methods are invalid.  This should have the best performance of the cursors. |
\ *| adOpenDynamic  | All additions, deletions and changes from other users are visible |
\ *| adOpenKeyset | Like a dynamic cursor, except added records can't be seen and deleted records are inaccessible |
        rec COM _Recordset PutCursorType drop ;M

:M GetLockType: ( -- n )
\ *G Returns the lock type.
        xtra rec COM _Recordset GetLockType drop xtra @ ;M

:M SetLockType: ( n -- )
\ *G Sets the lock type.  The lock type determines how the database is to handle changes
\ ** to the data on a cursor.  The possible values are:
\ *L
\ *| adLockUnspecified | The lock type is unspecified.  Usually defaults to adLockReadOnly |
\ *| adLockReadOnly | The records are read-only. Data cannot be altered |
\ *| adLockPessimistic | Pessamistic locking.  Record(s) are locked at the data source immediately when the alterations begin. |
\ *| adLockOptimistic | Optimistic locking.  Record(s) are locked only when the update method is called |
\ *| adLockBatchOptimistic | Useful for batch updates. |
        rec COM _Recordset PutLockType drop ;M

:M GetMaxRows: ( -- n )
\ *G Returns the maximum number of records to be returned in a query.
        xtra rec COM _Recordset GetMaxRecords drop xtra @ ;M

:M SetMaxRows: ( n -- )
\ *G Sets the maximum number of records to be returned from a query (0 = unlimited)
        rec COM _Recordset PutMaxRecords drop ;M

:M Close: ( -- )
\ *G Closes the cursor.  Another query can be executed on the cursor once it has been closed.
        Rec COM _Recordset Close drop ;M

:M GetState: ( -- n )
\ *G Returns the state of the cursor.  Useful when executing queries asyncronously.
        xtra Rec COM _Recordset GetState drop xtra @ ;M

:M Executing?: ( -- flag )
\ *G Returns true if the query is still executing.
        GetState: self adStateExecuting and ;M

:M Fetching?: ( -- flag )
\ *G Returns true if the rows are still being retrieved
        GetState: self adStateFetching and ;M

:M (Execute): ( str len option -- )
        -rot asc>bstr >r
        GetLockType: self
        GetCursorType: self
        0 CONNptr dup if GetConn: ADOConnection then 0 VT_DISPATCH
        0 r@ 0 VT_BSTR
        Rec COM _RecordSet Open
        r> bstrfree
        if CONNptr dup if err: ADOConnection then
           true abort" Unable to Execute Query!" then ;M


:M Execute: ( str len -- )
\ *G Execute a SQL query on the cursor.  Any returned data will be in the cursor.
        adOptionUnspecified (Execute): self ;M

:M AsyncExecute: ( str len -- )
\ *G Operates the same as the execute method, but is asyncronous.  The cursor's
\ ** state will indicate if the query has finished executing or not.
        adAsyncExecute (Execute): self ;M

:M Requery: ( n -- )
\ *G Rerun the last query.
        rec COM _Recordset Requery drop ;M

:M RecordCount: ( -- n )
\ *G Return the number of records in cursor.  May not work with the adOpenForwardOnly
\ ** cursor type.
        xtra rec COM _Recordset GetRecordCount drop xtra @ ;M

:M Move: ( n -- )
\ *G Move to the record number 'n' of the cursor's data
        >r 0 DISP_E_PARAMNOTFOUND 0 VT_ERROR r>
        rec COM _Recordset Move drop ;M

:M MoveFirst: ( -- )
\ *G Move to the first record of the cursor's data.
        rec COM _Recordset MoveFirst drop ;M

:M MoveNext: ( -- )
\ *G Move to the next record of the cursor's data
        rec COM _Recordset MoveNext drop ;M

:M MovePrevious: ( -- )
\ *G Move to the previous record of the cursor's data
        rec COM _Recordset MovePrevious drop ;M

:M MoveLast: ( -- )
\ *G Move to the last record of the cursor's data
        rec COM _Recordset MoveLast drop ;M

:M EOF: ( -- flag )
\ *G Flag that indicates if the current record position is after the last record.
        xtra rec COM _Recordset GetEOF drop xtra @ ;M

:M BOF: ( -- flag )
\ *G Flag that indicates if the current record position is before the first record.
        xtra rec COM _Recordset GetBOF drop xtra @ ;M

:M FieldCnt: ( -- n )
\ *G Returns the number of columns in the current record.
        flds rec COM _Recordset GetFields abort" Fields error!"
        xtra flds COM Fields GetCount drop xtra @
        flds COM Fields Release drop ;M

:M FieldType: ( field -- DataTypeEnum )
\ *G Returns the data type constant of the given column. Possible data types are:
\ *L
\ *| adEmpty |
\ *| adTinyInt |
\ *| adSmallInt |
\ *| adInteger |
\ *| adBigInt|
\ *| adUnsignedTinyInt  |
\ *| adUnsignedSmallInt |
\ *| adUnsignedInt |
\ *| adUnsignedBigInt |
\ *| adSingle |
\ *| adDouble |
\ *| adCurrency  |
\ *| adDecimal |
\ *| adNumeric  |
\ *| adBoolean  |
\ *| adError  |
\ *| adUserDefined  |
\ *| adVariant  |
\ *| adIDispatch  |
\ *| adIUnknown |
\ *| adGUID |
\ *| adDate  |
\ *| adDBDate  |
\ *| adDBTime  |
\ *| adDBTimeStamp |
\ *| adBSTR |
\ *| adChar  |
\ *| adVarChar  |
\ *| adLongVarChar |
\ *| adWChar |
\ *| adVarWChar |
\ *| adLongVarWChar |
\ *| adBinary |
\ *| adVarBinary  |
\ *| adLongVarBinary |
\ *| adChapter |
\ *| adFileTime |
\ *| adPropVariant |
\ *| adVarNumeric  |
\ *| adArray |
        flds rec COM _Recordset GetFields abort" Fields error!"
        fld 0 rot 0 VT_I4 flds COM Fields GetItem abort" Not a Field!"
        xtra fld COM Field GetType drop xtra @
        flds COM Fields Release drop ;M

:M FieldName: ( field -- str len )
\ *G Returns the column name of the given column number.
        flds rec COM _Recordset GetFields abort" Fields error!"
        fld 0 rot 0 VT_I4 flds COM Fields GetItem abort" Not a Field!"
        xtra fld COM Field GetName drop
        xtra @ bstr>asc: self
        fld COM Field Release drop
        flds COM Fields Release drop ;M

:M FieldSize: ( field -- n )
\ *G Returns the data size of the given column number.
        flds rec COM _Recordset GetFields abort" Fields error!"
        fld 0 rot 0 VT_I4 flds COM Fields GetItem abort" Not a Field!"
        xtra fld COM Field GetActualSize drop xtra @
        fld COM Field Release drop
        flds COM Fields Release drop ;M


:M GetValue: ( field -- )
        xtra 16 0 fill
        flds rec COM _Recordset GetFields abort" Fields error!"
        fld 0 rot 0 VT_I4 flds COM Fields GetItem abort" Not a Field!"
        xtra fld COM Field GetValue drop
        fld COM Field Release drop
        flds COM Fields Release drop ;M

:M GetInt: ( field -- int )
\ *G Returns an integer value of the given column on the current row.
        GetValue: self
        xtra @ VT_NULL = if 0 else xtra 2 cells + @ then ;M

:M GetDouble: ( field -- d )
\ *G Returns the double of the given column on the current row.
        GetValue: self
        xtra @ VT_NULL = if 0 0 else xtra 2 cells + 2@ then ;M

:M GetFloat: ( field -- float )
\ *G Returns the floating point value of the given column on the current row.
        GetValue: self
        xtra @ VT_NULL = if 0e0 else xtra 8 + df@ then ;M

:M GetStr: ( field -- str len )
\ *G Returns the string of the given column on the current row.  May be much longer than 255
        GetValue: self
        xtra @ VT_NULL = if s" " else xtra 2 cells + @ bstr>asc: self then ;M

:M GetTimeStamp: ( field -- float )
\ *G Return the timestamp value of the given column on the current row.  The timestamp value is
\ ** a floating point number that indicates the number of days since Dec 31, 1899.
        GetFloat: self ;M

:M GetDateTime: ( field -- sec min hour day month year )
\ *G Returns the datetime values of the given column on the current row.
        GetValue: self
        xtra @ VT_NULL = if 0 0 0 0 0 0 exitm then
        time-buf xtra 8 + 2@ call VariantTimeToSystemTime drop
        time-buf 12 + w@        \ seconds
        time-buf 10 + w@        \ minutes
        time-buf  8 + w@        \ hours
        time-buf  6 + w@        \ day of month
        time-buf  2 + w@        \ month of year
        time-buf      w@ ;M     \ year

:M isNull?: ( field -- flag )
\ *G Returns true if the given field for the given flag is null
        getValue: self
        xtra @ VT_NULL = ;M


:M SetValue: ( variant field -- ) \ puts xtra variant into Field
        flds rec COM _Recordset GetFields abort" Fields error!"
        fld 0 rot 0 VT_I4 flds COM Fields GetItem abort" Not a Field!"
        fld COM Field PutValue abort" Value Not Set!"
        fld COM Field Release drop
        flds COM Fields Release drop ;M

:M SetInt: ( int field -- )
\ *G Sets the integer value of a given column on the current row.
        >r 0 swap 0 VT_I4 r> SetValue: self ;M

:M SetDouble: ( d field -- )
\ *G Sets the double value of a given column on the current row.
        >r 0 VT_I8 r> SetValue: self ;M

:M SetFloat: ( float field -- )
\ *G Sets the floating point number of a given column on the current row.
        >r fs>ds 0 VT_R8 r> SetValue: self ;M

:M SetNull: ( field -- )
\ *G Sets the field value to null of a given column on the current row.
        >r 0 0 0 VT_NULL r> SetValue: self ;M

:M SetStr: ( str len field -- )
\ *G Sets the string value of a given column on the current row.
        -rot asc>bstr dup >r swap >r
        0 swap 0 VT_BSTR r> SetValue: self
        r> bstrfree ;M

:M SetTimeStamp: ( float field -- )
\ *G Sets the timestamp value of the given column on the current row.  The timestamp value is
\ ** a floating point number that indicates the number of days since Dec 31, 1899.
        SetFloat: self ;M

:M SetDateTime: ( sec min hour day month year field -- )
\ *G Sets the datetime values of the given column on the current row.
        time-buf time-len 0 fill
        >r time-buf      w!  \ year
           time-buf 2  + w!  \ month
           time-buf 6  + w!  \ day
           time-buf 8  + w!  \ hours
           time-buf 10 + w!  \ minutes
           time-buf 12 + w!  \ seconds
        xtra time-buf call SystemTimeToVariantTime
        0= abort" Unable to Convert DateTime!"
        xtra 4 + @ xtra @ 0 VT_DATE
        r> SetValue: self ;M

:M AddRow: ( -- )
\ *G Adds a new record to the end of the recordset and sets this as the current row.  The row
\ ** is not actually created until the update method is called.
        0 DISP_E_PARAMNOTFOUND 0 VT_ERROR
        0 DISP_E_PARAMNOTFOUND 0 VT_ERROR
        rec COM _Recordset AddNew abort" Unable to Add Row!" ;M

:M DeleteRow: ( -- )
\ *G Deletes the current record.
        adAffectCurrent rec COM _Recordset Delete
        abort" Unable to Delete Row!" ;M

:M Update: ( -- )
\ *G Updates the alterations to the data.
        0 DISP_E_PARAMNOTFOUND 0 VT_ERROR
        0 DISP_E_PARAMNOTFOUND 0 VT_ERROR
        rec COM _Recordset Update abort" Update Failed!" ;M


:M (Save): ( str len type -- )
        -rot asc>bstr dup >r 0 swap 0 VT_BSTR
        Rec COM _RecordSet Save abort" Unable to Save!"
        r> bstrfree ;M

:M SaveNative: ( str len -- )
\ *G Saves the cursor's data to a file that is in a unspecified format.
        0 (Save): self ;M

:M SaveXML: ( str len -- )
\ *G Saves the cursor's data as a XML file.
        adPersistXML (Save): self ;M

:M SaveADTG: ( str len -- )
\ *G Saves the cursor's data in the Microsoft Advanced Data TableGram (ADTG) format.
\ ** Requires a filename.
        adPersistADTG (Save): self ;M

:M SaveCSV: ( str len -- )
\ *G Saves the cursor's data to a comma separated value file for easy viewing.
\ ** Cannot be loaded later through the loadfile method.
        xtra 16 0 fill
        xtra UNull cell+ Ucrlf cell+ Ucomma cell+
        -1 adClipString Rec COM _Recordset GetString
        abort" Unable to Convert Records!"
        w/o create-file abort" Unable to Create File!" >r
        xtra @ bstr>asc: self
        r@ write-file drop r> close-file drop ;M

:M LoadFile: ( str len -- )
\ *G Loads a cursor data file that was saved previously.\n
\ ** A connection object is not required to load this data.
        adCmdFile (Execute): self ;M

;class



\ Relavant ADO Constants
\ This may seem unnecessary, but once we unload the type library, the
\ constants will not be accessible, so they are redefined as forth
\ constants

\ ConnectModeEnum
adModeUnknown           CONSTANT adModeUnknown
adModeRead              CONSTANT adModeRead
adModeWrite             CONSTANT adModeWrite
adModeReadWrite         CONSTANT adModeReadWrite
adModeShareDenyRead     CONSTANT adModeShareDenyRead
adModeShareDenyWrite    CONSTANT adModeShareDenyWrite
adModeShareExclusive    CONSTANT adModeShareExclusive
adModeShareDenyNone     CONSTANT adModeShareDenyNone
adModeRecursive         CONSTANT adModeRecursive

\ CursorTypeEnum
adOpenUnspecified       CONSTANT adOpenUnspecified
adOpenForwardOnly       CONSTANT adOpenForwardOnly
adOpenKeyset            CONSTANT adOpenKeyset
adOpenDynamic           CONSTANT adOpenDynamic
adOpenStatic            CONSTANT adOpenStatic

\ LockTypeEnum
adLockUnspecified       CONSTANT adLockUnspecified
adLockReadOnly          CONSTANT adLockReadOnly
adLockPessimistic       CONSTANT adLockPessimistic
adLockOptimistic        CONSTANT adLockOptimistic
adLockBatchOptimistic   CONSTANT adLockBatchOptimistic

\ DataTypeEnum
adEmpty                 CONSTANT adEmpty
adTinyInt               CONSTANT adTinyInt
adSmallInt              CONSTANT adSmallInt
adInteger               CONSTANT adInteger
adBigInt                CONSTANT adBigInt
adUnsignedTinyInt       CONSTANT adUnsignedTinyInt
adUnsignedSmallInt      CONSTANT adUnsignedSmallInt
adUnsignedInt           CONSTANT adUnsignedInt
adUnsignedBigInt        CONSTANT adUnsignedBigInt
adSingle                CONSTANT adSingle
adDouble                CONSTANT adDouble
adCurrency              CONSTANT adCurrency
adDecimal               CONSTANT adDecimal
adNumeric               CONSTANT adNumeric
adBoolean               CONSTANT adBoolean
adError                 CONSTANT adError
adUserDefined           CONSTANT adUserDefined
adVariant               CONSTANT adVariant
adIDispatch             CONSTANT adIDispatch
adIUnknown              CONSTANT adIUnknown
adGUID                  CONSTANT adGUID
adDate                  CONSTANT adDate
adDBDate                CONSTANT adDBDate
adDBTime                CONSTANT adDBTime
adDBTimeStamp           CONSTANT adDBTimeStamp
adBSTR                  CONSTANT adBSTR
adChar                  CONSTANT adChar
adVarChar               CONSTANT adVarChar
adLongVarChar           CONSTANT adLongVarChar
adWChar                 CONSTANT adWChar
adVarWChar              CONSTANT adVarWChar
adLongVarWChar          CONSTANT adLongVarWChar
adBinary                CONSTANT adBinary
adVarBinary             CONSTANT adVarBinary
adLongVarBinary         CONSTANT adLongVarBinary
adChapter               CONSTANT adChapter
adFileTime              CONSTANT adFileTime
adPropVariant           CONSTANT adPropVariant
adVarNumeric            CONSTANT adVarNumeric
adArray                 CONSTANT adArray


\ free the type library
free-lasttypelib

\ *Z

--- NEW FILE: FlashControl.F ---
\ $Id: FlashControl.F,v 1.1 2007/05/16 20:29:06 jos_ven Exp $

\ Shockwave Flash control written in forth
\ Tom Dixon

anew -FlashControl

needs AXControl

\ Load Shockwave TypeLibrary
1 0 typelib {D27CDB6B-AE6D-11CF-96B8-444553540000}

\ We Build off the Generic ActiveX Control
:CLASS FlashControl           <SUPER AXControl
  CELL bytes Flash      \ pointer to IShockwaveFlash interface
  16 bytes xtra         \ xtra space for api calls

  :M Start: ( Parent -- )
        Start: super
        xtra ShockwaveFlash call StringFromCLSID abort" Unable to Get Flash CLSID!"
        xtra @ AXUCreate: self
        Flash IShockwaveFlash QueryInterface: self
          abort" Unable to get the IShockwaveFlash Interface!"
        ;M

  :M On_Done: ( -- )
        Flash @ if
          Flash COM IShockwaveFlash Release drop 0 Flash ! then ;M

  \ ShockWave Methods
  :M PutMovie: ( str len -- f )
        >unicode drop flash COM IShockwaveFlash PutMovie ;M
  :M GetMovie: ( -- str len )
        xtra Flash COM IShockwaveFlash GetMovie drop
        xtra @ dup >r zunicount >ascii r> call SysFreeString drop ;M

  :M Play: ( -- ) Flash COM IShockwaveFlash Play drop ;M
  :M Stop: ( -- ) Flash COM IShockwaveFlash Stop drop ;M
  :M Back: ( -- ) Flash COM IShockwaveFlash Back drop ;M
  :M Forward: ( -- ) Flash COM IShockwaveFlash Forward drop ;M
  :M Rewind: ( -- ) Flash COM IShockwaveFlash Rewind drop ;M
  :M StopPlay: ( -- ) Flash COM IShockwaveFlash StopPlay drop ;M
  :M GotoFrame: ( n -- ) Flash COM IShockwaveFlash GotoFrame drop ;M
  :M CurrentFrame: ( -- n ) xtra Flash COM IShockwaveFlash CurrentFrame drop xtra @ ;M
  :M TotalFrames: ( -- n ) xtra Flash COM IShockwaveFlash GetTotalFrames drop xtra @ ;M
  :M Playing?: ( -- flag ) xtra Flash COM IShockwaveFlash IsPlaying drop xtra @ ;M
  :M Loaded%: ( -- percent ) xtra Flash COM IShockwaveFlash PercentLoaded drop xtra @ ;M
  :M Loop: ( flag -- ) Flash COM IShockwaveFlash PutLoop drop ;M
  :M Loop?: ( -- flag ) xtra Flash COM IShockwaveFlash GetLoop drop xtra @ ;M
  :M Pan: ( n n n -- ) Flash COM IShockwaveFlash Pan drop ;M
  :M Zoom: ( n -- ) Flash COM IShockwaveFlash Zoom drop ;M
  :M SetZoomRect: ( n n n n -- ) Flash COM IShockwaveFlash SetZoomRect drop ;M
  :M BGColor: ( -- color ) xtra Flash COM IShockwaveFlash GetBackgroundColor drop xtra @ ;M
  :M SetBGColor: ( color -- ) Flash COM IShockwaveFlash PutBackgroundColor drop ;M

;CLASS

\ We don't need the typelibrary anymore, so unload it now.
free-lasttypelib

\s
for an example see demos\FlashControlDemo.f

--- NEW FILE: PDFControl.F ---
\ $Id: PDFControl.F,v 1.1 2007/05/16 20:29:06 jos_ven Exp $

\ Acrobat PDF Control
\ Thomas Dixon

anew -PdfControl.f

needs AXControl

\ We Build off the Generic ActiveX Control
:CLASS PDFControl           <SUPER AXControl
  CELL bytes PDF        \ pointer to Dispatch Interface
  16 bytes xtra         \ xtra space for api calls

  :M Start: ( Parent -- )
        Start: super
          \ You can use PDF.PdfCtrl.6 instead of the ugly clsid string, but this
          \ way we aren't dependent on the vertion of adobe acrobat
        s" {CA8A9780-280D-11CF-A24D-444553540000}" AXCreate: self
        PDF IDispatch QueryInterface: self
          abort" Unable to get the Dispatch Interface!"
        ;M

  :M On_Done: ( -- )
        PDF @ if
          PDF COM IDispatch IReleaseref drop 0 PDF ! then ;M

  :M LoadFile: ( str len -- flag ) \ flag is true on error
        >unicode drop VT_BSTR >vt
        PDF displate" LoadFile" ;M

  :M SetPage: ( n -- )
        VT_I4 >vt
        PDF displate" setCurrentPage" drop ;M
  :M gotoFirstPage: ( -- )
        PDF displate" gotoFirstPage" drop ;M
  :M gotoLastPage: ( -- )
        PDF displate" gotoLastPage" drop ;M
  :M gotoNextPage: ( -- )
        PDF displate" gotoNextPage" drop ;M
  :M gotoPreviousPage: ( -- )
        PDF displate" gotoPreviousPage" drop ;M
  :M goForward: ( -- )
        PDF displate" goForwardStack" drop ;M
  :M goBack: ( -- )
        PDF displate" goBackwardStack" drop ;M

  :M Print: ( -- )
        PDF displate" Print" drop ;M
  :M PrintWithDialog: ( -- )
        PDF displate" PrintWithDialog" drop ;M
  :M PrintPages: ( n n -- )
        swap VT_I4 >vt VT_I4 >vt
        PDF displate" PrintPages" drop ;M
  :M PrintPagesFit: ( flag n n -- )
        rot VT_BOOL >vt swap VT_I4 >vt VT_I4 >vt
        PDF displate" PrintPagesFit" drop ;M
  :M PrintAll: ( -- )
        PDF displate" PrintAll" drop ;M
  :M PrintAllFit: ( bool -- )
        VT_BOOL >vt
        PDF displate" PrintAllFit" drop ;M

  :M SetZoom: ( float -- ) \ 100e0 is 100%
        sfs>ds VT_R4 >vt
        PDF displate" SetZoom" drop ;M
  :M SetZoomScroll: ( float float float -- )
        3 0 do sfs>ds VT_R4 loop   3 0 do >vt loop
        PDF displate" SetZoomScroll" drop ;M
  :M SetViewRect: ( float float float float -- )
        4 0 do sfs>ds VT_R4 loop   4 0 do >vt loop
        PDF displate" SetViewRect" drop ;M

  :M SetPageMode: ( str len -- )
        >unicode drop VT_BSTR >vt
        PDF displate" SetPageMode" drop ;M
  :M SetLayoutMode: ( str len -- )
        >unicode drop VT_BSTR >vt
        PDF displate" SetLayoutMode" drop ;M
  :M SetNamedDest: ( str len -- )
        >unicode drop VT_BSTR >vt
        PDF displate" SetNamedDest" drop ;M

  :M SetShowToolbar: ( flag -- )
        VT_BOOL >vt
        PDF displate" SetShowToolbar" drop ;M
  :M SetShowScrollbars: ( flag -- )
        VT_BOOL >vt
        PDF displate" SetShowScrollbars" drop ;M

  :M Aboutbox: ( -- )
        PDF displate" AboutBox" drop ;M

;CLASS

\ I don't think the PDF viewer was ever ment to be used as an embedded control
\ It only supports the dispatch interface and updates (such as resizing) are rather slow

\s
\ Example: see demos/PdfControlDemo.f

[Win32forth-cvs] win32forth-stc/src AXConList.F, NONE, 1.1 AxConInfo.f, NONE, 1.1 FCOM.F, NONE, 1.1 Unicode.F, NONE, 1.1

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv5856

Added Files:
	AXConList.F AxConInfo.f FCOM.F Unicode.F 
Log Message:
Jos: Tom Dixon's COM files.

--- NEW FILE: Unicode.F ---
\ Unicode Words
\ Tom Dixon

anew -Unicode.f


library OLE32.DLL
library oleaut32.dll


: UniPlace ( addr len destaddr -- )
\ *G Store a unicode string to an address
  2dup ! 4 + 2dup + 0 swap w! swap cmove ;

: +UniPlace ( addr len destaddr -- )
\ *G Append a string to the end of an address
  2dup @ + >r dup >r dup @ + 4 + 2dup + 0 swap ! swap cmove r> r> swap ! ;

: UniCount ( addr -- addr len )
\ *G Fetch a unicode string from an address (stored with uniplace)
  dup 4 + swap @ ;

: ZUniCount ( addr -- addr len )
\ *G Fetch a null-terminated unicode string from an address (null is 16-bit)
  dup 0 begin over w@ while 2 2 d+ repeat nip ;

: UniType ( addr len -- )
\ *G Type a unicode string to the console
  2/ 0 ?do dup i 2* + c@ emit loop drop ;

: (U") r> UniCount 2dup + 2 + aligned >r ;

: Ustr, ( addr n -- )
\ *G Store a unicode string to the dictionary at HERE
  HERE over 6 + allot uniplace ALIGN ;

: Asc>Uni ( str len -- str len ) \ !!! MUST FREE STRING AFTER !!!
\ *G Convert a ascii string to unicode.\n
\ ** must free unicode string with 'free' when no longer needed.
  dup 2* dup allocate abort" Unable to Allocate Unicode String!"
  dup >r 2swap swap MB_PRECOMPOSED 0 call MultiByteToWideChar r> swap 2* ;

: Uni>Asc ( str len -- str len ) \ !!! MUST FREE STRING AFTER !!!
\ *G Convert a unicode string to ascii\n
\ ** must free ascii string afterwards when no longer needed.
  0 0 2over 0 here 2swap swap 0 0 call WideCharToMultiByte 2/ >r
  0 0 2swap r@ dup Allocate abort" Unable to Allocate String!"
  dup >r 2swap swap 0 0 call WideCharToMultiByte drop r> r> ;

: >Unicode ( str len -- str len )
\ *G Convert ascii string to unicode (uses new$)
  asc>uni 2dup new$ dup >r uniplace drop free drop r> unicount ;

: >ascii ( str len -- str len )
\ *G Convert unicode string to ascii (uses new$)
  uni>asc 2dup new$ dup >r place drop free drop r> count ;

: U" ( <string"> -- str len )
\ *G Unicode string - unicode version of s" 
  [char] " PARSE >unicode
  compilation> drop
  [char] " PARSE asc>uni 2dup here -rot ustr, 
     unicount postpone 2literal drop free drop ;


\ Some APIs require more specific conditions to their unicode strings.
\ (ie: distributed and network apis)
\ bstr has more constraints applied to it.  These words are to convert
\ to bstrs and back again.

: Asc>bstr ( str len -- bstr )
\ *G Convert ascii string to unicode bstr.  bstr must be freed later with 'bstrfree'.
  dup dup 0 call SysAllocStringLen dup >r
  2swap swap
  MB_PRECOMPOSED
  CP_ACP
  call MultiByteToWideChar drop r> ;

: bstrFree ( bstr -- )
\ *G Free a bstr.
  call SysFreeString drop ;
  
: bstrlen ( ustr -- len )
\ *G Returns the length of the bstr.  From this the bstr can be used with all the
\ ** other unicode functions.
  cell- @ ;

\ *Z

--- NEW FILE: AxConInfo.f ---
\ $Id: AxConInfo.f,v 1.1 2007/05/16 20:24:58 jos_ven Exp $

\ AxConInfo.f
\ Get informations about an ActiveX control from registry and
\ display them.
\ Written by Dirk Busch

cr .( Loading ActiveX control info tool)

anew -AxConInfo.f

needs fcom

internal

in-system

create org_BaseReg 260 allot
create org_ProgReg 260 allot
0 value org_regBaseKey
0 value org_regAccessMask

: SaveReg       ( -- )
        BaseReg count org_BaseReg place
        ProgReg count org_ProgReg place
        regBaseKey to org_regBaseKey
        regAccessMask to org_regAccessMask
        ;

: RestoreReg    ( -- )
        org_BaseReg count BaseReg place
        org_ProgReg count ProgReg place
        org_regBaseKey to regBaseKey
        org_regAccessMask to regAccessMask
        ;

: tab-type      ( addr len -- )
        tab-size >r 32 to tab-size
        tab type
        r> to tab-size
        ;

: RegGetAxInfoValue     ( addr1 len1 addr2 len2 -- addr3 len3 )
        s" CLSID\" BaseReg place
        2swap BaseReg +place \ guid
        s" \" BaseReg +place
        BaseReg +place \ section
        ProgReg off
        s" "  s" " RegGetString ;

: (.AxInfoValue) ( addr len -- )
        2dup type ." : "
        RegGetAxInfoValue
        tab-type ;

: (.AxInfo)     ( addr len -- )
        cr ." GUID: " 2dup tab-type
        cr 2dup ." ClassName" s" " (.AxInfoValue)
        cr 2dup s" ProgID"  (.AxInfoValue)
        cr 2dup s" TypeLib" (.AxInfoValue)
        cr 2dup s" Version" (.AxInfoValue)
        cr      s" VersionIndependentProgID" (.AxInfoValue)
        cr ;

: AxInitReg     ( -- )
        SaveReg
        HKEY_CLASSES_ROOT to regBaseKey
        KEY_READ          to regAccessMask ;

: AxRestoreReg  ( -- )
        RestoreReg ;

: /get  { str len char \ str1 len1 -- str len str1 len1 } \ search for char in string, return string till char and rest of string after char
        str len char scan  to len1 to str1
        len1 0>
        if   len len1 - to len
             str1 1+ to str1
             len1 1- ?dup if to len1 then
        then str len str1 len1 ;

: guid>version ( addr len -- major minor )
        s" Version" RegGetAxInfoValue ?dup
        if   [char] . /get number? drop d>s >r number? drop d>s r>
        else drop 1 0
        then ;

: guid>typelib ( addr len -- addr len )
        s" TypeLib" RegGetAxInfoValue ;

external

: GetAxVersion  ( "GUID" -- major minor )
        AxInitReg
        parse-word ?dup if guid>version else drop 0 0 then
        RestoreReg ;

: GetAxTypeLib  ( "GUID" -- addr len )
        AxInitReg
        parse-word ?dup if guid>typelib else drop s" " then
        RestoreReg ;

internal

[undefined] (Guid,) [if]
: (Guid,)       ( addr len -- ) \ comments in a guid
        Base @ >r HEX dup 38 <> abort" Invalid Guid Length"
        1 /string  2dup ascii - scan 2dup >r >r nip - hatoi ,
        r> r> ascii - skip 2dup ascii - scan 2dup >r >r nip - hatoi w,
        r> r> ascii - skip 2dup ascii - scan 2dup >r >r nip - hatoi w,
        r> r> ascii - skip 2dup drop 2 0 do dup i 2 * + 2 hatoi c, loop drop
        ascii - scan ascii - skip drop 6 0 do dup i 2 * + 2 hatoi c, loop drop r> base ! ;
[then]

: (guid_typelib) ( major minor addr len -- ) \ load a type library for given GUID into the list
        2>r here typelibhead dup @ , !
        here dup >r 0 , here 0 , 2swap swap here r> 2r> rot >r (Guid,) call LoadRegTypeLib
        abort" Error Loading Type Library"
        r> dup cell+ swap UCOM ITypeLib GetTypeComp abort" Error Getting TypeComp" ;

external

: guid_typelib  ( "GUID" -- ) \ load a type library for given GUID into the list
        parse-word ?dup
        if   AxInitReg
             2dup guid>version 2swap guid>typelib (guid_typelib)
             RestoreReg
        else drop abort" GUID missing"
        then ;

: .AxInfo       ( "GUID" -- )
        cr cr ." ActiveX Control info"
        parse-word
        ?dup
        if   AxInitReg
             2dup (.AxInfo)
             2dup guid>version 2swap guid>typelib (guid_typelib)
             cr ." CoClasses:"  tab CoClasses
             cr cr ." Interfaces:" tab Interfaces
             cr cr ." Structures:" tab Structures
             cr cr ." ComConsts:"  tab ComConsts
             AxRestoreReg
        else drop
        then cr ;

module

in-application

cr .( Usage:   .axinfo <guid>)
cr .( Example: .axinfo {0002DF01-0000-0000-C000-000000000046})

--- NEW FILE: AXConList.F ---
\ $Id: AXConList.F,v 1.1 2007/05/16 20:24:58 jos_ven Exp $

\ Dump all installed ActiveX Controls to the console
\ Thomas Dixon

anew -AXConList.f

needs fcom \ include the com library

internal

in-system

\ define some guids
UUID StdComponentCategoriesMgr {0002E005-0000-0000-C000-000000000046}
UUID AXControl {40FC6ED4-2438-11cf-A3DB-080036F12502}

\ I couldn't find a typelibrary for these interfaces, so I must statically
\ define them.  There are only two, so it's not bad.

IUnknown Interface ICatInformation {0002E013-0000-0000-C000-000000000046}
ICatInformation Open-Interface
  3 3  IMethod EnumCategories ( *ppenumCategoryInfo lcid -- hres )
  4 4  IMethod GetCategoryDesc ( *pszDesc lcid rcatid -- hres )
  6 5  IMethod EnumClassesOfCategories ( *ppenumClsid rgcatidReq cReq rgcatidImpl cImp -- hres )
  6 6  IMethod IsClassOfCategories ( rgcatidReq cReq rgcatidImpl n clsid -- hres )
  3 7  IMethod EnumImplCategoriesOfClass ( *ppenumCatid rclsid -- hres )
  3 8  IMethod EnumReqCategoriesOfClass ( *ppenumCatid clsid -- hres )
Close-Interface

IUnknown Interface IEnumGUID {0002E000-0000-0000-C000-000000000046}
IEnumGUID Open-Interface
  4 3  IMethod Next ( *n *rgelt celt -- hres )
  2 4  IMethod Skip ( *celt -- hres )
  1 5  IMethod Reset ( -- hres )
  2 6  IMethod Clone ( *ppenum -- hres )
Close-Interface

\ Make a few interfaces
ICatInformation comiface catinfo
IEnumGUID comiface enumg

create tempguid 16 allot \ temporary guid buffer

external

\ word to list controls
: .axcontrols ( -- ) cr ." Listing all ActiveX controls:" cr
  catinfo ICatInformation 1 0 StdComponentCategoriesMgr call CoCreateInstance
    abort" Unable to initialize Control Manager!"
  enumg pad 0 axcontrol 1 catinfo EnumClassesOfCategories drop
  enumg reset drop
  begin 0 tempguid 1 enumg next 0= while

    pad tempguid call StringFromCLSID 0=
    if ."   " pad @ zunicount unitype then

    pad 1 tempguid call OleRegGetUserType 0=
    if ."   " pad @ zunicount unitype then

    cr repeat
  enumg IReleaseref drop
  catinfo IReleaseref drop ;


MODULE

.axcontrols

in-application

--- NEW FILE: FCOM.F ---
\ Component Object Module Interface for Win32forth
\ Tom Dixon

needs Unicode

anew -FCOM.f

internal
external

library oleaut32.dll

\ List Library (if not defined)
[DEFINED] lrest NOT [IF]
  : cons ( node list -- list ) over ! ;
  : lrest ( list -- list ) @ ;
  : node, ( -- node ) here 0 , ;
[THEN]

[...1049 lines suppressed...]
 \ if, for one reason or another, you don't want to use the type libraries, you
 \ can define it yourself as shown below.

\  0 Interface IUnknown    {00000000-0000-0000-C000-000000000046}
\  IUnknown Open-Interface
\    3 0  IMethod IQueryInterface ( ppv riid -- hres )
\    1 1  IMethod IAddRef ( -- refs )
\    1 2  IMethod IReleaseRef (  -- refs )
\  Close-Interface

 \ you can do the same with structures, but there are better ways to do
 \ structures.

 \ My primary purpose in writing this was to make interfacing to COM just as
 \ easy as using a dll (if not more so).  I tried to make it fast, which may
 \ have lost some of the readability.  This only supports early-binding.  This
 \ shouldn't be a problem, because nearly every component out there has a "dual"
 \ interface anyway.
))

[Win32forth-cvs] win32forth-stc/demos RebarControlDemo.f,NONE,1.1

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/demos
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv19010/win32forth-stc/demos

Added Files:
	RebarControlDemo.f 
Log Message:
gah:made ?turnkeyed work, and fixed bugs in recognising if words are in particular areas.

--- NEW FILE: RebarControlDemo.f ---
\ $Id: RebarControlDemo.f,v 1.1 2007/05/16 16:50:23 georgeahubert Exp $

\ Demonstrates the use of a rebar control to display bands containing various controls.
\ Bands can be detached into tool windows.
\ Sunday, June 04 2006  21:44:15 Rod Oakford


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\ Detachable Tool Window Class \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

Require controls.f
Require childwnd.f
Require rebarcontrol.f

COLOR_BTNFACE Call GetSysColor new-color BTNFACE

:Class ToolWindow   <Super Window

int child    \ child = control, parent = rebar
\ int parent   \ needed in earlier versions of Win32Forth

:M Start: ( child -- )   \ start hidden
        hWnd
        IF  drop
        ELSE
            to child
            GetParent: child to parent
            register-frame-window drop
            create-frame-window to hWnd
        THEN ;M

:M On_Paint: ( -- )   0 0 Width Height BTNFACE FillArea: dc ;M

:M WindowStyle: ( -- style )   [ WS_POPUP WS_CAPTION or ] literal ;M

:M ExWindowStyle: ( -- exstyle )   WS_EX_TOOLWINDOW ;M

:M StartSize: ( -- w h )   StartSize: child ;M

:M StartPos: ( -- w h )   StartPos: child ;M

:M ParentWindow: ( -- hWndparent )   GetHandle: parent ;M

: SetParentOfChild ( hWndparent -- )   GetHandle: child  call SetParent drop ;

:M Detach: ( -- )
        GetID: child IdToIndex: parent DeleteBand: parent
        hWnd SetParentOfChild
        SW_SHOW Show: child
        StartPos: self  StartSize: self  Move: child
        0 get-mouse-XY SetWindowPos: self
        ;M

:M Attach: ( uBand -- )
        GetHandle: parent SetParentOfChild
        child InsertChild: parent
        SW_HIDE Show: self
        ;M

:M WM_NCLBUTTONDBLCLK ( h m w l -- res )   -1 Attach: self  0 ;M

:M WM_EXITSIZEMOVE ( h m w l -- res )
        HitTest: parent  dup 1+ IF  Attach: self  ELSE  drop  THEN  0 ;M

;Class


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\ Some Toolbars \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

Needs Toolbar.f

1 value IDM_NEW
2 value IDM_OPEN
3 value IDM_SAVE
4 value IDM_PRINT
5 value IDM_FIND
6 value IDM_REPLACE
7 value IDM_CUT
8 value IDM_COPY
9 value IDM_PASTE
10 value IDM_UNDO
11 value IDM_REDO
12 value IDM_PRINTPRE
13 value IDM_DELETE
14 value IDM_PROPERTIES
15 value IDM_HELP

:Object Toolbar1 ( parent -- )   <super Win32ToolBar

:ToolBarTable FileButtons
\   Bitmap            index id           Initial state   Initial style   tool string index
    STD_FILENEW       IDM_NEW           TBSTATE_ENABLED   BTNS_BUTTON    0  ToolBarButton,
    STD_FILEOPEN      IDM_OPEN          TBSTATE_ENABLED   BTNS_BUTTON    0  ToolBarButton,
    STD_FILESAVE      IDM_SAVE          TBSTATE_ENABLED   BTNS_BUTTON    0  ToolBarButton,
                                                                          SeparatorButton,
    STD_PRINT         IDM_PRINT         TBSTATE_ENABLED   BTNS_BUTTON    0  ToolBarButton,
                                                                          SeparatorButton,
    STD_FIND          IDM_FIND          TBSTATE_ENABLED   BTNS_BUTTON    0  ToolBarButton,
    STD_REPLACE       IDM_REPLACE       TBSTATE_ENABLED   BTNS_BUTTON    0  ToolBarButton,
;ToolBarTable

:M WindowStyle: ( -- style )   \ start hidden
        [ WS_CHILD WS_CLIPCHILDREN or CCS_NODIVIDER or CCS_NOPARENTALIGN or CCS_NORESIZE or ] literal ;M

:M StartSize: ( -- w h )   \ start size in popup window
        hWnd
        IF
            GetButtonCount: self 1-   \ last button
            GetButtonRect: self  >r  over 2* +  rot drop  swap r> +   \ w=r+2t, h=b+t
        ELSE
            StartSize: super
        THEN ;M

:M StartPos: ( -- x y )   \ start position in popup window
        hWnd
        IF    0 GetButtonRect: self  2drop nip  0   \ x=top, y=0
        ELSE  StartPos: super
        THEN ;M

:M Start: ( parent -- )
        FileButtons IsButtonTable: self
        Start: super
        HINST_COMMCTRL  IDB_STD_SMALL_COLOR  15 AddBitmaps: self drop
        ;M

;Object


:Object Toolbar2 ( parent -- )   <super Win32ToolBar

:ToolBarTable EditButtons
\   Bitmap            index id           Initial state   Initial style   tool string index
    STD_CUT           IDM_CUT           TBSTATE_ENABLED   BTNS_BUTTON    0  ToolBarButton,
    STD_COPY          IDM_COPY          TBSTATE_ENABLED   BTNS_BUTTON    0  ToolBarButton,
    STD_PASTE         IDM_PASTE         TBSTATE_ENABLED   BTNS_BUTTON    0  ToolBarButton,
    STD_UNDO          IDM_UNDO          TBSTATE_ENABLED   BTNS_BUTTON    0  ToolBarButton,
    STD_REDOW         IDM_REDO          TBSTATE_ENABLED   BTNS_BUTTON    0  ToolBarButton,
;ToolBarTable

:M WindowStyle: ( -- style )   \ start hidden
        [ WS_CHILD WS_CLIPCHILDREN or CCS_NODIVIDER or CCS_NOPARENTALIGN or CCS_NORESIZE or ] literal ;M

:M StartSize: ( -- w h )   \ start size in popup window
        hWnd
        IF
            GetButtonCount: self 1-   \ last button
            GetButtonRect: self  >r  over 2* +  rot drop  swap r> +   \ w=r+2t, h=b+t
        ELSE
            StartSize: super
        THEN ;M

:M StartPos: ( -- x y )   \ start position in popup window
        hWnd
        IF    0 GetButtonRect: self  2drop nip  0   \ x=top, y=0
        ELSE  StartPos: super
        THEN ;M

:M Start: ( parent -- )
        EditButtons IsButtonTable: self
        Start: super
        HINST_COMMCTRL  IDB_STD_SMALL_COLOR  15 AddBitmaps: self drop
        ;M

;Object


:Object Toolbar3 ( parent -- )   <super Win32ToolBar

:ToolBarTable MiscButtons
\   Bitmap            index id           Initial state   Initial style   tool string index
    STD_PRINTPRE      IDM_PRINTPRE      TBSTATE_ENABLED   BTNS_BUTTON    0  ToolBarButton,
    STD_DELETE        IDM_DELETE        TBSTATE_ENABLED   BTNS_BUTTON    0  ToolBarButton,
    STD_PROPERTIES    IDM_PROPERTIES    TBSTATE_ENABLED   BTNS_BUTTON    0  ToolBarButton,
    STD_HELP          IDM_HELP          TBSTATE_ENABLED   BTNS_BUTTON    0  ToolBarButton,
;ToolBarTable

:M WindowStyle: ( -- style )   \ start hidden
        [ WS_CHILD WS_CLIPCHILDREN or CCS_NODIVIDER or CCS_NOPARENTALIGN or CCS_NORESIZE or ] literal ;M

:M StartSize: ( -- w h )   \ start size in popup window
        hWnd
        IF
            GetButtonCount: self 1-   \ last button
            GetButtonRect: self  >r  over 2* +  rot drop  swap r> +   \ w=r+2t, h=b+t
        ELSE
            StartSize: super
        THEN ;M

:M StartPos: ( -- x y )   \ start position in popup window
        hWnd
        IF    0 GetButtonRect: self  2drop nip  0   \ x=top, y=0
        ELSE  StartPos: super
        THEN ;M

:M Start: ( parent -- )
        MiscButtons IsButtonTable: self
        Start: super
        HINST_COMMCTRL  IDB_STD_SMALL_COLOR  15 AddBitmaps: self drop
        ;M

;Object


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\ A Combobox \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

:Object TheCombo   <super ComboControl

:M StartSize: ( -- x y )   100 60 ;M   \ start size in popup window

:M Start: ( Parent -- )
        start: super
        s" Option 2" InsertString: self
        s" Option 1" InsertString: self
        ;M

;Object


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\ An Editbox \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

EditControl TheEdit


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\ The Rebar \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

\ Needs RebarControl.f

ToolWindow Toolbar1Popup
ToolWindow Toolbar2Popup
ToolWindow Toolbar3Popup
ToolWindow ComboPopup
ToolWindow EditPopup

:Object TheRebar   <Super RebarControl

:M WindowStyle: ( -- style )
        WindowStyle: super
        [ WS_CLIPSIBLINGS WS_CLIPCHILDREN or WS_BORDER or RBS_VARHEIGHT or RBS_BANDBORDERS or RBS_DBLCLKTOGGLE or ] literal or
        ;M

: InsertToolbar1 ( uBand -- )
        Eraseband-info
        [ RBBIM_STYLE RBBIM_CHILD or RBBIM_CHILDSIZE or RBBIM_ID or ] literal to bfmask
        RBBS_CHILDEDGE to fstyle
        GetHandle: Toolbar1 to hWndChild
        StartSize: Toolbar1  to cyMinChild to cxMinChild
        GetID: Toolbar1 to wID
        InsertBandAt: self ;

: InsertToolbar2 ( uBand -- )
        Eraseband-info
        [ RBBIM_STYLE RBBIM_CHILD or RBBIM_CHILDSIZE or RBBIM_ID or ] literal to bfmask
        RBBS_CHILDEDGE to fstyle
        GetHandle: Toolbar2 to hWndChild
        StartSize: Toolbar2  to cyMinChild to cxMinChild
        GetID: Toolbar2 to wID
        InsertBandAt: self ;

: InsertToolbar3 ( uBand -- )
        Eraseband-info
        [ RBBIM_STYLE RBBIM_CHILD or RBBIM_CHILDSIZE or RBBIM_ID or ] literal to bfmask
        RBBS_CHILDEDGE to fstyle
        GetHandle: Toolbar3 to hWndChild
        StartSize: Toolbar3  to cyMinChild to cxMinChild
        GetID: Toolbar3 to wID
        InsertBandAt: self ;

: InsertCombo ( uBand -- )
        Eraseband-info
        [ RBBIM_STYLE RBBIM_TEXT or RBBIM_IMAGE or RBBIM_CHILD or RBBIM_CHILDSIZE or RBBIM_ID or ] literal to bfmask
        RBBS_CHILDEDGE RBBS_BREAK or to fstyle   \ start band on a new row
        z" Combobox" to lpText
        0 to iImage
        GetHandle: TheCombo to hWndChild
        StartSize: TheCombo to cyMinChild to cxMinChild
        GetID: TheCombo to wID
        InsertBandAt: self ;

: InsertEdit ( uBand -- )
        Eraseband-info
        [ RBBIM_STYLE RBBIM_TEXT or RBBIM_CHILD or RBBIM_CHILDSIZE or RBBIM_ID or ] literal to bfmask
        RBBS_CHILDEDGE to fstyle
        z" Editbox" to lpText
        0 to iImage
        GetHandle: TheEdit to hWndChild
        StartSize: TheEdit to cyMinChild to cxMinChild
        GetID: TheEdit to wID
        InsertBandAt: self ;

:M InsertChild: ( uBand child -- )
        Case
            Toolbar1  of  InsertToolbar1  Endof
            Toolbar2  of  InsertToolbar2  Endof
            Toolbar3  of  InsertToolbar3  Endof
            TheCombo  of  InsertCombo     Endof
            TheEdit   of  InsertEdit      Endof
            ( default ) drop
        EndCase
        ;M

:M DetachChild: ( wID -- )
        HitTest: self 1+
        IF  drop
        ELSE
            EndDrag: self
            Case
                GetID: Toolbar1  of  Detach: Toolbar1Popup  endof
                GetID: Toolbar2  of  Detach: Toolbar2Popup  endof
                GetID: Toolbar3  of  Detach: Toolbar3Popup  endof
                GetID: TheCombo  of  Detach: ComboPopup     endof
                GetID: TheEdit   of  Detach: EditPopup      endof
                ( default ) drop
            EndCase
        THEN ;M

:M Start: ( parent -- )
        Start: super
        0 1 ILC_COLORDDB ILC_MASK or 32 32 call ImageList_Create
        101 AppInst call LoadIcon
        over call ImageList_AddIcon drop
        RBIM_IMAGELIST SetBarInfo: self

        self Start: Toolbar1
        0 InsertToolbar1
        Toolbar1 start: Toolbar1Popup
        s" Toolbar1" SetText: Toolbar1Popup

        self Start: Toolbar2
        1 InsertToolbar2
        Toolbar2 start: Toolbar2Popup
        s" Toolbar2" SetText: Toolbar2Popup

        self Start: Toolbar3
        2 InsertToolbar3
        Toolbar3 start: Toolbar3Popup
        s" Toolbar3" SetText: Toolbar3Popup

        self Start: TheCombo
        3 InsertCombo
        TheCombo start: ComboPopup
        s" Combobox" SetText: ComboPopup

        self Start: TheEdit
        4 InsertEdit
        TheEdit start: EditPopup
        s" Editbox" SetText: EditPopup

        0 MinimizeBand: self
        0 1 MaximizeBand: self
        0 2 MaximizeBand: self

        ;M

;Object


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\ A Child Window \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

:Object TheChild   <Super Child-Window

:M WndClassStyle: ( -- style )   CS_DBLCLKS ;M

:M On_Init: ( -- )
\        CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong  drop   \ needed in earlier versions of Win32Forth
        ;M

:M On_Paint: ( -- )
        0 0 width height green FillArea: dc
        TRANSPARENT SetBkMode: dc
        0 0
        15 + 2dup s" REBAR CONTROL DEMO" TextOut: dc  15 +
        15 + 2dup s" Bands can be moved by clicking and dragging on the gripper, text or image." TextOut: dc
        15 + 2dup s" Double clicking toggles the minimum/maximum size of the band." TextOut: dc
        15 + 2dup s" Bands can be detached by dragging them off the rebar." TextOut: dc
        15 + 2dup s" Double clicking the tool window attaches the band at the last position of the rebar." TextOut: dc
        15 + 2dup s" Bands can be re-attached at any position by dropping the tool window on the rebar." TextOut: dc
        15 + 2dup s" The rebar is auto-arranged when the main window is resized." TextOut: dc
        2drop ;M

;Object


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\ The Main Window \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

:Object Frame   <Super Window

:M WindowStyle: ( -- style )   WindowStyle: Super WS_CLIPCHILDREN or ;M

:M WndClassStyle: ( -- style )   CS_DBLCLKS ;M

:M WindowHasMenu: ( -- f )   true ;M

:M On_Init: ( -- )
\        CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong  drop   \ needed in earlier versions of Win32Forth
        self start: TheChild
        self start: TheRebar
        ;M

:M On_Size: ( -- )
        0  Height: TheRebar  Width  Height Height: TheRebar -
        Move: TheChild
        AutoSize: TheRebar
        ;M

:M WM_NOTIFY ( hwnd msg wparam lparam -- res )
        dup 8 + @        \ fetch code from NMHDR structure
        Case
            RBN_ENDDRAG       of  dup 24 + @ ( wID ) DetachChild: TheRebar  endof
            RBN_HEIGHTCHANGE  of  On_Size: self                             endof
        EndCase
        0 ;M

:M OnWmCommand: ( hwnd msg wparam lparam -- hwnd msg wparam lparam )
        over HIWORD ( notification code )
        Case
            CBN_SELCHANGE  of   cr ." Combobox selection changed"  endof
            EN_CHANGE      of   cr ." Editbox text changed"        endof
        EndCase

        over LOWORD ( command ID )  dup 1 16 within
        IF    cr ." Toolbar button " .      \ intercept Toolbar commands
        ELSE  drop  OnWmCommand: Super      \ intercept Menu commands
        THEN ;M

;Object

start: frame

[Win32forth-cvs] win32forth-stc/src dis486.f,1.19,1.20

[Alex M. <ale...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv27502

Modified Files:
	dis486.f 
Log Message:
arm: support for extensibly describing different types of words

Index: dis486.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/dis486.f,v
retrieving revision 1.19
retrieving revision 1.20
diff -C2 -d -r1.19 -r1.20
*** dis486.f	10 May 2007 06:28:16 -0000	1.19
--- dis486.f	14 May 2007 16:01:00 -0000	1.20
***************
*** 1031,1034 ****
--- 1031,1060 ----
  : desc-stack    ( n -- )
                  dup 0< if drop ." ? " else . then ;
+                 
+ variable desc-list 0 desc-list !                     \ list of desc-hows
+ 
+ : desc-how      ( xt type -- )                       \ how to see an xt
+                 here >r 0 , , , r>                   \ link, type, xt
+                 desc-list add-link ;                 \ add in the link
+ 
+ :noname ( xt nfa -- ) swap execute . ." value " .id                       ; tval desc-how \ for value
+ :noname ( xt nfa -- ) ." variable " .id ." ( is " execute @ 10. ." ) "    ; tvar desc-how \ for variable
+ :noname ( xt nfa -- ) swap execute . ." constant " .id                    ; tcon desc-how \ for constant
+ :noname ( xt nfa -- ) swap >body @ . ." user " .id                        ; tusr desc-how \ for user
+ :noname ( xt nfa -- ) ." defer " .id ." ( is " defer@ .name ." )"         ; tdef desc-how \ for defer
+ :noname ( xt nfa -- ) ." : " .id drop                                     ; tcol desc-how \ for colon
+ :noname ( xt nfa -- ) ." vocabulary " .id drop                            ; tvoc desc-how \ for vocabulary
+ :noname ( xt nfa -- ) ." create " .id ." ( addr " execute $. ." ) "       ; tcre desc-how \ for create
+ :noname ( xt nfa -- ) 0 rot execute . ." offset " .id                     ; toff desc-how \ for offset
+ 
+ : desc-type     ( xt nfa type -- )                   \ find entry and execute
+                 desc-list                            \ fetch entry from linked
+                 begin @ dup                          \ list and cehck if match on type
+                 while
+                   2dup cell+ @ = if                  \ type entry, check type
+                     nip 2 cells+ @ execute exit      \ matches, so execute
+                   then
+                 repeat 
+                 2drop ." ? " .id drop ;              \ default
  
  also forth definitions
***************
*** 1052,1080 ****
  \ *bug needs to check for :noname type xts
  : describe      ( xt -- )
!                 dup>r >name cr
!                 
!                 \ do the header piece;
!                 dup dup n>tfa c@
!                 case
!                   tval of r@ execute . ." value "    .id                         endof
!                   tcon of r@ execute . ." constant " .id                         endof
!                   tvar of ." variable " .id ." ( is " r@ execute @ 10. ." ) "    endof
!                   tcre of ." create "   .id ." ( addr " r@ execute $. ." ) "     endof
!                   tcol of ." : " .id                                             endof
!                   tdef of ." defer " .id ." ( is " r@ defer@ .name ." )"         endof
!                   tvoc of ." vocabulary " .id                                    endof
!                   toff of 0 r@ execute . ." offset " .id                         endof
!                   swap ." : " .id ." ( no type )"
!                 endcase
  
                  \ stack effects
!                 dup (in/out@) swap
!                   ." ( " desc-stack
!                   ." -- " desc-stack
!                 dup ." ) "
  
                  \ compile information
                  oper-col ." \ "
-                 r>                                \ get the xt
                  dup >comp @ dup                   \ fetch the comp xt
                  case
--- 1078,1091 ----
  \ *bug needs to check for :noname type xts
  : describe      ( xt -- )
!                 cr
!                 dup >name 2dup dup>r dup n>tfa c@   \ xt nfa xt nfa type (r: nfa)
!                 desc-type                           \ do the type of the name
  
                  \ stack effects
!                 (in/out@) swap                      \ nfa, get in/out
!                   ." ( " desc-stack ." -- " desc-stack ." ) "
  
                  \ compile information
                  oper-col ." \ "
                  dup >comp @ dup                   \ fetch the comp xt
                  case
***************
*** 1093,1102 ****
  
                  \ misc head info
                  cr oper-col ." \ len=" n>ofa w@ .
!                 dup ." type=" n>tfa c@ .
!                 dup ." flag=" n>flg c@ h.2
  
                  \ tell user where the word was loaded
!                 cr oper-col ." \ " .viewinfo
                  ;
  
--- 1104,1114 ----
  
                  \ misc head info
+                 r@                                 \ get back nfa
                  cr oper-col ." \ len=" n>ofa w@ .
!                 r@ ." type=" n>tfa c@ .
!                 r@ ." flag=" n>flg c@ h.2
  
                  \ tell user where the word was loaded
!                 cr oper-col ." \ " r> .viewinfo
                  ;
  

[Win32forth-cvs] $59.95 Adobe Dreamweaver

[Christy S. <jke...@om...>]

<html>
<body bgcolor=3D"#ffffff" text=3D"#000000">
<img src=3D"cid:78BC2D91=2E1AFB46F7">
<br>
Man is an ape with possibilities=2E
<br>
Boredom is the dream bird that hatches the egg of experience=2E A rustli=
ng in the leaves drives him away=2E
<br>
The taste of defeat has a richness of experience all its own=2E
<br>
A physician can sometimes parry the scythe of death, but has no power ov=
er the sand in the hourglass=2E
<br>
We want all our friends to tell us our bad qualities it is only the part=
icular ass that does so whom we can't tolerate=2E
<br>
Common Sense is very uncommon=2E
<br>
As a twig is bent the tree inclines=2E
<br>
The gospel is neither a discussion or a debate=2E It is an announcement=2E=

<br>
The problems of this world are only truly solved in two ways: by extinct=
ion or duplication=2E
<br>
If you once turn on your side after the hour at which you ought to rise,=
 it is all over=2E Bolt up at once=2E
<br>
The only way to know how customers see your business is to look at it th=
rough their eyes=2E
<br>
Extended empires are like expanded gold, exchanging solid strength for f=
eeble splendor=2E
<br>
To exist is a habit I do not despair of acquiring=2E
</body>
</html>

[Win32forth-cvs] win32forth/apps/ForthForm ABOUT.F,1.4,1.5

[Ezra B. <ezr...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/ForthForm
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv25953/apps/ForthForm

Modified Files:
	ABOUT.F 
Log Message:
Minor update. EAB

Index: ABOUT.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/ABOUT.F,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** ABOUT.F	27 Dec 2006 18:43:57 -0000	1.4
--- ABOUT.F	14 May 2007 05:38:56 -0000	1.5
***************
*** 11,15 ****
  +z," with\n"
  +z," Contributions by Dirk Busch,Rod Oakford\n"
! +z," 2000-2006"
  here about-ForthForm-message - constant message-length
  
--- 11,15 ----
  +z," with\n"
  +z," Contributions by Dirk Busch,Rod Oakford\n"
! +z," 2000-2007"
  here about-ForthForm-message - constant message-length
  

[Win32forth-cvs] win32forth/apps/Win32ForthIDE EdPreferences.f, 1.2, 1.3 EdReplace.f, 1.1, 1.2 Main.f, 1.39, 1.40 ProjectTree.f, 1.16, 1.17

[Ezra B. <ezr...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/Win32ForthIDE
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv25188

Modified Files:
	EdPreferences.f EdReplace.f Main.f ProjectTree.f 
Log Message:
Small enhancement to search & replace. Some code tidying. EAB

Index: Main.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/Main.f,v
retrieving revision 1.39
retrieving revision 1.40
diff -C2 -d -r1.39 -r1.40
*** Main.f	13 May 2007 07:52:26 -0000	1.39
--- Main.f	14 May 2007 05:37:39 -0000	1.40
***************
*** 98,104 ****
  needs EdTabControl.f
  
- \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
- \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
- 
  Needs Task.f
  
--- 98,101 ----
***************
*** 143,147 ****
  : InitClassBrowsers ( -- )
          VocInitTask   run-task 0= abort" Failed to start background Task"
!         ClassInitTask run-task 0= abort" Failed to start background Task" ;
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
--- 140,144 ----
  : InitClassBrowsers ( -- )
          VocInitTask   run-task 0= abort" Failed to start background Task"
!         ClassInitTask run-task 0= abort" Failed to start background Task"  ;
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
***************
*** 741,745 ****
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  
! fload ScintillaMDI.f
  fload ScintillaHyperMDI.f
  fload EdHexViewer.f
--- 738,742 ----
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  
! needs ScintillaMDI.f
  fload ScintillaHyperMDI.f
  fload EdHexViewer.f

Index: ProjectTree.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/ProjectTree.f,v
retrieving revision 1.16
retrieving revision 1.17
diff -C2 -d -r1.16 -r1.17
*** ProjectTree.f	25 Feb 2007 19:04:42 -0000	1.16
--- ProjectTree.f	14 May 2007 05:37:39 -0000	1.17
***************
*** 20,24 ****
  \   0 value TheStatusBar
     0 value TheStatusBar
! 
     0 value dirty?
     0 value Modified
--- 20,24 ----
  \   0 value TheStatusBar
     0 value TheStatusBar
!    0 value module?
     0 value dirty?
     0 value Modified
***************
*** 75,79 ****
              short itemflags
             1 bits itemid            \ item id, 0 for child item
!           15 bits reservedflags
          4 cells bytes reserved
  ;recordsize: sizeof(iteminfo)
--- 75,80 ----
              short itemflags
             1 bits itemid            \ item id, 0 for child item
!            1 bits recursed
!           14 bits reservedflags
          4 cells bytes reserved
  ;recordsize: sizeof(iteminfo)
***************
*** 116,119 ****
--- 117,126 ----
  :m isitemid:    ( f -- )
                  to itemid ;m
+ 
+ :m recursed:	( -- recursed )
+ 		recursed ;m
+ 
+ :m isrecursed:  ( f -- )
+ 		to recursed ;m
  ;class
  
***************
*** 287,312 ****
                  ;
  
  :M AddItem:     ( str cnt parentlist -- )
                  to ThisList pad place
                  no-duplicates?
!                 if      #items: ThisList ?dup
!                         if      1+ 1
!                                 do      i >Link#: ThisList
!                                         Data@: ThisList Getname: [ ] zcount
!                                         pad count istr=
!                                         if      unloop exitm
!                                         then
!                                 loop
!                         then
                  then    Data@: ThisList
!                 if              AddLink: ThisList
                  then    New> TreeItem dup Data!: ThisList to ThisItem
!                 pad count UpdateList ;M
  
  :m AddModule:   ( str cnt -- )
!                 ModuleList AddItem: self ;m
  
  :m AddForm:     ( str cnt -- )
!                 FormList AddItem: self ;m
  
  :m AddDLL:      ( str cnt -- )
--- 294,322 ----
                  ;
  
+ :M InList?:	{ str cnt thelist -- f }
+ 		#items: TheList ?dup
+                 if      1+ 1
+                         do      i >Link#: TheList
+                                 Data@: TheList Getname: [ dup ] zcount
+                                 str cnt istr=
+                                 if      unloop exitm
+                                 then	drop
+                         loop
+                 then	0 ;M
+ 
  :M AddItem:     ( str cnt parentlist -- )
                  to ThisList pad place
                  no-duplicates?
!                 if      pad count ThisList inlist?: self ?exitm
                  then    Data@: ThisList
!                 if      AddLink: ThisList
                  then    New> TreeItem dup Data!: ThisList to ThisItem
!                 pad count 2dup cr type UpdateList ;M
  
  :m AddModule:   ( str cnt -- )
!                 true to module? ModuleList AddItem: self ;m
  
  :m AddForm:     ( str cnt -- )
!                 false to module? FormList AddItem: self ;m
  
  :m AddDLL:      ( str cnt -- )
***************
*** 968,973 ****
                  s" sys-winlibrary"  "of  true to skip-recurse?                 true  endof    \ don't search .dll file
                  s" load-dialog"     "of  true to skip-recurse? true to dialog? true  endof    \ add .res and .h later
!                 s" thisfile"        "of  true to skip-recurse?                 true  endof    \ special word for PM   ???
!                 s" load-bitmap"     "of  bl word drop  true to skip-recurse?   true  endof    \ skip bitmap name
                  s" toolbar"         "of  bl word drop  true to skip-recurse?   true  endof    \ skip bitmap name
                  ( default ) false swap
--- 978,982 ----
                  s" sys-winlibrary"  "of  true to skip-recurse?                 true  endof    \ don't search .dll file
                  s" load-dialog"     "of  true to skip-recurse? true to dialog? true  endof    \ add .res and .h later
! \                s" load-bitmap"     "of   bl word drop  true to skip-recurse?   true  endof    \ skip bitmap name
                  s" toolbar"         "of  bl word drop  true to skip-recurse?   true  endof    \ skip bitmap name
                  ( default ) false swap
***************
*** 990,994 ****
  
  \ Given file name search for needed files
! : BuildNeededFiles  { fname fcnt \ tmp$ -- }      \ recursive routine
                  false to comment?
                  maxstring localalloc: tmp$
--- 999,1003 ----
  
  \ Given file name search for needed files
! : BuildNeededFiles  { fname fcnt \ tmp$ obj -- }      \ recursive routine
                  false to comment?
                  maxstring localalloc: tmp$
***************
*** 1012,1024 ****
                              if
                                  2dup addfile
- \                                2dup SetText: ProjStatus
                                  dialog? IF
                                              2dup pad place -2 pad c+! s" .res" pad +place
                                              pad count addfile
- 
                                          THEN
                                  skip-recurse?
                                  if     2drop
!                                 else   comment? -rot  recurse   to comment?   \ save comment? on stack
                                  then
                              then
--- 1021,1037 ----
                              if
                                  2dup addfile
                                  dialog? IF
                                              2dup pad place -2 pad c+! s" .res" pad +place
                                              pad count addfile
                                          THEN
                                  skip-recurse?
                                  if     2drop
!                                 else   comment? >r  2dup module?
! 					if  modulelist: theproject
! 					else	formlist: theproject
! 					then	inlist?: theproject to obj recursed: obj 0=
! 					if	cr ." recursing " type recurse      \ save comment? on stack
! 					else	2drop
! 					then	r> to comment? true isrecursed: obj
                                  then
                              then
***************
*** 1045,1054 ****
                                  SetBuildFile: TheProject
                          else    drop exit
!                         then    GetBuildFile: TheProject ModuleList: TheProject
!                                 AddItem: TheProject
!                                 true to Modified
                  then
                  fClear if Clear: TheProject then
- \                s" " SetText: ProjStatus
                  GetBuildFile: TheProject ModuleList: TheProject
                  AddItem: TheProject
--- 1058,1064 ----
                                  SetBuildFile: TheProject
                          else    drop exit
!                         then
                  then
                  fClear if Clear: TheProject then
                  GetBuildFile: TheProject ModuleList: TheProject
                  AddItem: TheProject
***************
*** 1056,1068 ****
  
                  GetBuildFile: TheProject BuildNeededFiles
-                 #addedfiles Modified or to Modified
-                 #addedfiles (.) pad place
-                 s"  files added " pad +place
-                 #linecount (.) pad +place
-                 s"  total lines search of " pad +place
-                 total-size (.) pad +place
-                 s"  bytes" pad +place
- 
-                 GetBuildFile: TheProject SetBuildFile: TheProject \ update info
  
                  SortParentLists: TheProject
--- 1066,1069 ----

Index: EdPreferences.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/EdPreferences.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** EdPreferences.f	13 Jan 2007 02:20:10 -0000	1.2
--- EdPreferences.f	14 May 2007 05:37:39 -0000	1.3
***************
*** 39,43 ****
  
  
! :m close:                 ( -- )
                            color: fore to fore-color
                            color: back to back-color
--- 39,43 ----
  
  
! : savecolors               ( -- )
                            color: fore to fore-color
                            color: back to back-color
***************
*** 48,52 ****
  			  IsButtonChecked?: chkAutoIndent to autoindent?
                            Update
!                           close: super ;m
  
  : command-func            ( id obj -- )
--- 48,52 ----
  			  IsButtonChecked?: chkAutoIndent to autoindent?
                            Update
!                           ;
  
  : command-func            ( id obj -- )
***************
*** 58,63 ****
                                getid: btnSelectFore    of choose: selfore if color: selfore paint: selfore-window then endof
                                getid: btnSelectBack    of choose: selback if color: selback paint: selback-window then endof
!                               getid: btncancel        of close: super endof
!                               getid: btnok            of close: self endof
                            endcase ;
  
--- 58,63 ----
                                getid: btnSelectFore    of choose: selfore if color: selfore paint: selfore-window then endof
                                getid: btnSelectBack    of choose: selback if color: selback paint: selback-window then endof
!                               getid: btncancel        of close: self endof
!                               getid: btnok            of savecolors close: self endof
                            endcase ;
  

Index: EdReplace.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/EdReplace.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** EdReplace.f	15 Apr 2007 02:55:45 -0000	1.1
--- EdReplace.f	14 May 2007 05:37:39 -0000	1.2
***************
*** 12,19 ****
--- 12,26 ----
  0 value scope
  0 value replacecount
+ 0 value savedpos
  
  : SearchForText	( -- f )
  		findbuf count SearchInTarget: CurrentWindow -1 <> ;
  
+ : SavePosition	( -- )
+ 		GetCurrentPos: CurrentWindow to savedpos ;
+ 
+ : RestorePosition ( -- )
+ 		savedpos GotoPos: CurrentWindow ;
+ 
  : setflags	( -- )
  		0	\ default
***************
*** 37,41 ****
  : SetTargetRange	( -- ) \ what to search
  		direction
! 		if	GetTargetStart: CurrentWindow 0
  		else	GetTargetEnd: CurrentWindow GetTextLength: CurrentWindow
  		then	SetTargetEnd: CurrentWindow SetTargetStart: CurrentWindow ;
--- 44,48 ----
  : SetTargetRange	( -- ) \ what to search
  		direction
! 		if	GetTargetStart: CurrentWindow 0		\ backwards
  		else	GetTargetEnd: CurrentWindow GetTextLength: CurrentWindow
  		then	SetTargetEnd: CurrentWindow SetTargetStart: CurrentWindow ;
***************
*** 56,60 ****
  		s"  time(s)." pad +place
  		true pad count ?MessageBox
! 		0 GotoPos: CurrentWindow ;
  
  :Object frmConfirmPrompt	<Super frmPrompt
--- 63,67 ----
  		s"  time(s)." pad +place
  		true pad count ?MessageBox
! 		RestorePosition ;
  
  :Object frmConfirmPrompt	<Super frmPrompt
***************
*** 134,137 ****
--- 141,154 ----
  		endcase	;
  
+ : ?TextSelected	{ \ SelBuf$ -- }
+                 \ replace findbuf contents if text is selected
+                 0 GetSelText: CurrentWindow LocalAlloc: SelBuf$
+                 SelBuf$ GetSelText: CurrentWindow
+                 if   SelBuf$ zcount BL skip -trailing 10 -TRAILCHARS 13 -TRAILCHARS
+                      ?dup
+                      if 	maxstring min Findbuf place
+                      else 	drop
+                      then
+                 then	;
  
  :M ON_INIT:	( -- )
***************
*** 151,154 ****
--- 168,173 ----
  		scope    Check: radCurrent
  
+ 		?TextSelected
+ 
  		findbuf count SetText: txtSearch
  		Replacebuf count SetText: txtReplace
***************
*** 158,161 ****
--- 177,182 ----
  		0 to replacecount
  
+ 		SavePosition
+ 
  		;m
  

[Win32forth-cvs] win32forth/src/lib ScintillaControl.f, 1.6, 1.7 ScintillaEdit.f, 1.5, 1.6

[Ezra B. <ezr...@us...>]

Update of /cvsroot/win32forth/win32forth/src/lib
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv23619/src/lib

Modified Files:
	ScintillaControl.f ScintillaEdit.f 
Log Message:
Minor fix to allow flashing cursor in scintilla control.

Index: ScintillaEdit.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/ScintillaEdit.f,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** ScintillaEdit.f	13 Oct 2006 03:50:29 -0000	1.5
--- ScintillaEdit.f	14 May 2007 05:34:38 -0000	1.6
***************
*** 200,207 ****
                  SetWindowTitle: self ;M
  
! :M OpenFile:    ( -- )          \ open a file
                  GetOpenFilename ?dup
                  if   OpenNamedFile: self
!                 else drop
                  then ;M
  
--- 200,207 ----
                  SetWindowTitle: self ;M
  
! :M OpenFile:    ( -- f )          \ open a file
                  GetOpenFilename ?dup
                  if   OpenNamedFile: self
!                 else drop false
                  then ;M
  

Index: ScintillaControl.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/ScintillaControl.f,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
*** ScintillaControl.f	15 Apr 2007 03:30:53 -0000	1.6
--- ScintillaControl.f	14 May 2007 05:34:38 -0000	1.7
***************
*** 1982,1985 ****
--- 1982,1991 ----
          ;M
  
+ :M WM_TIMER  	{ h m w l -- res } \ override so we can get a flashing cursor in scintilla control
+                 old-WndProc
+                 IF      h m w l old-WndProc CallWindowProc
+                 ELSE	0
+                 THEN	;M
+ 
  ;Class
  

[Win32forth-cvs] win32forth-stc/src/kernel gmeta-compiler.f, 1.13, 1.14

[Alex M. <ale...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src/kernel
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv23291/src/kernel

Modified Files:
	gmeta-compiler.f 
Log Message:
arm: correct locals type

Index: gmeta-compiler.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gmeta-compiler.f,v
retrieving revision 1.13
retrieving revision 1.14
diff -C2 -d -r1.13 -r1.14
*** gmeta-compiler.f	22 Mar 2007 02:13:56 -0000	1.13
--- gmeta-compiler.f	13 May 2007 22:13:26 -0000	1.14
***************
*** 549,552 ****
--- 549,554 ----
  : t-tfa! ( type -- )                 \ set the type
           last-h @ n>tfa tsys-c! ;
+          
+ ' t-tfa! alias tfa!                  \ to support localn
  
  : in/out ( n m -- )

[Win32forth-cvs] win32forth-stc gkernel.exe,1.44,1.45

[Alex M. <ale...@us...>]

Update of /cvsroot/win32forth/win32forth-stc
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv23291

Modified Files:
	gkernel.exe 
Log Message:
arm: correct locals type

Index: gkernel.exe
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/gkernel.exe,v
retrieving revision 1.44
retrieving revision 1.45
diff -C2 -d -r1.44 -r1.45
Binary files /tmp/cvsHgFUBX and /tmp/cvsrgaBHK differ

[Win32forth-cvs] win32forth-stc/src Class.f,1.6,1.7

[Alex M. <ale...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv23291/src

Modified Files:
	Class.f 
Log Message:
arm: correct locals type

Index: Class.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/Class.f,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
*** Class.f	8 May 2007 08:34:39 -0000	1.6
--- Class.f	13 May 2007 22:13:26 -0000	1.7
***************
*** 252,269 ****
  in-system
  
- \ Temporary fix for ?isLocal to work
- tloc ' local0  >name n>tfa c!
- tloc ' local1  >name n>tfa c!
- tloc ' local2  >name n>tfa c!
- tloc ' local3  >name n>tfa c!
- tloc ' local4  >name n>tfa c!
- tloc ' local5  >name n>tfa c!
- tloc ' local6  >name n>tfa c!
- tloc ' local7  >name n>tfa c!
- tloc ' local8  >name n>tfa c!
- tloc ' local9  >name n>tfa c!
- tloc ' local10 >name n>tfa c!
- tloc ' local11 >name n>tfa c!
- 
  : [self]        ( -- )
                  true abort" Use only for self-reference to object" ; immediate
--- 252,255 ----

[Win32forth-cvs] win32forth-stc/src/kernel gMeta.f, 1.2, 1.3 gkernel.f, 1.37, 1.38

[Alex M. <ale...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src/kernel
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv7404/src/kernel

Modified Files:
	gMeta.f gkernel.f 
Log Message:
arm: remove caps-xxx functions to ansfile
optimise case statements
reorder kernel source (minor)

Index: gMeta.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gMeta.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** gMeta.f	23 Sep 2006 06:00:17 -0000	1.2
--- gMeta.f	13 May 2007 21:39:27 -0000	1.3
***************
*** 51,55 ****
  0x400000 to image-origin   \ where target image will run
  image-origin to std-exeload \ needed but needs checked in imageman why so
! gui      to exetype        \ default is a gui
  true value image-save      \ we want to save the image
  
--- 51,55 ----
  0x400000 to image-origin   \ where target image will run
  image-origin to std-exeload \ needed but needs checked in imageman why so
! cui      to exetype        \ dos console
  true value image-save      \ we want to save the image
  

Index: gkernel.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gkernel.f,v
retrieving revision 1.37
retrieving revision 1.38
diff -C2 -d -r1.37 -r1.38
*** gkernel.f	8 May 2007 08:02:27 -0000	1.37
--- gkernel.f	13 May 2007 21:39:27 -0000	1.38
***************
*** 426,430 ****
                  next;
  
! code sw@        ( a1 -- w1 )    \ fetch the sign extended word (16bit) w1 from address a1
       1 1 in/out
                  movsx   eax, word [eax]
--- 426,430 ----
                  next;
  
! code sw@        ( a1 -- w1 )    \ sign fetch the word w1
       1 1 in/out
                  movsx   eax, word [eax]
***************
*** 2204,2208 ****
                  mov    ' dp >body , ecx \ restore dp
                  ret    4              \ discard old value
!                 next;                \ return
  
  : >application  ( -- ) adp >dp exit ; \ select app dict, save prev dict
--- 2204,2208 ----
                  mov    ' dp >body , ecx \ restore dp
                  ret    4              \ discard old value
!                 c;
  
  : >application  ( -- ) adp >dp exit ; \ select app dict, save prev dict
***************
*** 2427,2431 ****
  : xt-inline, ( xt -- )                        \ inline the xt
              dup >name n>ofa                   \ get the length
!             w@ dup xt-inline-max u> not if    \ if short enough
                copy-code                       \ copy the code
              else
--- 2427,2431 ----
  : xt-inline, ( xt -- )                        \ inline the xt
              dup >name n>ofa                   \ get the length
!             w@ dup xt-inline-max u> not if    \ if <= inline max
                copy-code                       \ copy the code
              else
***************
*** 2476,2486 ****
                  ;
  
! : (in/out@) ( nfa -- in out )        \ get the ste values
              n>ste dup sc@ swap 1+ sc@ ;
  
! : in/out@   ( -- in out )            \ get the ste values
              last @ (in/out@) ;
  
! : in/out   ( in out -- )            \ set the ste values
              2dup ste-o ! ste-i !      \ set calc values
              last @ n>ste
--- 2476,2486 ----
                  ;
  
! : (in/out@) ( nfa -- in out )         \ get the ste values
              n>ste dup sc@ swap 1+ sc@ ;
  
! : in/out@   ( -- in out )             \ get the ste values
              last @ (in/out@) ;
  
! : in/out    ( in out -- )             \ set the ste values
              2dup ste-o ! ste-i !      \ set calc values
              last @ n>ste
***************
*** 3113,3119 ****
--- 3113,3130 ----
  defer ?cr
  
+ 1 proc GetStdHandle
+ 
+ -1 value stdout
+ -1 value stderr
+ -1 value stdin
+ 
  : x_init-console ( -- f1 )      \ initialize the forth console window
                                  \ and the keyboard i/o
                                  \ f1=false if already inited
+                                 
+                 STD_OUTPUT_HANDLE call GetStdHandle to stdout
+                 STD_INPUT_HANDLE  call GetStdHandle to stdin
+                 STD_ERROR_HANDLE  call GetStdHandle to stderr
+ 
                  _conhndl >r
  
***************
*** 3185,3208 ****
  2 proc c_gotoxy
  0 proc c_getxy
- 4 proc c_mark
  0 proc c_getcolrow
- 0 proc c_sizestate
- 1 proc k_fpushkey
  
- : x_sizestate   ( -- state )     call c_sizestate ;
  : x_gotoxy      ( x y -- )       swap call c_gotoxy drop ;
  : x_getxy       ( -- x y )       call c_getxy word-split ;
  : x_getcolrow   ( -- cols rows ) call c_getcolrow word-split ;
- : x_markconsole ( startline startcol endline endcol -- )
-                 call c_mark drop ;
  
- defer pushkey      ' drop    is pushkey
- defer "pushkeys    ' 2drop   is "pushkeys
- defer shiftmask    ' k_noop1 is shiftmask
- defer sizestate    ' x_sizestate    is sizestate
  defer gotoxy       ' x_gotoxy       is gotoxy
  defer getxy        ' x_getxy        is getxy
  defer getcolrow    ' x_getcolrow    is getcolrow
- defer markconsole  ' x_markconsole  is markconsole
  defer console      ' noop    is console
  defer cursorinview ' noop    is cursorinview
--- 3196,3208 ----
***************
*** 3210,3215 ****
  defer fg@          ' k_noop1 is fg@
  defer bg@          ' k_noop1 is bg@
- defer charwh       ' k_noop2 is charwh
- defer setcharwh    ' 2drop   is setcharwh
  defer setcolrow    ' 2drop   is setcolrow
  defer set-cursor   ' drop    is set-cursor
--- 3210,3213 ----
***************
*** 3219,3223 ****
  defer getmaxcolrow ' k_noop2 is getmaxcolrow
  defer setmaxcolrow ' 2drop   is setmaxcolrow
- defer &the-screen  ' k_noop1 is &the-screen
  
  : x_col         ( n -- )     getcolrow drop 1- min getxy drop - spaces ;
--- 3217,3220 ----
***************
*** 3228,3251 ****
  \ -------------------- deferred i/o  part ii --------------------------------
  
- -1 value stdout
- -1 value stderr
- -1 value stdin
- 
- 1 proc GetStdHandle
- 0 proc AllocConsole
- 0 proc FreeConsole
- : _dosconsole   ( fl -- )                        \ true = open, false = close
-                 if call AllocConsole drop
-                   STD_OUTPUT_HANDLE call GetStdHandle to stdout
-                   STD_INPUT_HANDLE  call GetStdHandle to stdin
-                   STD_ERROR_HANDLE  call GetStdHandle to stderr
-                 else call FreeConsole drop
-                 then ;
- 
  defer load-forth   ' noop is load-forth           \ things to do at start
  defer unload-forth ' noop is unload-forth         \ things to do at end
  
- 0 proc IsWindow
- 1 proc DestroyWindow
  1 proc ExitProcess
  : k_bye         ( -- )          \ exit forth
--- 3225,3231 ----
***************
*** 5521,5525 ****
  
  |: locals-init  ( -- )                                  \ init, check if locals validly used
!    		?csp                                    \ make sure not used inside control structures
                  localstk throw_localstwice ?throw       \ and not used before in the definition
                  0 to localsi
--- 5501,5505 ----
  
  |: locals-init  ( -- )                                  \ init, check if locals validly used
!    		        ?csp                                    \ make sure not used inside control structures
                  localstk throw_localstwice ?throw       \ and not used before in the definition
                  0 to localsi
***************
*** 5800,5806 ****
                  reset-stacks
  
!                 ['] boot catch                         \ do boot
!                 if bye then                            \ fatal error, exit
!                 &except @ 0=
                  if cmdline ['] evaluate catch
                    ?dup if console message then
--- 5780,5784 ----
                  reset-stacks
  
!                 ['] boot catch 0=                      \ do boot (which may never return)
                  if cmdline ['] evaluate catch
                    ?dup if console message then

[Win32forth-cvs] win32forth-stc gkernel.exe,1.43,1.44

[Alex M. <ale...@us...>]

Update of /cvsroot/win32forth/win32forth-stc
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv7404

Modified Files:
	gkernel.exe 
Log Message:
arm: remove caps-xxx functions to ansfile
optimise case statements
reorder kernel source (minor)

Index: gkernel.exe
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/gkernel.exe,v
retrieving revision 1.43
retrieving revision 1.44
diff -C2 -d -r1.43 -r1.44
Binary files /tmp/cvsVwiwV6 and /tmp/cvsAE5mg6 differ

[Win32forth-cvs] win32forth-stc/src ANSFILE.F, 1.2, 1.3 extend.f, 1.19, 1.20 optinline.f, 1.7, 1.8 optliterals.f, 1.14, 1.15 primutil.f, 1.32, 1.33

[Alex M. <ale...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv7404/src

Modified Files:
	ANSFILE.F extend.f optinline.f optliterals.f primutil.f 
Log Message:
arm: remove caps-xxx functions to ansfile
optimise case statements
reorder kernel source (minor)

Index: primutil.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/primutil.f,v
retrieving revision 1.32
retrieving revision 1.33
diff -C2 -d -r1.32 -r1.33
*** primutil.f	12 May 2007 10:49:12 -0000	1.32
--- primutil.f	13 May 2007 21:39:26 -0000	1.33
***************
*** 410,459 ****
  
  \ ------------------------------------------------------------------------
- \       Some case insensitive version of search and compare
- \ ------------------------------------------------------------------------
- 
- \ needed by ansfile.f
- 
- \ enhanced caps-search for source string > 255 bytes
- \ search for t-adr,t-len within string s-adr,s-len. f1=true if string was found
- : CAPS-SEARCH  ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 flag )
- \ *G Search the string specified by c-addr1 u1 for the string specified by c-addr2 u2,
- \ ** using a case-insensitive search. \n
- \ ** If flag is true, a match was found at c-addr3 with u3 characters remaining. \n
- \ ** If flag is false there was no match and c-addr3 is c-addr1 and u3 is u1.
-         { s-adr s-len t-adr t-len \ t-buf t-str -- adr len flag }
-         MAXSTRING localalloc: t-str
-         s-len cell+ ALLOCATE 0=
-         IF      to t-buf                    \ make a buffer big enough for s-adr
-                 t-adr t-len t-str place
-                 t-str count upper
-                 s-adr t-buf s-len move
-                 t-buf s-len upper
-                 t-buf s-len t-str count search
-                 IF      nip                     \ discard found address
-                         s-len swap -            \ offset where string was found
-                         s-adr s-len rot /string
-                                       \ location of found string in original buf
-                         TRUE
-                 ELSE    2drop
-                         s-adr s-len FALSE
-                 THEN
-                 t-buf FREE drop
-         ELSE    s-adr s-len FALSE             \ failed, couldn't allocate buffer
-         THEN    ;
- 
- \ COMPARE compares two strings, ignoring case. The return value is:
- \
- \        0 = string1 = string2
- \       -1 = string1 < string2
- \        1 = string1 > string2
- : CAPS-COMPARE  { sa1 sn1 sa2 sn2 \ st1 st2 -- f1 }
-                 MAXSTRING LocalAlloc: st1
-                 MAXSTRING LocalAlloc: st2
-                 sa1 sn1 st1 place  st1 count upper
-                 sa2 sn2 st2 place  st2 count upper
-                 st1 count st2 count compare ;
- 
- \ ------------------------------------------------------------------------
  \       Locking for Windows
  \ ------------------------------------------------------------------------
--- 410,413 ----

Index: ANSFILE.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/ANSFILE.F,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** ANSFILE.F	25 Sep 2006 11:57:52 -0000	1.2
--- ANSFILE.F	13 May 2007 21:39:26 -0000	1.3
***************
*** 73,76 ****
--- 73,121 ----
  2  newuser wMilliseconds
  
+ \ ------------------------------------------------------------------------
+ \       Some case insensitive version of search and compare
+ \ ------------------------------------------------------------------------
+ 
+ \ enhanced caps-search for source string > 255 bytes
+ \ search for t-adr,t-len within string s-adr,s-len. f1=true if string was found
+ : CAPS-SEARCH  ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 flag )
+ \ *G Search the string specified by c-addr1 u1 for the string specified by c-addr2 u2,
+ \ ** using a case-insensitive search. \n
+ \ ** If flag is true, a match was found at c-addr3 with u3 characters remaining. \n
+ \ ** If flag is false there was no match and c-addr3 is c-addr1 and u3 is u1.
+         { s-adr s-len t-adr t-len \ t-buf t-str -- adr len flag }
+         MAXSTRING localalloc: t-str
+         s-len cell+ ALLOCATE 0=
+         IF      to t-buf                    \ make a buffer big enough for s-adr
+                 t-adr t-len t-str place
+                 t-str count upper
+                 s-adr t-buf s-len move
+                 t-buf s-len upper
+                 t-buf s-len t-str count search
+                 IF      nip                     \ discard found address
+                         s-len swap -            \ offset where string was found
+                         s-adr s-len rot /string
+                                       \ location of found string in original buf
+                         TRUE
+                 ELSE    2drop
+                         s-adr s-len FALSE
+                 THEN
+                 t-buf FREE drop
+         ELSE    s-adr s-len FALSE             \ failed, couldn't allocate buffer
+         THEN    ;
+ 
+ \ COMPARE compares two strings, ignoring case. The return value is:
+ \
+ \        0 = string1 = string2
+ \       -1 = string1 < string2
+ \        1 = string1 > string2
+ : CAPS-COMPARE  { sa1 sn1 sa2 sn2 \ st1 st2 -- f1 }
+                 MAXSTRING LocalAlloc: st1
+                 MAXSTRING LocalAlloc: st2
+                 sa1 sn1 st1 place  st1 count upper
+                 sa2 sn2 st2 place  st2 count upper
+                 st1 count st2 count compare ;
+ 
+ 
  : get-fspace { zroot \ clus freclus b/sec s/clus -- as bs cs ds }
  \ *G Get a drive's free space, cluster and sector information

Index: extend.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/extend.f,v
retrieving revision 1.19
retrieving revision 1.20
diff -C2 -d -r1.19 -r1.20
*** extend.f	9 May 2007 12:14:08 -0000	1.19
--- extend.f	13 May 2007 21:39:26 -0000	1.20
***************
*** 6,9 ****
--- 6,10 ----
  sys-fload src\optinline     \ inline optimiser
      fload src\primutil.f
+ sys-fload src\struct.f      \ forth 200x structs
  sys-fload src\module.f      \ scoping support for modules
  sys-fload src\interpif.f    \ interpretive conditionals

Index: optliterals.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/optliterals.f,v
retrieving revision 1.14
retrieving revision 1.15
diff -C2 -d -r1.14 -r1.15
*** optliterals.f	22 Mar 2007 02:13:56 -0000	1.14
--- optliterals.f	13 May 2007 21:39:26 -0000	1.15
***************
*** 126,131 ****
  
  : add-v,tos      { var }     macro[ add   var , eax              ]macro ;
! : add-v,#n       { var n } n if   macro[ add   var , dword # n        ]macro  then ;
! : add-tos,#n     ( n )     dup if >r macro[ add   r@ tos,#n              ]macro r>drop else drop then ;
  : sub-tos,#n     ( n )    >r macro[ sub   r@ tos,#n              ]macro r>drop ;
  : shl-tos,#n     ( n )    >r macro[ shl   r@ tos,#n              ]macro r>drop ;
--- 126,131 ----
  
  : add-v,tos      { var }     macro[ add   var , eax              ]macro ;
! : add-v,#n       { var n } n if macro[ add   var , dword # n     ]macro then ;
! : add-tos,#n     ( n ) dup if >r macro[ add   r@ tos,#n          ]macro r>drop else drop then ;
  : sub-tos,#n     ( n )    >r macro[ sub   r@ tos,#n              ]macro r>drop ;
  : shl-tos,#n     ( n )    >r macro[ shl   r@ tos,#n              ]macro r>drop ;
***************
*** 135,138 ****
--- 135,140 ----
  : or-tos,#n      ( n )    >r macro[ or    r@ tos,#n              ]macro r>drop ;
  : xor-tos,#n     ( n )    >r macro[ xor   r@ tos,#n              ]macro r>drop ;
+ : cmp-tos,#n     ( n )    >r macro[ cmp   r@ tos,#n              ]macro r>drop ;
+ : jne-mark2      ( -- )      macro[ jne   0                      ]macro >mark 2 ;
  : not-tos        ( -- )      macro[ not   eax                    ]macro ;
  
***************
*** 320,322 ****
--- 322,335 ----
  ' optc!    compiles-for c!
  
+ : optof    ( xt -- ) \ optimise the constant case "n of ... endof"
+            drop 1+ >r
+            lits>0? if
+              lits spop sync-code cmp-tos,#n jne-mark2
+            else
+              postpone over
+              postpone =
+              postpone if
+            then 
+            postpone drop r> ;
+ 
  previous definitions

Index: optinline.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/optinline.f,v
retrieving revision 1.7
retrieving revision 1.8
diff -C2 -d -r1.7 -r1.8
*** optinline.f	11 Apr 2007 20:22:42 -0000	1.7
--- optinline.f	13 May 2007 21:39:26 -0000	1.8
***************
*** 36,40 ****
  
  vocabulary optimise
! 
  also optimise definitions
  
--- 36,40 ----
  
  vocabulary optimise
!                                                                  
  also optimise definitions
  
***************
*** 49,55 ****
--- 49,63 ----
  ' (comp-cons) compiles-for cell
  ' (comp-cons) compiles-for -cell
+ ' (comp-val)  compiles-for stdin
+ ' (comp-val)  compiles-for stdout
+ ' (comp-val)  compiles-for stderr
  
  \ set the words we will inline
  
+ ' xt-inline, compiles-for @
+ ' xt-inline, compiles-for c@
+ ' xt-inline, compiles-for sc@
+ ' xt-inline, compiles-for w@
+ ' xt-inline, compiles-for sw@
  ' xt-inline, compiles-for cells
  ' xt-inline, compiles-for cells+
***************
*** 75,87 ****
  ' xt-inline, compiles-for 2swap
  ' xt-inline, compiles-for 2over
- ' xt-inline, compiles-for @
  ' xt-inline, compiles-for !
  ' xt-inline, compiles-for +!
- ' xt-inline, compiles-for c@
- ' xt-inline, compiles-for sc@
  ' xt-inline, compiles-for c!
  ' xt-inline, compiles-for c+!
- ' xt-inline, compiles-for w@
- ' xt-inline, compiles-for sw@
  ' xt-inline, compiles-for w!
  ' xt-inline, compiles-for w+!
--- 83,90 ----

[Win32forth-cvs] win32forth-stc/src/console CONSOLE.F,1.1,1.2

[Alex M. <ale...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src/console
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv7404/src/console

Modified Files:
	CONSOLE.F 
Log Message:
arm: remove caps-xxx functions to ansfile
optimise case statements
reorder kernel source (minor)

Index: CONSOLE.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/console/CONSOLE.F,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** CONSOLE.F	23 Sep 2006 10:18:34 -0000	1.1
--- CONSOLE.F	13 May 2007 21:39:26 -0000	1.2
***************
*** 10,13 ****
--- 10,33 ----
  cr .( Loading... Console I/O Part 1)
  
+ 
+ library w32fconsole.dll
+ 1 proc k_fpushkey
+ 0 proc c_sizestate
+ 4 proc c_mark
+ 
+ : x_sizestate   ( -- state )     call c_sizestate ;
+ 
+ : x_markconsole ( startline startcol endline endcol -- )
+                 call c_mark drop ;
+ 
+ defer pushkey      ' drop    is pushkey
+ defer "pushkeys    ' 2drop   is "pushkeys
+ defer shiftmask    ' k_noop1 is shiftmask
+ defer sizestate    ' x_sizestate    is sizestate
+ defer markconsole  ' x_markconsole  is markconsole
+ defer &the-screen  ' k_noop1 is &the-screen
+ defer charwh       ' k_noop2 is charwh
+ defer setcharwh    ' 2drop   is setcharwh
+ 
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  \       get console window handle

[Win32forth-cvs] win32forth/src Extend.f, 1.13, 1.14 Keysave.f, 1.4, 1.5 editor_io.f, 1.3, 1.4

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/src
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv27480/src

Modified Files:
	Extend.f Keysave.f editor_io.f 
Log Message:
- Removed the Forth-Instance-Counting from then Editor-IO.

Index: editor_io.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/editor_io.f,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** editor_io.f	12 May 2007 07:51:19 -0000	1.3
--- editor_io.f	13 May 2007 07:52:26 -0000	1.4
***************
*** 7,22 ****
  anew -Editor_io.F
  
! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
! \   primitive utilities to support view, browse and edit of words and files
! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  
  INTERNAL
  EXTERNAL
  
! in-application
  
  0 value ed-hndl
  0 value ed-ptr
- FALSE value second-forth?               \ am I the second or more copy of forth to load
  
  INTERNAL
--- 7,21 ----
  anew -Editor_io.F
  
! \ ----------------------------------------------------------------------------------------
! \ Communication beetween the Editor (e.g. the Win32ForthIDE) and the Console window.
! \ ----------------------------------------------------------------------------------------
  
  INTERNAL
  EXTERNAL
  
! IN-APPLICATION
  
  0 value ed-hndl
  0 value ed-ptr
  
  INTERNAL
***************
*** 30,34 ****
  0
  cell      ed-field+ ed-window           \ the handle of the MainWindow of the Editor
- cell      ed-field+ ed-forth-count      \ count of forths running
  cell      ed-field+ ed-response         \ response from the editor
  cell      ed-field+ ed-line             \ line number to edit
--- 29,32 ----
***************
*** 44,64 ****
  4096 + 4096 / 4096 * constant ed-size   \ multiples of 4k bytes
  
! \ Messages To Forth FROM the Editor
! newproc WM_SETBP
! newproc WM_STEPBP
! newproc WM_NESTBP
! newproc WM_UNESTBP
! newproc WM_CONTBP
! newproc WM_JUMPBP
! newproc WM_BEGNBP
! newproc WM_HEREBP
! newproc WM_RSTKBP
! newproc WM_DONEBP
! newproc WM_INQUIRE
! 
! \ tell Forth to get text from the clipboard and compile it
! newproc WM_PASTELOAD
  
! \ Messages TO the Editor FROM the Editor
  newproc ED_OPEN_EDIT
  newproc ED_OPEN_BROWSE
--- 42,63 ----
  4096 + 4096 / 4096 * constant ed-size   \ multiples of 4k bytes
  
! \ Messages FROM the Editor TO Forth for Console window
! newproc WM_KEY          \ give Forth a key
! newproc WM_SETBP        \ tell the forth console to set a breakpoint on a word (only used in WinEd)
! newproc WM_STEPBP       \ single step
! newproc WM_NESTBP       \ nest into this definition
! newproc WM_UNESTBP      \ unnest to definition above
! newproc WM_CONTBP       \ continuous step till key
! newproc WM_JUMPBP       \ Jump over next Word
! newproc WM_BEGNBP       \ proceed to def again
! newproc WM_HEREBP       \ proceed to this point again
! newproc WM_RSTKBP       \ show Return stack
! newproc WM_DONEBP       \ done, run the program
! newproc WM_INQUIRE      \ what it is good for? (only used in WinEd)
! newproc WM_PASTELOAD    \ tell Forth to get text from the clipboard and compile it (only used in WinEd)
  
! \ Messages FROM the Forth for Console window TO the Editor
! newproc ED_ALIVE        \ notify editor that the Forth console window is ready to accept characters
! newproc ED_SHUTDOWN     \ notify editor that the Forth console window was closed
  newproc ED_OPEN_EDIT
  newproc ED_OPEN_BROWSE
***************
*** 67,86 ****
  newproc ED_STACK
  newproc ED_DEBUG
- newproc ED_NOTINBP
- 
- \ Messages FROM Editor TO Forth for Console
- newproc WM_KEY                                  \ give Forth a key
- 
- \ Messages TO Editor FROM Forth for Console
- newproc ED_READY                                \ notify editor Forth is alive (not used)
- newproc ED_ALIVE                                \ notify editor Forth is ready to accept characters
- newproc ED_SHUTDOWN                             \ tell editor to shut down the Forth console window
  
  : editor-present? ( -- f1 )
                  ed-ptr
                  -IF  drop ed-window @ call IsWindow 0<>
                  THEN ;
  
! : editor-message ( lParam wParam -- )           \ send a Message to the Editor
                  editor-present?
                  if   WM_WIN32FORTH ed-window @ Call SendMessage drop
--- 66,78 ----
  newproc ED_STACK
  newproc ED_DEBUG
  
  : editor-present? ( -- f1 )
+ \ *G check if the Editor (e.g. the Win32ForthIDE) is present.
                  ed-ptr
                  -IF  drop ed-window @ call IsWindow 0<>
                  THEN ;
  
! : editor-message ( lParam wParam -- )
! \ *G Send a Message to the Editor.
                  editor-present?
                  if   WM_WIN32FORTH ed-window @ Call SendMessage drop
***************
*** 93,102 ****
  INTERNAL
  
- : init-shared-forth ( -- )
-                 1 ed-forth-count +! ;           \ bump count of Forths currently running
- 
- ' init-shared-forth is init-shared-type
- 
  : init-shared-memory ( -- )
                  0 to ed-ptr                     \ initialize to not present
                  0 to ed-hndl
--- 85,90 ----
  INTERNAL
  
  : init-shared-memory ( -- )
+ \ *G Init the shared memory for commuication.
                  0 to ed-ptr                     \ initialize to not present
                  0 to ed-hndl
***************
*** 108,127 ****
                  THEN ;
  
- init-shared-memory                              \ init it now per smb March 6th, 1996
- 
- initialization-chain chain-add init-shared-memory
- 
- : uninit-shared-forth ( -- )
-                 second-forth? 0=                \ and I'm the editors copy of Forth
-                 IF   0 ed-result !              \ then tell console to close the console
-                      0 ED_SHUTDOWN editor-message
-                 THEN
-                 -1 ed-forth-count +! ;          \ bump count of Forths currently running
- 
- ' uninit-shared-forth is uninit-shared-type
- 
- EXTERNAL
- 
  : uninit-shared-memory ( -- )
                  ed-ptr  0<>                     \ if shared memory was inited
                  ed-hndl 0<> and
--- 96,101 ----
                  THEN ;
  
  : uninit-shared-memory ( -- )
+ \ *G Deinit the shared memory for commuication.
                  ed-ptr  0<>                     \ if shared memory was inited
                  ed-hndl 0<> and
***************
*** 132,138 ****
                  THEN ;
  
! unload-chain chain-add-before uninit-shared-memory
  
! INTERNAL
  
  LOADED? debug.f [IF]
--- 106,115 ----
                  THEN ;
  
! initialization-chain  chain-add         init-shared-memory
! unload-chain          chain-add-before  uninit-shared-memory
  
! \ ----------------------------------------------------------------------------------------
! \ Debug support
! \ ----------------------------------------------------------------------------------------
  
  LOADED? debug.f [IF]
***************
*** 140,144 ****
  IN-SYSTEM
  
! : do-inquire    ( -- )  \ respond to an inquiry from the editor on a data item
                  [ also bug ]
                  ed-result off
--- 117,122 ----
  IN-SYSTEM
  
! : do-inquire    ( -- )
! \ *G Respond to an inquiry from the editor on a data item
                  [ also bug ]
                  ed-result off
***************
*** 163,222 ****
  
  : db-pushkey    ( c1 -- )
                  in-breakpoint?
!                 if      pushkey
!                 else    drop
!                         0 ED_NOTINBP editor-message
!                 then    ;
! 
! : (win-set-break) { wParam lParam \ bp$ -- wParam lParam }
!                 wParam lParam
  
! \ This forth instance counting doesn't work well, and I don't understand
! \ what it's realy good for. So I removed the SECOND-FORTH? check to
! \ fix this nasty Win32ForthIDE F12 bug. (Samstag, Mai 12 2007 dbu)
! \               second-forth? ?EXIT             \ ignore messages if second copy
  
                  MAXSTRING LocalAlloc: bp$
!                 ed-ptr   0= ?EXIT               \ exit if no shared memory
!                 sys-free 0= ?EXIT               \ exit if no heads are present
!                 over WM_SETBP =                 \ if we are being told to set a breakpoint
!                 if      context @ >r            \ save context vocabulary
!                         ed-name count bl skip 2dup bl scan ?dup
!                         if      2dup 2>r nip - bp$ place
                                  bp$ anyfind
!                                 if      execute
!                                         2r> bl skip bp$ place
!                                         bp$ anyfind
!                                 else    2r> 2drop
!                                         FALSE
!                                 then
!                         else    ed-name anyfind
                          then
!                         if      unbug                   \ remove any previous BP
!                                 remote-debug            \ set the breakpoint
!                                 dup ed-response !       \ non zero=success
!                                 if      with-source     \ enable source viewing
!                                 then
!                         else    drop                    \ couldn't find it
!                                 0 ed-response !         \ 0=failure
                          then
!                         r> context !            \ restore the context vocabulary
!                         EXIT
!                 then    over
                  CASE
                          \ --- Debugger support
!                         WM_STEPBP       OF      0x0D           db-pushkey       ENDOF
!                         WM_NESTBP       OF      'N'            db-pushkey       ENDOF
!                         WM_UNESTBP      OF      'U'            db-pushkey       ENDOF
!                         WM_CONTBP       OF      'C'            db-pushkey       ENDOF
!                         WM_JUMPBP       OF      'J'            db-pushkey       ENDOF
!                         WM_BEGNBP       OF      'P'            db-pushkey       ENDOF
!                         WM_HEREBP       OF      'P' +k_control db-pushkey       ENDOF
!                         WM_RSTKBP       OF      'R'            db-pushkey       ENDOF
!                         WM_DONEBP       OF      'D'            db-pushkey       ENDOF
!                         WM_INQUIRE      OF      do-inquire                      ENDOF
  
                          \ --- Support for console interface
!                         WM_KEY          OF      dup pushkey                     ENDOF
                  ENDCASE ;
  
--- 141,200 ----
  
  : db-pushkey    ( c1 -- )
+ \ *G Push a key to the console window during debuging.
                  in-breakpoint?
!                 if   pushkey
!                 else drop beep
!                 then ;
  
! : do-set-breakpoint { \ bp$ -- }
! \ *G Set breakpoint to a word.
  
                  MAXSTRING LocalAlloc: bp$
! 
!                 context @ >r            \ save context vocabulary
!                 ed-name count bl skip 2dup bl scan ?dup
!                 if      2dup 2>r nip - bp$ place
!                         bp$ anyfind
!                         if      execute
!                                 2r> bl skip bp$ place
                                  bp$ anyfind
!                         else    2r> 2drop
!                                 FALSE
                          then
!                 else    ed-name anyfind
!                 then
!                 if      unbug                   \ remove any previous BP
!                         remote-debug            \ set the breakpoint
!                         dup ed-response !       \ non zero=success
!                         if   with-source        \ enable source viewing
                          then
!                 else    drop                    \ couldn't find it
!                         0 ed-response !         \ 0=failure
!                 then
!                 r> context !            \ restore the context vocabulary
!                 ;
! 
! : (win-set-breakpoint) { wParam lParam \ bp$ -- wParam lParam }
!                 wParam lParam
! 
!                 ed-ptr 0= ?EXIT               \ exit if no shared memory
! 
!                 over
                  CASE
                          \ --- Debugger support
!                         WM_SETBP    OF  do-set-breakpoint           ENDOF
!                         WM_STEPBP   OF  0x0D           db-pushkey   ENDOF
!                         WM_NESTBP   OF  'N'            db-pushkey   ENDOF
!                         WM_UNESTBP  OF  'U'            db-pushkey   ENDOF
!                         WM_CONTBP   OF  'C'            db-pushkey   ENDOF
!                         WM_JUMPBP   OF  'J'            db-pushkey   ENDOF
!                         WM_BEGNBP   OF  'P'            db-pushkey   ENDOF
!                         WM_HEREBP   OF  'P' +k_control db-pushkey   ENDOF
!                         WM_RSTKBP   OF  'R'            db-pushkey   ENDOF
!                         WM_DONEBP   OF  'D'            db-pushkey   ENDOF
!                         WM_INQUIRE  OF  do-inquire                  ENDOF
  
                          \ --- Support for console interface
!                         WM_KEY      OF  dup pushkey                 ENDOF
                  ENDCASE ;
  
***************
*** 224,230 ****
  
  : win-set-breakpoint ( -- )
!                     TURNKEYED? ?EXIT
! \IN-SYSTEM-OK       (win-set-break)
!                     ;
  
  forth-msg-chain chain-add win-set-breakpoint
--- 202,208 ----
  
  : win-set-breakpoint ( -- )
! \ *G Handle debug-messages from the Editor
!                     TURNKEYED? ?EXIT        \ exit if no heads are present
! \IN-SYSTEM-OK       (win-set-breakpoint) ;
  
  forth-msg-chain chain-add win-set-breakpoint
***************
*** 232,234 ****
--- 210,238 ----
  [ENDIF]
  
+ \ ----------------------------------------------------------------------------------------
+ \ Copy text from the clipboard to the console window and compile it.
+ \ ----------------------------------------------------------------------------------------
+ 
+ EXTERNAL
+ 
+ defer paste-load ' noop is paste-load
+ 
+ INTERNAL
+ 
+ IN-SYSTEM
+ 
+ : (win-paste-load)  ( wParam lParam -- wParam lParam )
+                     ed-ptr   0= ?EXIT       \ exit if no shared memory
+                     over WM_PASTELOAD =
+                     if   paste-load         \ tell Forth to PASTE and LOAD
+                     then ;
+ 
+ IN-APPLICATION
+ 
+ : win-paste-load    ( wParam lParam -- wParam lParam )
+                     TURNKEYED?  ?EXIT       \ exit if no heads are present
+ \IN-SYSTEM-OK       (win-paste-load) ;
+ 
+ forth-msg-chain chain-add win-paste-load
+ 
  MODULE

Index: Keysave.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Keysave.f,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** Keysave.f	29 Apr 2006 19:47:17 -0000	1.4
--- Keysave.f	13 May 2007 07:52:26 -0000	1.5
***************
*** 29,33 ****
  
  :M GetLogName:  ( -- a1 n1 )
!                 logfilename count 
                  ;M
  
--- 29,33 ----
  
  :M GetLogName:  ( -- a1 n1 )
!                 logfilename count
                  ;M
  
***************
*** 118,122 ****
                  logfilebuf place
                  logfilebuf to logfilename
!                 logfilename count r/w create-file 
                  dup s" Error Creating LOG file" ?MessageBox
                  if      drop
--- 118,122 ----
                  logfilebuf place
                  logfilebuf to logfilename
!                 logfilename count r/w create-file
                  dup s" Error Creating LOG file" ?MessageBox
                  if      drop
***************
*** 147,151 ****
                  2dup r/o open-file
                  dup s" Key LOG file doesn't exist!" ?MessageBox
!                 if      3drop 
                  else    to playhndl
                          logfilebuf place
--- 147,151 ----
                  2dup r/o open-file
                  dup s" Key LOG file doesn't exist!" ?MessageBox
!                 if      3drop
                  else    to playhndl
                          logfilebuf place
***************
*** 327,331 ****
  
  : new-log       ( -- )
!                 NewLog: key-log-file 
                  logging-on ;
  
--- 327,331 ----
  
  : new-log       ( -- )
!                 NewLog: key-log-file
                  logging-on ;
  
***************
*** 362,366 ****
                  PlayLog: key-log-file
                  ['] play1key  is auto_key
!                 ['] play1key? is auto_key? 
                  play1key ;
  
--- 362,366 ----
                  PlayLog: key-log-file
                  ['] play1key  is auto_key
!                 ['] play1key? is auto_key?
                  play1key ;
  
***************
*** 373,377 ****
  
  : replay-macro  ( -- )
!                 Playing: key-log-file 0=        \ replay only if not already 
                                                  \ playing some keys
                  if      GetLogName: key-log-file  "playkeys
--- 373,377 ----
  
  : replay-macro  ( -- )
!                 Playing: key-log-file 0=        \ replay only if not already
                                                  \ playing some keys
                  if      GetLogName: key-log-file  "playkeys
***************
*** 419,423 ****
                          else    drop 0
                          then    to #repeating-macro
!                 then    
                  #repeating-macro
                  if      GetLogName: key-log-file PlayLog: key-log-file
--- 419,423 ----
                          else    drop 0
                          then    to #repeating-macro
!                 then
                  #repeating-macro
                  if      GetLogName: key-log-file PlayLog: key-log-file
***************
*** 472,484 ****
                  then    ;
  
! defer paste-load
! : _paste-load    ( -- )
!  ( _conHndl) null call OpenClipboard 0=
          if   beep
          else CF_TEXT call GetClipboardData ?dup
!       if   dup to paste-hdl
                    call GlobalLock dup to paste-ptr       \ lock memory
!            0= if call CloseClipboard drop exit then
!              paste-ptr zcount nip dup to paste-len \ get len
                    if   0 to paste-off
                         0 to play0cnt
--- 472,484 ----
                  then    ;
  
! : _paste-load   ( -- )
! \ *G Copy text from the clipboard to the console window and compile it.
!         conhndl call OpenClipboard 0=
          if   beep
          else CF_TEXT call GetClipboardData ?dup
!              if   dup to paste-hdl
                    call GlobalLock dup to paste-ptr       \ lock memory
!                   0= if call CloseClipboard drop exit then
!                   paste-ptr zcount nip dup to paste-len \ get len
                    if   0 to paste-off
                         0 to play0cnt
***************
*** 498,517 ****
               then
          then ;
- ' _paste-load is paste-load
- 
- : win-paste-load ( wParam lParam -- wParam lParam )
-                 ed-ptr   0= ?EXIT               \ exit if no shared memory
-                 sys-free 0= ?EXIT               \ exit if no heads are present
-                 over WM_PASTELOAD =             \ tell Forth to PASTE and LOAD
-                 if      paste-load
-                 then    ;
  
! forth-msg-chain chain-add win-paste-load
  
! : copy-console  { \ gblhndl gblptr b/l l/s len -- } \ Copy text to Windows clipboard
!                 marked? 0=
!                 if      beep EXIT
!                 then
!                 conhndl call OpenClipboard 0=
          if      beep
          else    getmaxcolrow to l/s                     \ lines per screen (really total)
--- 498,510 ----
               then
          then ;
  
! ' _paste-load is paste-load
  
! : copy-console  { \ gblhndl gblptr b/l l/s len -- }
! \ *G Copy text to Windows clipboard
!         marked? 0=
!         if      beep EXIT
!         then
!         conhndl call OpenClipboard 0=
          if      beep
          else    getmaxcolrow to l/s                     \ lines per screen (really total)
***************
*** 566,569 ****
--- 559,563 ----
  
  : cut-console   ( -- )
+ \ *G Cut the complete text from the console window to the clipboard.
                  marked?
                  if      beep
***************
*** 575,577 ****
  MODULE          \ finish up the module
  
- 

[Win32forth-cvs] win32forth/src/console LINEEDIT.F,1.8,1.9

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/src/console
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv27480/src/console

Modified Files:
	LINEEDIT.F 
Log Message:
- Removed the Forth-Instance-Counting from then Editor-IO.

Index: LINEEDIT.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/console/LINEEDIT.F,v
retrieving revision 1.8
retrieving revision 1.9
diff -C2 -d -r1.8 -r1.9
*** LINEEDIT.F	28 Sep 2006 10:16:48 -0000	1.8
--- LINEEDIT.F	13 May 2007 07:52:26 -0000	1.9
***************
*** 439,443 ****
  
  : __laccept     ( a1 n1 -- n2 )
-                 0 ED_READY editor-message           \ notify editor we are ready
                  ['] accept-lup   is _le-up
                  ['] accept-ldown is _le-down
--- 439,442 ----

[Win32forth-cvs] win32forth WinEdColorize.f, 1.2, 1.3 fkernel.exe, 1.40, 1.41 setup.exe, 1.26, 1.27

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv27480

Modified Files:
	WinEdColorize.f fkernel.exe setup.exe 
Log Message:
- Removed the Forth-Instance-Counting from then Editor-IO.

Index: setup.exe
===================================================================
RCS file: /cvsroot/win32forth/win32forth/setup.exe,v
retrieving revision 1.26
retrieving revision 1.27
diff -C2 -d -r1.26 -r1.27
Binary files /tmp/cvsUGjfro and /tmp/cvseNAtb9 differ

Index: WinEdColorize.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/WinEdColorize.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** WinEdColorize.f	5 Oct 2005 15:53:09 -0000	1.2
--- WinEdColorize.f	13 May 2007 07:52:25 -0000	1.3
***************
*** 56,60 ****
  1  9    AGAIN
  1  9    UNTIL
! 1  9    CONTINUE 
  1  9    DO
  1  9    ?DO
--- 56,60 ----
  1  9    AGAIN
  1  9    UNTIL
! 1  9    CONTINUE
  1  9    DO
  1  9    ?DO
***************
*** 342,346 ****
  1  11   FLOOR
  1  11   F-ROT
! 1  11   FPICK 
  1  11   FSQRT
  1  11   FTUCK
--- 342,346 ----
  1  11   FLOOR
  1  11   F-ROT
! 1  11   FPICK
  1  11   FSQRT
  1  11   FTUCK
***************
*** 486,490 ****
   open-previous?
   term-canceled?
-  second-copy?
   as-pc?
   start-browse?
--- 486,489 ----
***************
*** 492,494 ****
   max-toolbar
   displayingLine
- 

[Win32forth-cvs] win32forth/apps/SciEdit EdCompile.f, 1.4, 1.5 EdDebug.f, 1.2, 1.3 EdRemote.f, 1.3, 1.4 Main.f, 1.26, 1.27

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/SciEdit
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv27480/apps/SciEdit

Modified Files:
	EdCompile.f EdDebug.f EdRemote.f Main.f 
Log Message:
- Removed the Forth-Instance-Counting from then Editor-IO.

Index: EdDebug.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/SciEdit/EdDebug.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** EdDebug.f	5 May 2005 09:43:27 -0000	1.2
--- EdDebug.f	13 May 2007 07:52:26 -0000	1.3
***************
*** 43,51 ****
                  0 WM_DONEBP win32forth-message ;
  
- NewEditDialog InquireDlg "Inquire for Data Item" "Get Current Value for:" "Inquire" "" ""
- 
- defer inquirebp ( -- ) \ inquire for the value of a data item
- ' beep is inquirebp
- 
  0 value debug-buttons?
  
--- 43,46 ----
***************
*** 146,157 ****
                  ;M
  
- : show-inquire  { \ temp$ -- }
-                 MAXSTRING LocalAlloc: temp$
-                 s"  " temp$ place               \ init to empty type
-                 ed-result @ 4 min 0
-                 ?DO     ed-result i 1+ cells+ @ n>" temp$ +place
-                         s"  "                       temp$ +place
-                 LOOP    temp$ count IDT_RESULT SetDlgItemText: self ;
- 
  :M On_Init:     ( -- )
                  On_Init: super
--- 141,144 ----
***************
*** 181,185 ****
                       IDB_HERE     OF herebp                             ENDOF
                       IDB_DONE     OF donebp                             ENDOF
-                      IDB_INQUIRE  OF inquirebp show-inquire             ENDOF
                       IDR_HEX      OF TRUE  to HexBase ShowStack: self   ENDOF
                       IDR_DECIMAL  OF FALSE to HexBase ShowStack: self   ENDOF
--- 168,171 ----
***************
*** 208,234 ****
                  ShowDebug: DbgButtonsDlg ;
  
- : no-breakpoint ( -- )          \ not currently in a breakpoint
-                 beep ;
- 
  \ -----------------------------------------------------------------------------
  \ -----------------------------------------------------------------------------
! : zMessageBox   ( szString -- )
!                 z" Notice"
!                 MB_OK MB_ICONSTOP or
!                 MessageBox: Frame ;
! 
! MAXSTRING pointer debug-buf
! NewEditDialog DebugDlg "Insert BreakPoint at Word" "BreakPoint at: ' [ vocabulary (sp) ]  word '" "Set" "" ""
! 
! : "debug-word   ( a1 n1 -- )
!                 ed-name place                   \ the name we want debugged
!                 ed-response off                 \ clear return result
!                 0 WM_SETBP win32forth-message
!                 ed-response @ 0=
!                 IF   z" Failed to set BreakPoint!" zMessageBox
!                 THEN
!                 ed-response @                   \ browse mode it BP is set
!                 IF   debug-buttons
!                 THEN ;
! 
! 

[Win32forth-cvs] win32forth/apps/ForthForm FORTHFORM.F,1.21,1.22

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/ForthForm
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv27480/apps/ForthForm

Modified Files:
	FORTHFORM.F 
Log Message:
- Removed the Forth-Instance-Counting from then Editor-IO.

Index: FORTHFORM.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/FORTHFORM.F,v
retrieving revision 1.21
retrieving revision 1.22
diff -C2 -d -r1.21 -r1.22
*** FORTHFORM.F	15 Apr 2007 02:59:51 -0000	1.21
--- FORTHFORM.F	13 May 2007 07:52:26 -0000	1.22
***************
*** 1019,1023 ****
  \+ sysgen       HandleCmdLine  \ November 8th, 2003 - 9:52 dbu
                  show-release-notes
- \+ sysgen	-1 ed-forth-count +!     \ reduce count
  \+ sysgen       z" ForthForm Console" conhndl Call SetWindowText drop
                  ;
--- 1019,1022 ----

[Win32forth-cvs] win32forth/apps/Win32ForthIDE EdCompile.f, 1.4, 1.5 EdDebug.f, 1.1, 1.2 EdRemote.f, 1.6, 1.7 Main.f, 1.38, 1.39

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/Win32ForthIDE
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv27480/apps/Win32ForthIDE

Modified Files:
	EdCompile.f EdDebug.f EdRemote.f Main.f 
Log Message:
- Removed the Forth-Instance-Counting from then Editor-IO.

Index: EdDebug.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/EdDebug.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** EdDebug.f	5 Jun 2006 09:19:00 -0000	1.1
--- EdDebug.f	13 May 2007 07:52:26 -0000	1.2
***************
*** 43,51 ****
                  0 WM_DONEBP win32forth-message ;
  
- NewEditDialog InquireDlg "Inquire for Data Item" "Get Current Value for:" "Inquire" "" ""
- 
- defer inquirebp ( -- ) \ inquire for the value of a data item
- ' beep is inquirebp
- 
  0 value debug-buttons?
  
--- 43,46 ----
***************
*** 146,157 ****
                  ;M
  
- : show-inquire  { \ temp$ -- }
-                 MAXSTRING LocalAlloc: temp$
-                 s"  " temp$ place               \ init to empty type
-                 ed-result @ 4 min 0
-                 ?DO     ed-result i 1+ cells+ @ n>" temp$ +place
-                         s"  "                       temp$ +place
-                 LOOP    temp$ count IDT_RESULT SetDlgItemText: self ;
- 
  :M On_Init:     ( -- )
                  On_Init: super
--- 141,144 ----
***************
*** 181,185 ****
                       IDB_HERE     OF herebp                             ENDOF
                       IDB_DONE     OF donebp                             ENDOF
-                      IDB_INQUIRE  OF inquirebp show-inquire             ENDOF
                       IDR_HEX      OF TRUE  to HexBase ShowStack: self   ENDOF
                       IDR_DECIMAL  OF FALSE to HexBase ShowStack: self   ENDOF
--- 168,171 ----
***************
*** 208,234 ****
                  ShowDebug: DbgButtonsDlg ;
  
- : no-breakpoint ( -- )          \ not currently in a breakpoint
-                 beep ;
- 
  \ -----------------------------------------------------------------------------
  \ -----------------------------------------------------------------------------
! : zMessageBox   ( szString -- )
!                 z" Notice"
!                 MB_OK MB_ICONSTOP or
!                 MessageBox: Frame ;
! 
! MAXSTRING pointer debug-buf
! NewEditDialog DebugDlg "Insert BreakPoint at Word" "BreakPoint at: ' [ vocabulary (sp) ]  word '" "Set" "" ""
! 
! : "debug-word   ( a1 n1 -- )
!                 ed-name place                   \ the name we want debugged
!                 ed-response off                 \ clear return result
!                 0 WM_SETBP win32forth-message
!                 ed-response @ 0=
!                 IF   z" Failed to set BreakPoint!" zMessageBox
!                 THEN
!                 ed-response @                   \ browse mode it BP is set
!                 IF   debug-buttons
!                 THEN ;
  
- 

[Win32forth-cvs] win32forth/apps/WinEd Ed_Debug.F, 1.2, 1.3 Ed_Globals.F, 1.4, 1.5 Ed_HyperLink.F, 1.5, 1.6 Ed_Remote.F, 1.4, 1.5 WinEd.f, 1.15, 1.16

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/WinEd
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv27480/apps/WinEd

Modified Files:
	Ed_Debug.F Ed_Globals.F Ed_HyperLink.F Ed_Remote.F WinEd.f 
Log Message:
- Removed the Forth-Instance-Counting from then Editor-IO.

Index: WinEd.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/WinEd/WinEd.f,v
retrieving revision 1.15
retrieving revision 1.16
diff -C2 -d -r1.15 -r1.16
*** WinEd.f	2 Dec 2006 10:17:30 -0000	1.15
--- WinEd.f	13 May 2007 07:52:26 -0000	1.16
***************
*** 135,146 ****
  
                  .free                   \ how much memory did we really use?
-                 -1 ed-forth-count +!    \ remove myself from Forth count
                  &forthdir count &appdir place
                  0 0 ' wined ' APPLICATION catch WinEd.exe checkstack  \ save WinEd.exe
                  &appdir off
-                 1 ed-forth-count +!
                  swap forth-msg-chain !
-                 \ make sure that the remote I/O will still work after WinEd is compiled
-                 also hidden ' uninit-shared-forth is uninit-shared-type previous
                  throw
                  s" src\res\WinEd.ico"  s" WinEd.exe" Prepend<home>\ AddAppIcon
--- 135,142 ----

Index: Ed_Debug.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/WinEd/Ed_Debug.F,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** Ed_Debug.F	30 Apr 2005 20:52:42 -0000	1.2
--- Ed_Debug.F	13 May 2007 07:52:26 -0000	1.3
***************
*** 126,130 ****
                  ztemp MAXSTRING erase                   \ null fill buffer
                  adr ztemp len MAXSTRING 1- min move     \ move text to buffer
!                 ztemp 
                  0 LB_ADDSTRING IDL_WORDS SendDlgItemMessage: self drop ;
  
--- 126,130 ----
                  ztemp MAXSTRING erase                   \ null fill buffer
                  adr ztemp len MAXSTRING 1- min move     \ move text to buffer
!                 ztemp
                  0 LB_ADDSTRING IDL_WORDS SendDlgItemMessage: self drop ;
  
***************
*** 202,210 ****
                  ShowDebug: DbgButtonsDlg ;
  
- : no-breakpoint ( -- )          \ not currently in a breakpoint
-                 beep ;
- 
- 
- 
  : zMessageBox   ( szString -- )
                  z" Notice"
--- 202,205 ----

Index: Ed_Globals.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/WinEd/Ed_Globals.F,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** Ed_Globals.F	28 Aug 2005 07:28:06 -0000	1.4
--- Ed_Globals.F	13 May 2007 07:52:26 -0000	1.5
***************
*** 30,34 ****
    760 value start-width         \ was 640
    420 value start-height        \ was 480
!   
     60 value drag-barH
      4 value drag-thick
--- 30,34 ----
    760 value start-width         \ was 640
    420 value start-height        \ was 480
! 
     60 value drag-barH
      4 value drag-thick
***************
*** 61,65 ****
  FALSE value open-previous?      \ should we open the file we had open previously
  FALSE value term-canceled?      \ did we cancel program termination
- FALSE value second-copy?        \ am I the second editor copy to load
  FALSE value as-pc?              \ save file as a PC file?
  FALSE value start-browse?       \ are we starting in browse mode?
--- 61,64 ----
***************
*** 130,137 ****
  
          \ wait untill Forth is loaded
!         WaitForConsole
! 
!         \ adjust count of Forths currently running
!         -1 ed-forth-count +! ;  \ SF-RequestID 745393 - fixed June 8th, 2003 - 12:59 dbu
  
  : highlight-cursor ( -- )
--- 129,133 ----
  
          \ wait untill Forth is loaded
!         WaitForConsole ;
  
  : highlight-cursor ( -- )

Index: Ed_HyperLink.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/WinEd/Ed_HyperLink.F,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** Ed_HyperLink.F	26 Aug 2006 15:25:32 -0000	1.5
--- Ed_HyperLink.F	13 May 2007 07:52:26 -0000	1.6
***************
*** 189,193 ****
  
  : help-link     ( -- )           \ link to the currently highlighted word
!                 bitImage? ?EXIT  \ it is bound to Ctrl-F1   
                  highlighting? 0=                \ something is highlighted
                  IF      highlight-word
--- 189,193 ----
  
  : help-link     ( -- )           \ link to the currently highlighted word
!                 bitImage? ?EXIT  \ it is bound to Ctrl-F1
                  highlighting? 0=                \ something is highlighted
                  IF      highlight-word
***************
*** 202,206 ****
  
  : help-api      ( -- )           \ link to the currently highlighted word
!                 bitImage? ?EXIT  \ it is bound to Ctrl-F2   
                  highlighting? 0=                \ something is highlighted
                  IF      highlight-word
--- 202,206 ----
  
  : help-api      ( -- )           \ link to the currently highlighted word
!                 bitImage? ?EXIT  \ it is bound to Ctrl-F2
                  highlighting? 0=                \ something is highlighted
                  IF      highlight-word
***************
*** 295,299 ****
                                                    \ if already open
  
! ' _"+open-text is "+open-text 
  
  1 value FilterIndex
--- 295,299 ----
                                                    \ if already open
  
! ' _"+open-text is "+open-text
  
  1 value FilterIndex
***************
*** 365,369 ****
          >r
          MB_OK MB_TASKMODAL or
!         z" Win-Ed DOS Commandline Help" 
          r> NULL call MessageBox drop ;
  
--- 365,369 ----
          >r
          MB_OK MB_TASKMODAL or
!         z" Win-Ed DOS Commandline Help"
          r> NULL call MessageBox drop ;
  
***************
*** 392,400 ****
      ( rbs )                    s" .NDX" &WINED.NDX +place
                         THEN
-                        uninit-shared-memory             \ I'm not here
                         hyper-compile
                         BYE
                  THEN
!                 
                  \ just a dummy command to ignore the /IMAGE directive to the wrapper
                  2dup s" IMAGE" compare 0=               \ in case started with
--- 392,399 ----
      ( rbs )                    s" .NDX" &WINED.NDX +place
                         THEN
                         hyper-compile
                         BYE
                  THEN
! 
                  \ just a dummy command to ignore the /IMAGE directive to the wrapper
                  2dup s" IMAGE" compare 0=               \ in case started with
***************
*** 446,450 ****
  \ GetLongPathName() isn't supported under Win95, NT 3.51 and NT4,
  \ so we can only use it under Win98, WinME and Win2000 and later.
! \ This bug was reported on Wed, 02 Jun 2004 by Bruce Rennie 
  [ winver win95 = winver winnt351 = or winver winnt4 = or ]
  [IF]
--- 445,449 ----
  \ GetLongPathName() isn't supported under Win95, NT 3.51 and NT4,
  \ so we can only use it under Win98, WinME and Win2000 and later.
! \ This bug was reported on Wed, 02 Jun 2004 by Bruce Rennie
  [ winver win95 = winver winnt351 = or winver winnt4 = or ]
  [IF]
***************
*** 621,625 ****
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
! \ 38    Cause text command string to be interpreted.     
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  
--- 620,624 ----
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
! \ 38    Cause text command string to be interpreted.
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  
***************
*** 647,656 ****
          THEN    ;
  
! : 'line         ( -- addr )  \ get address of the line 
          get-cursor-line cur-buf LCOUNT drop ;
  
  : 'cursor       ( -- addr )  \ Get the address of the cursor.
          'line  cursor-col +  ;
!         
  
  \ *p SMART-CR  ( -- ) Bruno's version of Baden's smart cursor follows the ragged
--- 646,655 ----
          THEN    ;
  
! : 'line         ( -- addr )  \ get address of the line
          get-cursor-line cur-buf LCOUNT drop ;
  
  : 'cursor       ( -- addr )  \ Get the address of the cursor.
          'line  cursor-col +  ;
! 
  
  \ *p SMART-CR  ( -- ) Bruno's version of Baden's smart cursor follows the ragged
***************
*** 671,675 ****
  : do-goto-line  ( -- )
                  goto-line ;
!                 
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  \ 41    Change case of highlighted text
--- 670,674 ----
  : do-goto-line  ( -- )
                  goto-line ;
! 
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  \ 41    Change case of highlighted text

Index: Ed_Remote.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/WinEd/Ed_Remote.F,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** Ed_Remote.F	13 Nov 2006 13:51:52 -0000	1.4
--- Ed_Remote.F	13 May 2007 07:52:26 -0000	1.5
***************
*** 8,47 ****
  \ also needed for debug support
  
- 0 value second-copy?
- 
  defer remote-open   ( wParam -- )  ' noop is remote-open
  defer remote-word   ( -- )         ' noop is remote-word
  
  : HandleW32FMsg { hndl msg wParam lParam -- }  \ respond to Win32Forth messages
!         second-copy? 0=
!         IF  wParam
!             CASE
!                   \ debug support messages
!                   ED_OPEN_EDIT   OF wParam remote-open ENDOF
!                   ED_OPEN_BROWSE OF wParam remote-open ENDOF
!                   ED_WATCH       OF wParam remote-open ENDOF
!                   ED_WORD        OF remote-word        ENDOF
!                   ED_STACK       OF receive-stack      ENDOF
!                   ED_DEBUG       OF receive-debug      ENDOF
!                   ED_NOTINBP     OF no-breakpoint      ENDOF
  
!                   \ console start and termination
!                   ED_ALIVE       OF true  to ConsoleReady? ENDOF
!                   ED_SHUTDOWN    OF false to ConsoleReady? ENDOF
!             ENDCASE
!         THEN ;
  
  :noname         ( -- )
                  ed-ptr 0= ?EXIT      \ leave if shared memory not inited
!                 EditorWindow
!                 IF   ed-window @ 0<> to second-copy?
!                      GetHandle: EditorWindow ed-window ! \ set our window handle
!                 then ; is init-shared-type
  
  :noname         ( -- )
                  ed-ptr 0= ?EXIT \ leave if shared memory not inited
!                 second-copy? 0=
!                 IF   0 ed-window !  \ clear our window handle
!                 THEN ; is uninit-shared-type
  
  
--- 8,40 ----
  \ also needed for debug support
  
  defer remote-open   ( wParam -- )  ' noop is remote-open
  defer remote-word   ( -- )         ' noop is remote-word
  
  : HandleW32FMsg { hndl msg wParam lParam -- }  \ respond to Win32Forth messages
!         wParam
!         CASE
!                 \ debug support messages
!                 ED_OPEN_EDIT   OF wParam remote-open ENDOF
!                 ED_OPEN_BROWSE OF wParam remote-open ENDOF
!                 ED_WATCH       OF wParam remote-open ENDOF
!                 ED_WORD        OF remote-word        ENDOF
!                 ED_STACK       OF receive-stack      ENDOF
!                 ED_DEBUG       OF receive-debug      ENDOF
  
!                 \ console start and termination
!                 ED_ALIVE       OF true  to ConsoleReady? ENDOF
!                 ED_SHUTDOWN    OF false to ConsoleReady? ENDOF
!         ENDCASE
!         ;
  
  :noname         ( -- )
                  ed-ptr 0= ?EXIT      \ leave if shared memory not inited
!                 GetHandle: EditorWindow ed-window ! \ set our window handle
!                 ; is init-shared-type
  
  :noname         ( -- )
                  ed-ptr 0= ?EXIT \ leave if shared memory not inited
!                 0 ed-window !  \ clear our window handle
!                 ; is uninit-shared-type
  
  

[Win32forth-cvs] win32forth/src/lib LoadProject.f,1.5,1.6

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/src/lib
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv27480/src/lib

Modified Files:
	LoadProject.f 
Log Message:
- Removed the Forth-Instance-Counting from then Editor-IO.

Index: LoadProject.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/LoadProject.f,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** LoadProject.f	12 May 2007 07:49:22 -0000	1.5
--- LoadProject.f	13 May 2007 07:52:27 -0000	1.6
***************
*** 3,16 ****
  Needs src\lib\w_search.f
  
  IN-SYSTEM
  
  map-handle ProjectHndl
  
- create LatestProjectFile$ ," LatestProject.dat"
- 
  : CountMappedFile ( ProjectHndl - )
  	dup >hfileAddress @  swap >hfileLength  @	;
  
! : LoadProject
  	LatestProjectFile$ count Prepend<home>\ ProjectHndl open-map-file
  	abort" Use Win32Forth IDE to open or define a project"
--- 3,21 ----
  Needs src\lib\w_search.f
  
+ IN-APPLICATION
+ 
+ create LatestProjectFile$ ," LatestProject.dat"
+ 
+ IN-PREVIOUS
+ 
  IN-SYSTEM
  
  map-handle ProjectHndl
  
  : CountMappedFile ( ProjectHndl - )
  	dup >hfileAddress @  swap >hfileLength  @	;
  
! : LoadProject   ( -- )
! \ *G Compile the Project which was last used in the Win32ForthIDE
  	LatestProjectFile$ count Prepend<home>\ ProjectHndl open-map-file
  	abort" Use Win32Forth IDE to open or define a project"
***************
*** 21,32 ****
  	abort" Project not found. Use Win32Forth IDE to open or define a project"
  	ProjectHndl CountMappedFile false   w-search  \ Search the line with BuildFile=
! 		if	ProjectHndl CountMappedFile nip over - -rot + swap
! 			2dup 0xd scan nip - Prepend<home>\ temp$ place
! 			ProjectHndl close-map-file drop
! 			temp$ count "path-only" pad place
! 			pad dup +null count  "chdir
! 			cr ." Loading " temp$ count 2dup type included
! 		else	abort" Invalid projectfile"
! 		then
  ;
  
--- 26,37 ----
  	abort" Project not found. Use Win32Forth IDE to open or define a project"
  	ProjectHndl CountMappedFile false   w-search  \ Search the line with BuildFile=
!         if	ProjectHndl CountMappedFile nip over - -rot + swap
!                 2dup 0xd scan nip - Prepend<home>\ temp$ place
!                 ProjectHndl close-map-file drop
!                 temp$ count "path-only" pad place
!                 pad dup +null count  "chdir
!                 cr ." Loading " temp$ count 2dup type included
!         else	abort" Invalid projectfile"
!         then
  ;
  

[Win32forth-cvs] win32forth/demos/AccelDemo AccelDemo.f,1.2,1.3

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth/demos/AccelDemo
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv8889

Modified Files:
	AccelDemo.f 
Log Message:
Jos: Solved the copy-demo-bitmap problem.

Index: AccelDemo.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/demos/AccelDemo/AccelDemo.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** AccelDemo.f	5 May 2005 09:43:28 -0000	1.2
--- AccelDemo.f	12 May 2007 14:21:20 -0000	1.3
***************
*** 232,236 ****
          SUBMENU         "&Copy"
               MENUITEM   "Plot Window &Normal\tCtrl+C"          4719 Handle-Key-Table ;
!              MENUITEM   "Plot Window &Inverted\tShift+Ctrl+P"  4720 Handle-Key-Table ;
               ENDSUBMENU
          MENUITEM        "Paste\tCtrl+V"                        4721 Handle-Key-Table ;
--- 232,236 ----
          SUBMENU         "&Copy"
               MENUITEM   "Plot Window &Normal\tCtrl+C"          4719 Handle-Key-Table ;
!              MENUITEM   "Plot Window &Inverted\tShift+Ctrl+C"  4720 Handle-Key-Table ;
               ENDSUBMENU
          MENUITEM        "Paste\tCtrl+V"                        4721 Handle-Key-Table ;
***************
*** 523,527 ****
  
                  hbm hdcMem call SelectObject drop
!                 r>
                  IF      NOTSRCCOPY
                  ELSE    SRCCOPY
--- 523,527 ----
  
                  hbm hdcMem call SelectObject drop
!                 flag
                  IF      NOTSRCCOPY
                  ELSE    SRCCOPY
***************
*** 1101,1105 ****
  
          FCONTROL            'C'    4719  ' handle-control-c        ACCELENTRY
!         FCONTROL FSHIFT OR  'C'    4720  ' handle-control-shift-p  ACCELENTRY
          FCONTROL            'V'    4721  ' paste-demo-bitmap       ACCELENTRY
          FCONTROL            'X'    4722  ' handle-control-x        ACCELENTRY
--- 1101,1105 ----
  
          FCONTROL            'C'    4719  ' handle-control-c        ACCELENTRY
!         FCONTROL FSHIFT OR  'C'    4720  ' handle-control-shift-c  ACCELENTRY
          FCONTROL            'V'    4721  ' paste-demo-bitmap       ACCELENTRY
          FCONTROL            'X'    4722  ' handle-control-x        ACCELENTRY
***************
*** 1150,1152 ****
  AccelDemo
  \ ' windemo turnkey AccelDemo
! 

[Win32forth-cvs] win32forth-stc/demos/AccelDemo AccelDemo.f, 1.1, 1.2

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/demos/AccelDemo
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv6864

Modified Files:
	AccelDemo.f 
Log Message:
Jos: Solved the copy-demo-bitmap problem.

Index: AccelDemo.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/demos/AccelDemo/AccelDemo.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** AccelDemo.f	12 May 2007 13:42:09 -0000	1.1
--- AccelDemo.f	12 May 2007 14:17:47 -0000	1.2
***************
*** 233,237 ****
          SUBMENU         "&Copy"
               MENUITEM   "Plot Window &Normal\tCtrl+C"          4719 Handle-Key-Table ;
!              MENUITEM   "Plot Window &Inverted\tShift+Ctrl+P"  4720 Handle-Key-Table ;
               ENDSUBMENU
          MENUITEM        "Paste\tCtrl+V"                        4721 Handle-Key-Table ;
--- 233,237 ----
          SUBMENU         "&Copy"
               MENUITEM   "Plot Window &Normal\tCtrl+C"          4719 Handle-Key-Table ;
!              MENUITEM   "Plot Window &Inverted\tShift+Ctrl+C"  4720 Handle-Key-Table ;
               ENDSUBMENU
          MENUITEM        "Paste\tCtrl+V"                        4721 Handle-Key-Table ;
***************
*** 522,528 ****
                  GetHandle: demo-dc
                  call CreateCompatibleDC to hdcMem
- 
                  hbm hdcMem call SelectObject drop
!                 r>
                  IF      NOTSRCCOPY
                  ELSE    SRCCOPY
--- 522,527 ----
                  GetHandle: demo-dc
                  call CreateCompatibleDC to hdcMem
                  hbm hdcMem call SelectObject drop
!                 flag
                  IF      NOTSRCCOPY
                  ELSE    SRCCOPY
***************
*** 1102,1106 ****
  
          FCONTROL            'C'    4719  ' handle-control-c        ACCELENTRY
!         FCONTROL FSHIFT OR  'C'    4720  ' handle-control-shift-p  ACCELENTRY
          FCONTROL            'V'    4721  ' paste-demo-bitmap       ACCELENTRY
          FCONTROL            'X'    4722  ' handle-control-x        ACCELENTRY
--- 1101,1105 ----
  
          FCONTROL            'C'    4719  ' handle-control-c        ACCELENTRY
!         FCONTROL FSHIFT OR  'C'    4720  ' handle-control-shift-c  ACCELENTRY
          FCONTROL            'V'    4721  ' paste-demo-bitmap       ACCELENTRY
          FCONTROL            'X'    4722  ' handle-control-x        ACCELENTRY