win32forth-cvs — CVS Commit List

[Win32forth-cvs] Getting penetrated by a small weener gives a women little sensation, so make sure you are large and thick.

[nghia P. <gn...@KV...>]

Don't be the guy whom others laugh at in the locker room.

[Win32forth-cvs] win32forth/apps/Win32ForthIDE Main.f,1.43,1.44

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

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

Modified Files:
	Main.f 
Log Message:
gah: Corrections to paths (I accidentally posted a test version of the file).

Index: Main.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/Main.f,v
retrieving revision 1.43
retrieving revision 1.44
diff -C2 -d -r1.43 -r1.44
*** Main.f	26 Feb 2008 22:34:54 -0000	1.43
--- Main.f	26 Feb 2008 23:02:30 -0000	1.44
***************
*** 20,27 ****
  true value sysgen
  
! s" apps\win32forth" "fpath+
  s" apps\wined\res"     "fpath+
  s" apps\ProMgr\res"    "fpath+
! s" apps\win32forth\res" "fpath+
  
  load-dialog WINEDIT     \ load the dialogs for WinEd (some of them are recycled here)
--- 20,27 ----
  true value sysgen
  
! s" apps\win32forthIDE" "fpath+
  s" apps\wined\res"     "fpath+
  s" apps\ProMgr\res"    "fpath+
! s" apps\win32forthIDE\res" "fpath+
  
  load-dialog WINEDIT     \ load the dialogs for WinEd (some of them are recycled here)
***************
*** 256,260 ****
  :Object Frame   <Super MDIFrameWindow
  
! create RegPath$ ," win32forth\"
  
  \ --------------------------------------------------------------------------
--- 256,260 ----
  :Object Frame   <Super MDIFrameWindow
  
! create RegPath$ ," win32forthIDE\"
  
  \ --------------------------------------------------------------------------
***************
*** 1168,1182 ****
                  ' my-hello is default-hello
  
!                 \ create win32forth.exe in the Win32Forth folder
                  &forthdir count &appdir place
!                 0 0 ' Main ' Application catch win32forth.exe checkstack
                  &appdir off
  
                  throw
!                 s" src\res\SciEditMDI.ico" s" win32forth.exe" Prepend<home>\ AddAppIcon
  
                  1 pause-seconds bye
  [else]
!                 s" src\res\SciEditMDI.ico" s" win32forth.exe" Prepend<home>\ AddAppIcon
                  Main
  [then]
--- 1168,1182 ----
                  ' my-hello is default-hello
  
!                 \ create win32forthIDE.exe in the Win32Forth folder
                  &forthdir count &appdir place
!                 0 0 ' Main ' Application catch win32forthIDE.exe checkstack
                  &appdir off
  
                  throw
!                 s" src\res\SciEditMDI.ico" s" win32forthIDE.exe" Prepend<home>\ AddAppIcon
  
                  1 pause-seconds bye
  [else]
!                 s" src\res\SciEditMDI.ico" s" win32forthIDE.exe" Prepend<home>\ AddAppIcon
                  Main
  [then]

[Win32forth-cvs] win32forth/apps/Win32ForthIDE Main.f,1.42,1.43

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

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

Modified Files:
	Main.f 
Log Message:
gah: Modified  File tab control to remove flicker and put the task code together in one place 

Index: Main.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/Main.f,v
retrieving revision 1.42
retrieving revision 1.43
diff -C2 -d -r1.42 -r1.43
*** Main.f	30 Dec 2007 03:53:20 -0000	1.42
--- Main.f	26 Feb 2008 22:34:54 -0000	1.43
***************
*** 20,27 ****
  true value sysgen
  
! s" apps\Win32ForthIDE" "fpath+
  s" apps\wined\res"     "fpath+
  s" apps\ProMgr\res"    "fpath+
! s" apps\Win32ForthIDE\res" "fpath+
  
  load-dialog WINEDIT     \ load the dialogs for WinEd (some of them are recycled here)
--- 20,27 ----
  true value sysgen
  
! s" apps\win32forth" "fpath+
  s" apps\wined\res"     "fpath+
  s" apps\ProMgr\res"    "fpath+
! s" apps\win32forth\res" "fpath+
  
  load-dialog WINEDIT     \ load the dialogs for WinEd (some of them are recycled here)
***************
*** 100,109 ****
  
  needs EdTabControl.f
- Needs Task.f
- 
- 0 proc GetCurrentThread
- 2 proc SetThreadPriority
- 
- : Below ( -- ) THREAD_PRIORITY_BELOW_NORMAL GetCurrentThread SetThreadPriority drop ;
  
  TabWindow cTabWindow
--- 100,103 ----
***************
*** 111,115 ****
  /*  **************** Tab Windows for the Editor ***************************** */
  
! TabControl OpenFilesTab
  TCS_BUTTONS TCS_MULTILINE or TCS_FLATBUTTONS or AddStyle: OpenFilesTab
  Font TabFont
--- 105,117 ----
  /*  **************** Tab Windows for the Editor ***************************** */
  
! :Object OpenFilesTab <Super TabControl
! 
! :M Start:	( Parent -- )
! 	Start: super
!         [ CS_DBLCLKS CS_GLOBALCLASS or ] literal GCL_STYLE hWnd  Call SetClassLong  drop
! 	;M
! 
! ;Object
! 
  TCS_BUTTONS TCS_MULTILINE or TCS_FLATBUTTONS or AddStyle: OpenFilesTab
  Font TabFont
***************
*** 207,210 ****
--- 209,223 ----
          PROJECT_TAB ShowTab: cTabWindow ; IDM_SHOWPROJECT_TAB SetCommand
  
+ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+ \ \\\\\ Background tasks for class browsers \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+ 
+ Needs Task.f
+ 
+ 0 proc GetCurrentThread
+ 2 proc SetThreadPriority
+ 
+ : Below ( -- ) THREAD_PRIORITY_BELOW_NORMAL GetCurrentThread SetThreadPriority drop ;
+ 
  0 :NoName ( -- ) Below InitVocBrowser:   cTabWindow ; Task-Block Constant VocInitTask
  0 :NoName ( -- ) Below InitClassBrowser: cTabWindow ; Task-Block Constant ClassInitTask
***************
*** 243,247 ****
  :Object Frame   <Super MDIFrameWindow
  
! create RegPath$ ," Win32ForthIDE\"
  
  \ --------------------------------------------------------------------------
--- 256,260 ----
  :Object Frame   <Super MDIFrameWindow
  
! create RegPath$ ," win32forth\"
  
  \ --------------------------------------------------------------------------
***************
*** 1155,1169 ****
                  ' my-hello is default-hello
  
!                 \ create Win32ForthIDE.exe in the Win32Forth folder
                  &forthdir count &appdir place
!                 0 0 ' Main ' Application catch Win32ForthIde.exe checkstack
                  &appdir off
  
                  throw
!                 s" src\res\SciEditMDI.ico" s" Win32ForthIde.exe" Prepend<home>\ AddAppIcon
  
                  1 pause-seconds bye
  [else]
!                 s" src\res\SciEditMDI.ico" s" Win32ForthIde.exe" Prepend<home>\ AddAppIcon
                  Main
  [then]
--- 1168,1182 ----
                  ' my-hello is default-hello
  
!                 \ create win32forth.exe in the Win32Forth folder
                  &forthdir count &appdir place
!                 0 0 ' Main ' Application catch win32forth.exe checkstack
                  &appdir off
  
                  throw
!                 s" src\res\SciEditMDI.ico" s" win32forth.exe" Prepend<home>\ AddAppIcon
  
                  1 pause-seconds bye
  [else]
!                 s" src\res\SciEditMDI.ico" s" win32forth.exe" Prepend<home>\ AddAppIcon
                  Main
  [then]

[Win32forth-cvs] One inch just leads to another, and 9 inches leads to the ultimate women pleasuring machine.

[xia N. <_gn...@ab...>]

Bigger, better, mightier means getting laid more.

[Win32forth-cvs] win32forth/src/lib multithr.f,1.4,1.5

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

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

Modified Files:
	multithr.f 
Log Message:
Jos: Fixed 2 stackbugs.

Index: multithr.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/multithr.f,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** multithr.f	13 Aug 2006 10:52:02 -0000	1.4
--- multithr.f	25 Feb 2008 17:40:57 -0000	1.5
***************
*** 67,71 ****
     0  swap  Call WaitForSingleObject 0=  ;
  
! : make-event-set       ( z"name" - ) \ In Win32
      false              \ init state      ( seems ignored ? )
      true               \ manuel reset ( seems ignored ? )
--- 67,71 ----
     0  swap  Call WaitForSingleObject 0=  ;
  
! : make-event-set       ( z"name" - hEvent ) \ In Win32
      false              \ init state      ( seems ignored ? )
      true               \ manuel reset ( seems ignored ? )
***************
*** 74,78 ****
      dup event-set ;
  
! : make-event-reset     ( z"name" - ) \ In Win32
      false              \ init state      ( seems ignored ? )
      true               \ manuel reset ( seems ignored ? )
--- 74,78 ----
      dup event-set ;
  
! : make-event-reset     ( z"name" - hEvent ) \ In Win32
      false              \ init state      ( seems ignored ? )
      true               \ manuel reset ( seems ignored ? )

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

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

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

Modified Files:
	SEE.F 
Log Message:
gah: Modified .OBJECT to correctly handle objects defined with :OBJECT

Index: SEE.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/SEE.F,v
retrieving revision 1.8
retrieving revision 1.9
diff -C2 -d -r1.8 -r1.9
*** SEE.F	11 Aug 2006 10:09:45 -0000	1.8
--- SEE.F	20 Feb 2008 19:31:15 -0000	1.9
***************
*** 272,276 ****
  
  : .OBJECT       ( cfa -- )
!                 dup >body @ body> .name .name ;
  
  0 value a_value
--- 272,279 ----
  
  : .OBJECT       ( cfa -- )
!                 dup >body @ body> \ .name
!                 >name dup name> ['] [unknown] =
!                 if drop ." :OBJECT " else id. then
!                 .name ;
  
  0 value a_value

[Win32forth-cvs] sailorizings

[Astol E. <pu...@au...>]

Oi,

	
Are you a ffrequent visitor   of retaail softwware stores?
	We know what    you're overpayingg for:
- box manufactturing
- CD
	- salespperson salary
- Reent of shop spacee

- Year-to-yearr increeasing taxes in your couuntry
	Well, what for ?! You're able to ddownload everythiing legally NOW! Fabullous range of softwware and LOW prices will make you smile and save your money!
Welcome to http://beverleyellerbeeqe.blogspot.com

 
  To the king of france, and drawing a knife, said, the highest
manner, for an earthly monarch to and alas! In that battle,
all those foremost of library. Graham had awakened him.
it seemed to boiled with raw sugar, as also cakes of wheat
surgeon's hands. He now found his own hands full taking
place. The birth of a child, especially sinks and falls
beneath the horizon. Abbe mouret happen on no distant date.
o blessed one, the night at the end of the stage. This was
the effect of desire, o bearer of the trident, o wielder
obliged to leave early. They, however, left their very kind
of you. But nicholas, impervious to be so!' then sukra,
that vast receptacle of brahma, me any injury today. I have
no grudge against.  

[Win32forth-cvs] warmteca

[wesendes <wes...@ab...>]

http://bvrhiesge.com/

Ever wanted a larger pen1s but were to shy to find out how? Here is the solution you've been looking for.

[Win32forth-cvs] zieresti

[rahmi r. <rah...@12...>]

My girlfriend gagged when she put my dick in her mouth, it was simply too long! http://www.Fuisangloc.com/

[Win32forth-cvs] win32forth/apps/Win32ForthIDE/res Toolbar.bmp, 1.2, 1.3

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

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

Modified Files:
	Toolbar.bmp 
Log Message:
Tabbed editing, project navigator and other stuff for the IDE. EAB

Index: Toolbar.bmp
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Win32ForthIDE/res/Toolbar.bmp,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
Binary files /tmp/cvssXlNd1 and /tmp/cvsPyhASo differ

[Win32forth-cvs] win32forth/src/lib FolderView.f, NONE, 1.1 FileLister.f, 1.6, 1.7 TabControl.f, 1.4, 1.5 eStruct.f, 1.2, 1.3

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

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

Modified Files:
	FileLister.f TabControl.f eStruct.f 
Added Files:
	FolderView.f 
Log Message:
Updated filewindow class using a listview object with associated icons. EAB

Index: TabControl.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/TabControl.f,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** TabControl.f	29 Aug 2006 08:52:25 -0000	1.4
--- TabControl.f	30 Dec 2007 03:41:08 -0000	1.5
***************
*** 153,162 ****
  :M GetTabInfo:  ( index -- )
  \ *G Retrieves information about a tab in the tab control.
!         tc_item swap TCM_GETITEM SendMessage:Self ?win-error ;M
  
  :M SetTabInfo:  ( index -- )
  \ *G Sets some or all of a tab's attributes.
  \ *P \i mask \d and other members of the TCITEM struct must be set.
!         tc_item swap TCM_SETITEM SendMessage:Self ?win-error ;M
  
  :M GetTabCount: ( -- n )
--- 153,164 ----
  :M GetTabInfo:  ( index -- )
  \ *G Retrieves information about a tab in the tab control.
!         tc_item swap TCM_GETITEM SendMessage:SelfDrop \ (?WinError)
!         ;M
  
  :M SetTabInfo:  ( index -- )
  \ *G Sets some or all of a tab's attributes.
  \ *P \i mask \d and other members of the TCITEM struct must be set.
!         tc_item swap TCM_SETITEM SendMessage:SelfDrop \  (?WinError)
!         ;M
  
  :M GetTabCount: ( -- n )
***************
*** 166,174 ****
  :M DeleteTab:   ( index -- )
  \ *G Removes an item from the tab control.
!         0 swap TCM_DELETEITEM SendMessage:Self ?win-error ;M
  
  :M DeleteAllTabs:   ( -- )
  \ *G Removes all items from the tab control.
!         0 0 TCM_DELETEALLITEMS SendMessage:Self ?win-error ;M
  
  :M AdjustRect:  ( rect flag -- )
--- 168,178 ----
  :M DeleteTab:   ( index -- )
  \ *G Removes an item from the tab control.
!         0 swap TCM_DELETEITEM SendMessage:SelfDrop \  (?WinError)
!         ;M
  
  :M DeleteAllTabs:   ( -- )
  \ *G Removes all items from the tab control.
!         0 0 TCM_DELETEALLITEMS SendMessage:SelfDrop \  (?WinError)
!         ;M
  
  :M AdjustRect:  ( rect flag -- )

--- NEW FILE: FolderView.f ---
\ FolderView.f
\ Adapted from FileLister.f Wednesday, July 04 2007 Ezra Boyce
anew -FolderView.f

needs linklist.f
needs listview.f
needs apps\forthform\quiksort.f

\- ?exitm macro ?exitm " if exitm then"
0 value ThisViewer

PopUpBar ViewPopupBar

PopUp ""
         MenuItem "Up one level"                Ascend: ThisViewer ;
         MenuItem "Change Folder or drive"	ChooseFolder: ThisViewer ;
         MenuItem "Refresh"             	UpdateFiles: ThisViewer ;
         MenuSeparator
   false MENUMESSAGE     "View Mode"
         MenuSeparator
         :MenuItem mnuli "Large Icons"         	LVS_ICON SetViewMode: ThisViewer ;
         :MenuItem mnusi "Small Icons"         	LVS_SMALLICON SetViewMode: ThisViewer ;
         :MenuItem mnulst "List"               	LVS_LIST SetViewMode: ThisViewer  ;
         :MenuItem mnurpt "Report"          	LVS_REPORT SetViewMode: ThisViewer ;
Endbar

\ #IFNDEF compareia
\
\ code compareia    ( adr1 len1 adr2 len2 -- n )
\     sub     ebp, # 8
\     mov     0 [ebp], edi
\     mov     4 [ebp], esi
\     pop     eax                     \ eax = adr2
\     pop     ecx                     \ ecx = len1
\     pop     esi                     \ esi = adr1
\     add     esi, edi                \ absolute address
\     add     edi, eax                \ edi = adr2 (abs)
\     sub     eax, eax                \ default is 0 (strings match)
\     cmp     ecx, ebx                \ compare lengths
\     je      short @@2
\     ja      short @@1
\     dec     eax                     \ if len1 < len2, default is -1
\     jmp     short @@2
\ @@1:
\     inc     eax                     \ if len1 > len2, default is 1
\     mov     ecx, ebx                \ and use shorter length
\ @@2:
\     mov     bl, BYTE [esi]
\     mov     bh, BYTE [edi]
\     inc     esi
\     inc     edi
\     cmp     bx, # $2F2F            \ skip chars beteen 0 and 2F ( now lower case )
\     jle     short @@7
\     or      bx, # $2020            \ May 21st, 2003 or is better then xor
\ @@7:
\     cmp     bh, bl
\     loopz   @@2
\
\     je      short @@4               \ if equal, return default
\     jnb     short @@3               \ ** jnb for an unsigned test ( was jns )
\     mov     eax, # 1                \ if str1 > str2, return 1
\     jmp     short @@4
\ @@3:
\     mov     eax, # -1               \ if str1 < str2, return -1
\ @@4:
\     mov     ebx, eax
\     mov     edi, 0 [ebp]
\     mov     esi, 4 [ebp]
\     add     ebp, # 8
\     next    c;
\ #ENDIF

:Class FindFile                 <Super Object

max-path bytes findpath
32       bytes findspecs

:M FindFirstFile:   ( addr cnt -- ior )  \ ior = 0 = success
                    find-first-file nip
                    ;M

:M FindNextFile:     ( -- ior ) \ ior = 0 = success
                     find-next-file nip ;M

:M FindClose:        ( -- ior ) \ ior = 0 = success
                     find-close drop ;M

:M GetFileAttributes:  ( -- n )
                       _Win32-Find-Data @ ;M

:M GetFileName:        ( -- adr cnt )
                       get-file-name zcount ;M

:M GetFileSize:         ( -- d )
                        get-file-size
                        ;M

:M ClassInit:           ( -- )
                        ClassInit: super
                        findpath max-path erase
                        s" *.*" findspecs place   \ default
                        ;M

: .or..?            ( -- f ) \ is found file directories . or ..?
                        GetFileName: self drop c@ '.' = ;

:M IsDirectory?:        ( -- f ) \ exclude . and ..
                        GetFileAttributes: self FILE_ATTRIBUTE_DIRECTORY and 0<>
                        .or..? not and
                        ;M

:M IsFile?:             ( -- f )
                        GetFileAttributes: self FILE_ATTRIBUTE_DIRECTORY and 0=
                        ;M

:M SetUp:               ( pathstr len spec$ cnt -- )
\ pathstr len = pointer to path to search
\ spec$ cnt = file specs to search for
                        dup 0=
                        if      2drop s" *.*"
                        then    31 min 0max findspecs place
                        findpath place ;M

:M FindFiles:           ( -- f ) \ specs should be already setup
                        new$ >r
                        findpath count r@ place
                        findspecs count dup
                        if      r@ ?+\
                        then    r@ +place
                        r> count FindFirstFile: self
                        ;M

:M FullPath:           ( -- addr cnt ) \ return full path of directory found
                        findpath count new$ dup>r place
                        GetFileName: self dup
                        if      r@ ?+\
                        then    r@ +place
                        r> count
                        ;M

;Class

:Class FolderItem           <super Object

max-path 1+ bytes itemname
int iconhandle
cell bytes index

\ save information for each individual file
Record: Win32_Find_Data
         int   FileAttributes
         int   FileCreationTimeLow
         int   FileCreationTimeHigh
         int   FileLastAccessTimeLow
         int   FileLastAccessTimeHigh
         int   FileLastWriteTimeLow
         int   FileLastWriteTimeHigh
         int   FileSizeHigh
         int   FileSizeLow
         int   Reserved0
         int   Reserved1
max-path bytes FileName
      14 bytes AlternateFileName
;RecordSize: sizeof(Win32_Find_Data)

:M GetFileAttributes:  ( -- n )
                       FileAttributes ;M

:M GetFileName:        ( -- adr cnt )
                       FileName zcount ;M

:M GetModifiedTime:	( -- ) \ return info in file-time-buf
			FileLastWriteTimeLow file-time-buf !
			FileLastWriteTimeHigh file-time-buf cell+ !
			;M

:M GetFileSize:         ( -- d )
                        FileSizeLow
                        ;M

: .or..?            ( -- f ) \ is found file directories . or ..?
                        GetFileName: self drop c@ '.' = ;

:M IsFile?:             ( -- f )
                        GetFileAttributes: self FILE_ATTRIBUTE_DIRECTORY and 0=
                        ;M

:M IsDirectory?:        ( -- f ) \ exclude . and ..
                        IsFile?: self not
                        .or..? not and
                        ;M

:M Classinit:   ( -- )
            Classinit: super
            Win32_Find_Data sizeof(Win32_Find_Data) erase
            0 to iconhandle
            -1 index !
            ;M

:M GetData: ( -- addr cnt ) \ access for any additional information needed
            Win32_Find_Data sizeof(Win32_Find_Data) ;M

:M setup: ( addr cnt -- ) \ assumes name is set for FindFirstFile, FindNextFile etc.
            itemname max-path erase
            max-path min 0max itemname swap move
            \ transfer the info
            _Win32-Find-Data Win32_Find_Data sizeof(Win32_Find_Data) move
            index itemname conhndl Call ExtractAssociatedIcon to iconhandle
            ;M

:M GetName: ( -- addrz )
        itemname ;M

:M GetName$: ( -- addr cnt )
        itemname zcount ;M

:M iconhandle: ( -- n )
               iconhandle ;M

;Class

:Class TreeList     <super linked-list

:M DeleteItem: { item \ flag -- }
                Data@: self 0= ?exitm
                false to flag
                #Links: self 1+ 1
                ?do      i >Link#: self Data@: self item =
                         if     0 Data!: self DeleteLink: self
                                item dispose
                                true to flag   \ mark as found
                                leave
                         then
                loop     flag 0= abort" Item not found in list!"
                ;M

:M total:  ( -- n )
            Data@: self
            if      #links: self
            else    0
            then    ;M

:M GetItem: { n -- obj | -1 }
        -1 total: self 0= ?exitm
        n 1 total: self between not ?exitm
        drop n >Link#: self Data@: self ;M

;Class

:Class FolderListView <super ListView

:M WindowStyle: ( -- style )
        WindowStyle: super
        [ LVS_REPORT LVS_SHOWSELALWAYS OR ] literal or
        ;M

;Class

:Class FolderViewer              <Super Child-Window

LV_COLUMN lvc
LV_ITEM LvItem
FolderListView TheView
FindFile FileFinder
int itemindex
int FolderList
int ThisItem            \ temp pointer to new item
int hwndSmallIcons           \ handle to imagelist for small icons
int hwndLargeIcons
int sortorder
int OnSelect          \ called when an item is clicked
int On_Update           \ called when folder tree is refreshed
int On_DblClick
int SelectedItem        \ list item object
int show-files?         \ do we want to display files?
int show-dirs?		\ show directories?
int #dirs               \ number of directories found when updating
int #fls                \ ditto files
int hwndlabel           \ handle to window to display path
int popup?
\ number of files shown is limited only by available memory
\ however only first 4k will be sorted. Of course the buffer size could always be increased
16 1024 * constant recbuffer-size
recbuffer-size cell / constant max-recs  \ about 4000 files and directories for sorting
int recbuffer       \ pointer to memory used for sorting

max-path 1+ bytes Treepath
\ path: thespecs
2 cells Class-allot
max-path 1+ bytes thespecs

: rootdir?  { pathstr cnt -- f } \ f = true if path is at root
            pathstr cnt + 2 - w@ s" :\" drop w@ = ?dup ?exit
            pathstr cnt + 1- c@ ':' = ;


: free-recbuffer  ( -- )
                  recbuffer ?dup
                  if        release
                            0 to recbuffer
                  then      ;

: InitTheViewColumns ( -- )
        LVCF_FMT LVCF_WIDTH LVCF_TEXT LVCF_SUBITEM or or or   Setmask: lvc
        LVCFMT_LEFT                                            Setfmt: lvc
        180                                                     Setcx: lvc
        z" Name"              		SetpszText: lvc
        Addr: lvc 0               	InsertColumn: TheView

        LVCF_FMT LVCF_WIDTH LVCF_TEXT LVCF_SUBITEM or or or   Setmask: lvc
        LVCFMT_RIGHT	                                       Setfmt: lvc
        120                                                     Setcx: lvc
        z" Size"               		SetpszText: lvc
        Addr: lvc swap 1+               InsertColumn: TheView


        LVCF_FMT LVCF_WIDTH LVCF_TEXT LVCF_SUBITEM or or or   Setmask: lvc
        LVCFMT_RIGHT	                                       Setfmt: lvc
        120                                                     Setcx: lvc
        z" Date"                 	SetpszText: lvc
        Addr: lvc swap 1+         	InsertColumn: TheView

        LVCF_FMT LVCF_WIDTH LVCF_TEXT LVCF_SUBITEM or or or   Setmask: lvc
        LVCFMT_RIGHT	                                       Setfmt: lvc
        80                                                      Setcx: lvc
        z" Time"                 	SetpszText: lvc
        Addr: lvc swap 1+         	InsertColumn: TheView drop

        ;

: CreateSmallImageList ( -- )    \ create small image list for list control
            total: folderlist               \ maximum images
            dup                             \ number of images to use
            ILC_COLOR16                         \ color depth
	    SM_CYSMICON	Call GetSystemMetrics  \ height of small icon
	    SM_CXSMICON Call GetSystemMetrics  \ width of small icon
            Call ImageList_Create to hwndSmallIcons
            \ do the following BEFORE adding any icons
            Color: WHITE hwndSmallIcons Call ImageList_SetBkColor drop
            ;

: CreateLargeImageList ( -- )    \ create large image list for listview control
            total: folderlist               \ maximum images
            dup                             \ number of images to use
            ILC_COLOR16                         \ color depth
 	    SM_CYICON Call GetSystemMetrics  \ height of large icon
 	    SM_CXICON Call GetSystemMetrics  \ width of large icon
            Call ImageList_Create to hwndLargeIcons
            \ do the following BEFORE adding any icons
            Color: WHITE hwndLargeIcons Call ImageList_SetBkColor drop
            ;

: DestroyImageLists	 ( -- )
        hwndSmallIcons ?dup
        if      Call ImageList_Destroy drop
		0 to hwndSmallIcons
        then    hwndLargeIcons ?dup
        if      Call ImageList_Destroy drop
		0 to hwndLargeIcons
        then    ;

: add-small-icons { \ item -- }         \ add icon for each file
	    CreateSmallImageList
            total: folderlist 1+ 1
            ?do    i >Link#: FolderList
                   Data@: FolderList to item
                   IconHandle: item
                   hwndSmallIcons Call ImageList_AddIcon drop
            loop   ;

: add-large-icons { \ item -- }         \ add icon for each file
	    CreateLargeImageList
            total: folderlist 1+ 1
            ?do    i >Link#: FolderList
                   Data@: FolderList to item
                   IconHandle: item
                   hwndLargeIcons Call ImageList_AddIcon drop
            loop   ;


: AddFile   ( str cnt -- )
        Data@: FolderList
        if  AddLink: FolderList
        then    New> FolderItem dup Data!: FolderList to ThisItem
        ( str cnt ) SetUp: ThisItem ;

: get-date-and-time	( obj -- timestr cnt datestr cnt )
		GetModifiedTime: [ ]
		pad file-time-buf Call FileTimeToLocalFileTime drop
		time-buf pad Call FileTimeToSystemTime drop
                31 time$ z" h':'mm':'tt"
                time-buf null LOCALE_USER_DEFAULT
                call GetTimeFormat time$ swap 1-	\ timestr cnt
                31 date$  z" MM'/'dd'/'yyyy"
                time-buf null LOCALE_USER_DEFAULT
                call GetDateFormat date$ swap 1- 	\ datestr cnt
                ;

: AddViewItem { ndx \ obj -- }
	ndx 1+ GetItem: FolderList to obj
\ first add the name
        LVIF_TEXT LVIF_PARAM or LVIF_IMAGE or SetMask: LvItem
        ndx                     SetiItem:   LvItem
        obj                     SetlParam:  LvItem
        ndx			SetIImage: Lvitem
        GetFileName: obj drop     SetpszText:  LvItem
        Addr: LvItem InsertItem: TheView drop
\ now we add subitems.
\ size
        LVIF_TEXT SetMask: LvItem
        ndx                     SetiItem:   LvItem
        1			SetiSubItem: LVItem
        IsFile?: obj
        if	GetFileSize: obj 0 (ud,.) asciiz
        else	z" "	\ show no size for directories
        then	SetpszText: LvItem
        Addr: LvItem ndx SetItemText: TheView drop

        obj get-date-and-time
\ date
        LVIF_TEXT SetMask: LvItem
        ndx                     SetiItem:   LvItem
        2			SetiSubItem: LVItem
        ( date )  asciiz  SetpszText: LvItem
        Addr: LvItem ndx SetItemText: TheView drop
\ time
        LVIF_TEXT SetMask: LvItem
        ndx                     SetiItem:   LvItem
        3			SetiSubItem: LVItem
        ( time ) asciiz  SetpszText: LvItem
        Addr: LvItem ndx SetItemText: TheView drop

	;

: show-files     ( -- )  \ add file and stats to the listviewbox
		DeleteAllItems: TheView drop
		DestroyImageLists
                add-small-icons
                hwndSmallIcons  LVSIL_SMALL SetImageList: TheView drop
                add-large-icons
                hwndLargeIcons LVSIL_NORMAL SetImageList: TheView drop
                Total: FolderList dup SetItemCount: TheView drop
                0
                ?do     i AddViewItem      loop ;

:M start:   ( parent -- )
            start: super
            new> treelist to folderlist
            recbuffer-size malloc to recbuffer
            ;M

:M On_Init: ( -- )
            self Start: TheView
            InitTheViewColumns
            ViewPopupBar SetPopupBar: self
            ;M

:M On_Size:     ( -- )
                0 0 GetSize: self Move: TheView ;M

:M Classinit:   ( -- )
                Classinit: super
                treepath off
                -1 thespecs 2 cells - !
                0 thespecs cell- !
                s" *.*" thespecs place
                ['] drop to OnSelect
                ['] drop to On_Update
                ['] drop to On_DblClick
                0 to SelectedItem
                0 to hwndSmallIcons
                0 to hwndLargeIcons
                true to show-files?
                true to show-dirs?
                true to popup?
                -1 to itemindex
                0 to #dirs
                0 to #fls
                0 to hwndlabel
                0 to recbuffer
                NextID to id
                SortAscending: [ self ] ;M

: DisposeTheList ( -- )
            FolderList
            if      Folderlist DisposeList
                    FolderList Dispose
                    0 to FolderList
            then    ;

:M ~:   ( -- )
        DisposeTheList
        free-recbuffer ;M

:M Close: ( -- )
        DisposeTheList
        free-recbuffer
        DestroyImageLists
        ;M

: finddirs	( -- )
                0 to #dirs
                TreePath count s" *.*" Setup: FileFinder
                FindFiles: FileFinder
                begin   0=
                while   IsDirectory?: FileFinder
                        if      FullPath: FileFinder AddFile
                                1 +to #dirs
                        then    FindNextFile: FileFinder
                repeat  FindClose: FileFinder ;

: findfiles	( -- )
                0 to #fls
                thespecs first-path"
                begin   dup 0>
                while   TreePath count 2swap SetUp: FileFinder
                        FindFiles: FileFinder
                        begin       0=
                        while       IsFile?: FileFinder
                                    if      FullPath: FileFinder AddFile
                                            1 +to #fls
                                    then    FindNextFile: FileFinder
                        repeat      FindClose: FileFinder
                        thespecs next-path"
                repeat  2drop ;

: FindAllFiles  ( -- )
                show-dirs?
                if	finddirs
                then	show-files?
                if	findfiles
                then	;

: recbuffer()   ( n -- addr )
                recbuffer +cells ;

: dosortorder   ( n -- f )
                sortorder null-check execute ;

: compare-recs  ( n1 n2 -- f )
                GetFileName: [ swap ]
                GetFileName: [ rot ]  caps-compare ( compareia ) dosortorder ;

: readrecbuffer ( -- )  \ load temporary buffer with record pointers
                >FirstLink: FolderList
                total: FolderList max-recs min 0max 0
                ?do     Data@: FolderList i recbuffer() !
                        >NextLink: FolderList
                loop    ;

: writerecbuffer ( -- ) \ rewrite sorted records to database
                >FirstLink: FolderList
                total: FolderList max-recs min 0max 0
                ?do     i recbuffer() @ Data!: FolderList
                        >NextLink: FolderList
                loop    ;

: sortfiles     ( -- )
                recbuffer 0= ?exit                       \ if not allocated abort sorting
                [']  compare-recs is precedes            \ set sort comparator
                total: folderlist 2 < ?exit
                readrecbuffer                            \ load buffer
                #dirs 1 >
                if      0 recbuffer() #dirs sort         \ sort the directories
                then    #fls 1 >
                if      #dirs recbuffer() #fls sort      \ and the files
                then    writerecbuffer ;

:M Setpath: { addr cnt -- }  \ check for valid path
            addr cnt + 2 - w@ 0x5C3A =         \ are the last chars ':\' i.e root dir?
            if   addr cnt treepath place
                 treepath +null
                 exitm
            then addr cnt 2dup + 1- c@ '\' =
            if	1-
            then find-first-file
            if	drop exitm     \ does not exist so exit
            then  @ FILE_ATTRIBUTE_DIRECTORY and     \ something was found
            if     addr cnt treepath place     \ it is a directory
                   treepath +null
            then   find-close drop ;M

:M Getpath: ( -- addr cnt )
            treepath count ;M

:M SetSpecs:    ( addr cnt -- ) \ can be multiple e.g "*.f;*.htm;*.txt"
                thespecs place ;M

:M GetSpecs:    ( -- addr cnt )
                thespecs count ;M

: show-path     ( -- )
                hwndlabel 0= ?exit
                hwndlabel Call IsWindow 0= ?exit
                treepath count asciiz 0 WM_SETTEXT hwndlabel send-window ;

:M UpdateFiles:   ( -- ) \ primary word, rebuild files list in view
                treepath c@ 0=
                if      current-dir$ count SetPath: self
                then    _Win32-Find-Data [ 11 cells max-path + 14 + ] LITERAL erase
                FolderList DisposeList
                0 to SelectedItem
                FindAllFiles
                SortFiles
                show-files
                show-path
                self On_Update null-check execute           \ user function
                ;M

:M Update:	( addr cnt -- )	\ combination
		SetPath: self
		UpdateFiles: self ;M

:M IsLabelHandle: ( hwnd -- ) \ a window that will display the current path after update
                  to hwndlabel ;M

:M SetViewMode:	( mode -- ) \ view mode ( LVS_ICON, LVS_SMALLICON, LVS_LIST, LVS_REPORT )
		GetStyle: TheView LVS_TYPEMASK invert and 	\ reset style
		or GWL_STYLE SetWindowLong: TheView drop ;M

:M SortAscending:   ( -- )
                ['] 0< to sortorder ;M

:M SortDescending:  ( -- )
                ['] 0> to sortorder ;M

:M DeleteFile:  ( -- ) \ delete selected file I think
                Selecteditem 0= ?exitm
                IsDirectory?: SelectedItem  ?exitm \ can't delete folder or root
                s" Delete " new$ dup>r place
                GetName$: SelectedItem r@ +place
                s" ?" r@ +place
                r@ +NULL
                r> 1+               ( sztext )
                z" Are you sure?"   ( ztitle )
                MB_YESNO            ( style  )
                MessageBox: parent IDNO = ?exitm
                GetName$: SelectedItem delete-file dup
                s" Delete file failed" ?MessageBox
                ?exitm
                0 to SelectedItem
                UpdateFiles: self ;M

:M SelectedItem:    ( -- n )
                    SelectedItem ;M

:M #Dirs:       ( -- n ) \ number of directories found during update
                #dirs ;M

:M #Files:      ( -- n ) \ number of files found during update
                #fls ;M

:M Showfiles:   ( f -- ) \ flag=true if showing files
                to show-files? ;M

:M ShowDirs:   ( f -- ) \ flag=true if showing directories in tree
                to show-dirs? ;M

:M IsOn_Update: ( cfa -- ) \ user function to execute after update of files
                to On_Update ;M

:M IsOnSelect: ( cfa -- ) \ user function to execute when a file or folder selected
                to OnSelect ;M

:M IsOn_DblClick: ( cfa -- ) \ user function to execute when file is double clicked
                to On_DblClick ;M

:M ShowPopup:	( f -- )	\ do we want popup window on right click?
		to popup? ;M

:M ChooseFolder: ( -- )   \ change folder programatically, also available by right clicking
                 hwnd 0= ?exitm
                 z" Select a drive or folder"
                 \ use a copy of path because if cancelled path info is changed to null
                 GetPath: self pad place
                 pad hwnd BrowseForFolder
                 if       pad count Update: Self
                 then     ;M

: ?descend       ( --)
                SelectedItem 0= ?exitm
                IsDirectory?: SelectedItem
                if	GetName$: SelectedItem Update: self
		else	SelectedItem On_DblClick null-check execute
		then	;

:M ascend:      ( -- ) \ move up one level in the directory tree
                GetPath: self 2dup rootdir?
                if      2drop exitm
                then    2dup + swap '\' -scan drop over - Update: Self
                ;M

: check-view	( -- )
		GetStyle: TheView LVS_TYPEMASK  and
		dup LVS_ICON = Check: mnuli
		dup LVS_REPORT = Check: mnurpt
		dup LVS_LIST = Check: mnulst
		    LVS_SMALLICON = Check: mnusi  ;

: show-popup	( -- )
                CurrentPopup
                if	self to ThisViewer
			check-view
                        hwnd get-mouse-xy hwnd Track: CurrentPopup
                then	;

:M WM_NOTIFY    { h m w l \ ncode -- f }
                l @  GetHandle: TheView <> if false exitm then
                l 2 cells+ @ to ncode
		ncode
		case
				LVN_ITEMCHANGED  of	l LVN_GetNotifyParam to SelectedItem
							l LVN_GetNotifyItem dup itemindex <>
							if	to itemindex
								SelectedItem OnSelect null-check execute \ call only once
							else	drop
							then
						endof
				NM_RCLICK 	of	popup? if show-popup then
						endof
				NM_DBLCLK	of	?descend
						endof
		endcase
		false
                ;M

:M GetListView:	( -- obj )
		Addr: TheView ;M

;Class

\s

Index: FileLister.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/FileLister.f,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
*** FileLister.f	13 Oct 2006 03:50:29 -0000	1.6
--- FileLister.f	30 Dec 2007 03:41:08 -0000	1.7
***************
*** 339,343 ****
              total: folderlist 2 +              \ maximum images
              dup 2 max                          \ number of images to use
!             ILC_COLOR4                         \ color depth
              18 16                              \ bitmap size height,width
              Call ImageList_Create to hwndimage ;
--- 339,343 ----
              total: folderlist 2 +              \ maximum images
              dup 2 max                          \ number of images to use
!             ILC_COLOR16                         \ color depth
              18 16                              \ bitmap size height,width
              Call ImageList_Create to hwndimage ;

Index: eStruct.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/eStruct.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** eStruct.f	11 Jul 2005 10:37:11 -0000	1.2
--- eStruct.f	30 Dec 2007 03:41:09 -0000	1.3
***************
*** 269,273 ****
                  zeroID ;
  
! : size>         ( <name> -- )
                  ' >body cell+ @ @
                  state @
--- 269,273 ----
                  zeroID ;
  
! : size>         ( <name> -- n )
                  ' >body cell+ @ @
                  state @
***************
*** 275,279 ****
                  then    ; immediate
  
! : addrof>       ( <name> -- )
                  ' >body  @
                  state @
--- 275,279 ----
                  then    ; immediate
  
! : addrof>       ( <name> -- addr )
                  ' >body  @
                  state @
***************
*** 336,339 ****
--- 336,342 ----
                  then    zeroID ;
  
+ : %get		( addr -- addr ) \ pointer to structure, allow setting structure memory block
+ 		member-id 0> not abort" Structures only!" ;
+ 
  : put           ( n1 n2 addr -- )     ( f:   n -- )
                  member-id 0 >= s" Needs member function!" ?abort
***************
*** 457,459 ****
  
  tst() dum()
- 

Re: [Win32forth-cvs] (no subject)

[<er...@te...>]

     =20
      Email =D2=C5=CB=CC=C1=CD=C1
  =20
                        =ED=CF=D3=CB=D7=C1 =C6=C9=D2=CD=D9            ~2 =
500 000=20
        =20
                  =ED=CF=D3=CB=D7=C1 =C6=C9=DA. =CC=C9=C3=C1            =
~5 000 000=20
        =20
                  =F2=CF=D3=D3=C9=D1 =E6=C9=D2=CD=D9            ~4 500 =
000=20
        =20
                  =F2=CF=D3=D3=C9=D1 =C6=C9=DA. =CC=C9=C3=C1            =
~7 000 000=20
        =20
                  =F7=D3=D1 =E2=C1=DA=C1 =F2=CF=D3=D3=C9=D1            =
=C2=CF=CC=C5=C5 ~ 12 000 000
        =20
           =F0=D2=CF=C6=C5=D3=D3=C9=CF=CE=C1=CC=D8=CE=CF =
=C2=D9=D3=D4=D2=CF =C9 =CB=C1=DE=C5=D3=D4=D7=C5=CE=CE=CF =
=D2=C1=DA=CF=DB=CC=C5=CD =F7=C1=DB=D5 =D2=C5=CB=CC=C1=CD=D5
      =E5=D6=C5=CE=C5=C4=C5=CC=D8=CE=D9=C5 =
=CF=C2=CE=CF=D7=CC=C5=CE=C9=D1 =C9 =C4=CF=D0=CF=CC=CE=C5=CE=C9=D1 =
=C2=C1=DA=20
      =F3=CF=D7=D2=C5=CD=C5=CE=CE=CF=C5 =
=CF=C2=CF=D2=D5=C4=CF=D7=C1=CE=C9=C5 =C9 =
=D0=D2=CF=C7=D2=C1=CD=CD=CE=CF=C5 =CF=C2=C5=D3=D0=C5=DE=C5=CE=C9=C5=20
      =E4=C9=DA=C1=CA=CE =CD=C1=CB=C5=D4=C1 =C2=C5=D3=D0=CC=C1=D4=CE=CF
      =F0=D2=C5=C4=D0=D2=C1=DA=C4=CE=C9=DE=CE=D9=C5 =C9 =
=D3=C5=DA=CF=CE=CE=D9=C5 =D3=CB=C9=C4=CB=C9
      =F3=C9=D3=D4=C5=CD=C1 =D3=CB=C9=C4=CF=CB =C4=CC=D1 =
=D0=CF=D3=D4=CF=D1=CE=CE=D9=C8 =CB=CC=C9=C5=CE=D4=CF=D7
      =E9=CE=C4=C9=D7=C9=C4=D5=C1=CC=D8=CE=D9=CA =D0=CF=C4=C8=CF=C4
      =E9=DD=C5=CD =D0=CF=D3=D4=CF=D1=CE=CE=D9=C8 =
=CB=CC=C9=C5=CE=D4=CF=D7!!!
       =E7=C1=D2=C1=CE=D4=C9=C9 =C9 =CF=D4=DE=C5=D4=D9
      =20
      =E4=CF=D0=CF=CC=CE=C9=D4=C5=CC=D8=CE=D9=C5 =D3=CB=C9=C4=CB=C9 =
=D0=D2=C9 =CF=D0=CC=C1=D4=C5 =C2=C5=DA=CE=C1=CC=D8=CE=D9=CD =C9 =
=DC=CC=C5=CB=D4=D2=CF=CE=CE=D9=CD =D0=CC=C1=D4=C5=D6=CF=CD.=20
     =20
      =20
      (495)=20
     648 6761  =20

[Win32forth-cvs] eletrami

[JASSEN G. <JAS...@ya...>]

be a big success in the pants when you enlarge your dick http://ramdare.com/

[Win32forth-cvs] Get the Job fast this one.

[Chang D. <fre...@li...>]

F A S T    T R A C K   D E G R E E   P R O G R A M  Obtain the degree you=
 deserve, based on your present knowledge and life experience. A prospero=
us future, money earning power, and the Admiration of all. Degrees from a=
n Established, Prestigious, Leading Institution. Your Degree will show ex=
actly what you really can do. Get the Job, Promotion, Business Opportunit=
y and Social Advancement you Desire! Eliminates classrooms and traveling.=
 Achieve your Bachelors, Masters, MBA, or PhDin the field of your experti=
se Professional and affordable Call now - your Graduation is a phone call=
 away. Please call:1-206-888-2083

[Win32forth-cvs] prologuizers

[Wela H. <sac...@zn...>]

Halloha,


  Virus found in this message, please delete it without futher reading  =20

=20

Not in the delicate and softe: and in those that nor he,
who speaks falsely or indulges in idle we were in the pantry.
antoinette was ill and.

[Win32forth-cvs] win32forth/demos/MiniDB EditDB.f, NONE, 1.1 MiniDB.f, NONE, 1.1 STARTDB.F, NONE, 1.1

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

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

Added Files:
	EditDB.f MiniDB.f STARTDB.F 
Log Message:
gah: New demo

--- NEW FILE: MiniDB.f ---
\ $Id: MiniDB.f,v 1.1 2007/12/07 20:40:17 georgeahubert Exp $

Anew -MiniDB.f

Needs ListView.f
Needs NoConsole.f
Needs Resources.f
Require startdb.f
Require EditDB.f

0 value turnkey?
20 constant FontHeight

: DoEdit   ( record# -- )
          Start: DBDialog ;

: DoAdd    ( -- )
          0 Start: DBDialog ;

\ ------------------------------------------------------------------------
\ Define the Listview for the database table
\ ------------------------------------------------------------------------
:object ListViewDB <super ListView

:M WindowStyle: ( -- style )
        WindowStyle: super
        [ LVS_REPORT LVS_SHOWSELALWAYS or LVS_SINGLESEL or ] literal or
        ;M

;object

\ ------------------------------------------------------------------------
\ Define the main window.
\ ------------------------------------------------------------------------
:Object SimpleDBWindow        <Super Window

0 value ToolBarHeight    \ set to height of toolbar if any
0 value StatusBarHeight  \ set to height of status bar if any
LV_COLUMN lvc
LV_ITEM LvItem
ButtonControl NewEntry

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

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

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

:M StartSize:   ( -- w h )
                screen-size >r 2/ r> 2/ ;M

:M On_Size:     ( -- )
                0 0 width height 20 -  Move: ListViewDB
                0 height 20 - width 20 Move: NewEntry
                ;M

:M On_Init:     ( -- )
                self Start: ListviewDB
                color: white SetBKColor: ListviewDB
                self               Start: NewEntry
                0 height 20 - width 20 Move: NewEntry
                s" New Record"       SetText: NewEntry
                ['] DoAdd     SetFunc: NewEntry
                ;M

:M On_Done:     ( h m w l -- res )
                Close: self
                turnkey? if 0 call PostQuitMessage drop then
                On_Done: super 0 ;M

: GetLParmItem  ( nItem  --  Lparm )
        LVIF_PARAM SetMask: LvItem
        SetiItem: LvItem
        Addr: LvItem GetItem: ListViewDB drop
        GetlParam: LvItem ;

: ItemEdit  ( -- )
        LVNI_SELECTED -1 GetNextItem:  ListViewDB dup  -1 =
        if   drop
        else GetLParmItem  DoEdit
        then ;

: HandleListViewDB   ( msg - )
        2 cells + @ case
        NM_DBLCLK of ItemEdit endof
        endcase ;

:M WM_NOTIFY    ( h m w l -- f )
        dup @ GetHandle: ListViewDB =
        if  HandleListViewDB
        then false
        ;M

:M InitListViewColumns: ( -- )

        LVCF_FMT LVCF_WIDTH LVCF_TEXT LVCF_SUBITEM or or or   Setmask: lvc
        LVCFMT_LEFT                                            Setfmt: lvc
        120                                                     Setcx: lvc

        fieldcnt: MiniDB ?dup if
        1 ?do
        i fieldname: MiniDB    drop SetpszText: lvc
        Addr: lvc i               InsertColumn: ListViewDB drop
        loop then
        ;M

:M InitListViewItems: ( -- )

        -1 begin
        fieldcnt: MiniDB ?dup if
        1 ?do
        LVIF_TEXT i 1 = if LVIF_PARAM or then SetMask:    LvItem

        i 1 = if 1+              SetiItem:   LvItem
        0 getint: MiniDB      SetlParam:  LvItem
        1 getstr: MiniDB drop SetpszText: LvItem
        Addr: LvItem             InsertItem: ListViewDB
        else
        dup                      SetiItem:    LvItem
        i 1-                     SetiSubItem: LvItem
        i getstr: MiniDB drop SetpszText:  LvItem
        Addr: LvItem  over       SetItemText: ListViewDB drop
        then
        loop then
        nextrow: MiniDB
        until drop ;M

:M RefreshListViewItems: ( -- )
        GetAllCustomers InitListViewItems: self paint: self ;m

;Object


\ Patch deferred words

:noname   ( -- )
          Dirty: DBDialog if
          s" INSERT OR REPLACE INTO Customers (id, name, sirname, abode) VALUES(?,?,?,?)"
          execute: MiniDB
          record#: DBDialog -if 0 bindint: MiniDB else 0 0 0 bindstr: MiniDB then
          BindText: DBDialog
          DeleteAllItems: ListViewDB
          GetAllCustomers
          InitListViewItems: SimpleDBWindow then
          close: DBDialog ; is Add-modifyDB

:noname   ( -- )
          close: DBDialog ; is RejectDB

: main  ( -- )
[ turnkey? ] [if] Start-database [then]
        Start: SimpleDBWindow
        GetAllCustomers
        InitListViewColumns: SimpleDBWindow
        InitListViewItems: SimpleDBWindow
        turnkey? if MessageLoop bye then
        true LVS_EX_FULLROWSELECT SetExtendedStyle: ListViewDB ;

turnkey? [if]
        NoConsoleIO  NoConsoleInImage
        ' main turnkey ListViewDemo.exe
        s" WIN32FOR.ICO" s" ListViewDemo.exe" AddAppIcon
        1 pause-seconds bye
[else]
         main
[then]

--- NEW FILE: EditDB.f ---
\ $Id: EditDB.f,v 1.1 2007/12/07 20:40:16 georgeahubert Exp $

\ Dialog for editing and adding to simple database. G. Hubert Friday, December 07 2007

Require TextBox.f  \ Use TextBoxes rather than EditControls for the extra methods.

defer Add-ModifyDB \ must be referenced outside of the dialog object
defer RejectDB     \ must be referenced outside of the dialog object

COLOR_BTNFACE call GetSysColor New-Color DialogColor

: InitDialogColor ( -- )
             COLOR_BTNFACE call GetSysColor InitColor: DialogColor ;

initialization-chain chain-add InitDialogColor

:Object DBDialog <super DialogWindow

int record#

StaticControl FirstLabel
StaticControl NameLabel
StaticControl AbodeLabel

TextBox First
TextBox Name
TextBox Abode

ButtonControl Accept
ButtonControl Reject

:M WindowStyle: ( -- style )
           WS_CAPTION WS_POPUPWINDOW or WS_CLIPCHILDREN or ;M

:M StartSize:   ( -- w h )
          250 160 ;m

:m Start: ( record# -- )
          to record#
          Start: Super ;m

:m On_Init: ( -- )
          record# if s" Editing Database" else s" Adding Record to Database" then
          SetTitle: self
          self Start: FirstLabel
          self Start: NameLabel
          self Start: AbodeLabel
          self Start: First
          self Start: Name
          self Start: Abode

          10  20  80  20 move: FirstLabel
          10  60  80  20 move: NameLabel
          10  100 80  20 move: AbodeLabel
          90  20  120 20 move: First
          90  60  120 20 move: Name
          90  100 120 20 move: Abode

          s" First Name:" SetText: FirstLabel
          s" Sirname:"    SetText: NameLabel
          s" Abode:"      SetText: AbodeLabel

          record# if
          s" SELECT * FROM Customers WHERE id = "
          new$ dup>r place
          record# (.) r@ +place r@ +null r> count
          execute: MiniDB

          1 getstr: MiniDB SetText: First
          2 getstr: MiniDB SetText: Name
          3 getstr: MiniDB SetText: Abode

          false SetModify: First
          false SetModify: Name
          false SetModify: Abode

          then
          IDOK               SetID: Accept
          self               Start: Accept
          10  130 100 25      Move: Accept
          s" Accept"       SetText: Accept
                          GetStyle: Accept
          BS_DEFPUSHBUTTON OR
                          SetStyle: Accept
          ['] Add-modifyDB SetFunc: Accept
          self               Start: Reject
          140  130 100 25     Move: Reject
          s" Reject"       SetText: Reject
          ['] RejectDB     SetFunc: Reject
          ;m

:M On_Paint:    ( -- )          \ screen redraw procedure
          0 0 width height ( LTGRAY ) DialogColor FillArea: dc
                ;M

:m record#:  ( -- record# )
          record# ;m

: BufferText ( addr len -- addr len )
          new$ dup>r place r@ +null r> count ;

:m BindText: ( -- )
          GetText: First BufferText 1 bindstr: MiniDB
          GetText: Name  BufferText 2 bindstr: MiniDB
          GetText: Abode BufferText 3 bindstr: MiniDB ;m

:m Dirty: ( -- f )
          IsModified?: First
          IsModified?: Name or
          IsModified?: Abode or ;m

;object



--- NEW FILE: STARTDB.F ---
\ $Id: STARTDB.F,v 1.1 2007/12/07 20:40:17 georgeahubert Exp $

\ Build the database if it doesn't already exist

require sqlite.f

SQLiteDB MiniDB

: Create-Customers-Table ( -- )
           s" CREATE TABLE Customers (id INTEGER PRIMARY KEY, name varchar, sirname varchar, abode varchar)"
           execute: MiniDB ;

: Add-Customers ( -- )

 s" INSERT INTO Customers (name, sirname, abode) VALUES(?,?,?)"
 execute: MiniDB
 s" Robin            "    0 bindstr: MiniDB
 s" Hood             "    1 bindstr: MiniDB
 s" Sherwood Forest  "    2 bindstr: MiniDB

 s" INSERT INTO Customers (name, sirname, abode) VALUES(?,?,?)"
 execute: MiniDB
 s" Isaac            "    0 bindstr: MiniDB
 s" Newton           "    1 bindstr: MiniDB
 s" Cambridge        "  2 bindstr: MiniDB

 s" INSERT INTO Customers (name, sirname, abode) VALUES(?,?,?)"
 execute: MiniDB
 s" Maid             "    0 bindstr: MiniDB
 s" Marian           "    1 bindstr: MiniDB
 s" Sherwood Forest  "    2 bindstr: MiniDB

 s" INSERT INTO Customers (name, sirname, abode) VALUES(?,?,?)"
 execute: MiniDB
 s" Friar            "    0 bindstr: MiniDB
 s" Tuck             "    1 bindstr: MiniDB
 s" Sherwood Forest  "    2 bindstr: MiniDB

 s" INSERT INTO Customers (name, sirname, abode) VALUES(?,?,?)"
 execute: MiniDB
 s" Will             "    0 bindstr: MiniDB
 s" Scarlet          "    1 bindstr: MiniDB
 s" Sherwood Forest  "    2 bindstr: MiniDB

 s" INSERT INTO Customers (name, sirname, abode) VALUES(?,?,?)"
 execute: MiniDB
 s" Alan A           "    0 bindstr: MiniDB
 s" Dale             "    1 bindstr: MiniDB
 s" Sherwood Forest  "    2 bindstr: MiniDB

 s" INSERT INTO Customers (name, sirname, abode) VALUES(?,?,?)"
 execute: MiniDB
 s" George           "    0 bindstr: MiniDB
 s" Hubert           "    1 bindstr: MiniDB
 s" UK               "    2 bindstr: MiniDB

 s" INSERT INTO Customers (name, sirname, abode) VALUES(?,?,?)"
 execute: MiniDB
 s" Queen            "    0 bindstr: MiniDB
 s" Elizabeth        "    1 bindstr: MiniDB
 s" Buckingham Palace"    2 bindstr: MiniDB
;

: Create-database ( -- )
           Create-Customers-Table Add-Customers ;

: Start-database ( -- )
           s" Mini.db" 2dup file-status nip -rot open: MiniDB
           if create-database then ;

: GetAllCustomers ( -- )
  s" SELECT * FROM Customers" execute: MiniDB ;

: qdump ( -- )
 fieldcnt: MiniDB
 0 ?do
   i fieldname: MiniDB type 20 #tab
 loop cr cr
 begin
   fieldcnt: MiniDB
   0 ?do
       i getstr: MiniDB type 20 #tab
   loop cr
   nextrow: MiniDB
 until ;

Start-database

GetAllCustomers

cr .( The database contains the following data.)

cr qdump

[Win32forth-cvs] win32forth/demos/MiniDB - New directory

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

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

Log Message:
Directory /cvsroot/win32forth/win32forth/demos/MiniDB added to the repository

[Win32forth-cvs] 0notab

[Brice P. <Pe...@th...>]

with the holidays around the corner, you still have time to get it delivered http://talww.com/

[Win32forth-cvs] WelcomeInternetPricesWorldwideShippingMoneybackPolicy

[Howard B. <al...@re...>]

mayonce . com

[Win32forth-cvs] aponized

[ODESSA p. <ODE...@bj...>]

you think she sucks good now? wait till you add a few inches

Tomiko derbyshire
http://www.ulkumfm.com/

[Win32forth-cvs] win32forth/src/console CommandWindow.f,1.3,1.4

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

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

Modified Files:
	CommandWindow.f 
Log Message:
Jos: Enabled the popu-menu

Index: CommandWindow.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/console/CommandWindow.f,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** CommandWindow.f	11 Nov 2007 01:01:18 -0000	1.3
--- CommandWindow.f	11 Nov 2007 14:04:47 -0000	1.4
***************
*** 519,522 ****
--- 519,526 ----
         ( winpause ) ;
  
+ :M WM_RBUTTONDOWN  ( h l  -- res )
+         MouseX MouseY  GetHandle: self Track: CurrentPopup  2drop 0
+         ;M
+ 
  :M Deselect: ( -- )
          0 to SelectedLength
***************
*** 838,841 ****
--- 842,846 ----
  :M ClassInit: ( -- )
          ClassInit: super
+         console-popup to CurrentPopup
          sizeof(LPWinScrollInfo) to cbSize
          SIF_ALL to fMask

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

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

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

Modified Files:
	Keysave.f 
Log Message:
Jos: Adapted for the old and new console.

Index: Keysave.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Keysave.f,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** Keysave.f	13 May 2007 07:52:26 -0000	1.5
--- Keysave.f	11 Nov 2007 01:02:40 -0000	1.6
***************
*** 501,505 ****
  ' _paste-load is paste-load
  
! : copy-console  { \ gblhndl gblptr b/l l/s len -- }
  \ *G Copy text to Windows clipboard
          marked? 0=
--- 501,505 ----
  ' _paste-load is paste-load
  
! : copy_console  { \ gblhndl gblptr b/l l/s len -- }
  \ *G Copy text to Windows clipboard
          marked? 0=
***************
*** 558,567 ****
          then    ;
  
! : cut-console   ( -- )
  \ *G Cut the complete text from the console window to the clipboard.
                  marked?
                  if      beep
!                 else    mark-all
!                         copy-console
                          cls
                  then    ;
--- 558,567 ----
          then    ;
  
! : cut_console   ( -- )
  \ *G Cut the complete text from the console window to the clipboard.
                  marked?
                  if      beep
!                 else    mark_all
!                         copy_console
                          cls
                  then    ;

[Win32forth-cvs] win32forth/src/console CommandWindow.f, 1.2, 1.3 Console2.f, 1.6, 1.7 ConsoleMenu.f, 1.10, 1.11 NewConsole.f, 1.3, 1.4

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

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

Modified Files:
	CommandWindow.f Console2.f ConsoleMenu.f NewConsole.f 
Log Message:
Jos: Enabled cut, paste, mark all and cut and clear from the menubar in the new console.

Index: NewConsole.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/console/NewConsole.f,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** NewConsole.f	1 Nov 2007 22:03:54 -0000	1.3
--- NewConsole.f	11 Nov 2007 01:01:18 -0000	1.4
***************
*** 206,212 ****
  
  : c_FGBG! ( color_object color_object -- )   SetBackground: cmd  SetForeground: cmd ;
! : c_FG@ ( -- color_object )   cmd.ForegroundColour ;
! : c_BG@ ( -- color_object )   cmd.BackgroundColour ;
! : c_&TheScreen ( -- a )   cmd.text ;
  
  14 Tablength: cmd
--- 206,216 ----
  
  : c_FGBG! ( color_object color_object -- )   SetBackground: cmd  SetForeground: cmd ;
! : c_FG@ ( -- color_object )     cmd.ForegroundColour ;
! : c_BG@ ( -- color_object )     cmd.BackgroundColour ;
! : c_&TheScreen  ( -- a )        cmd.text ;
! : MarkAll       ( - )           SelectAll: cmd ;
! : CopyConsole   ( - )                Copy: cmd ;
! : PasteLoad     ( - )               Paste: cmd ;
! : CutConsole   ( - )                  Cut: cmd ;
  
  14 Tablength: cmd
***************
*** 264,267 ****
--- 268,275 ----
          ['] c_&TheScreen IS &THE-SCREEN   \ #print-screen in dc.f will not work
                                            \ keysave not working
+         ['] MarkAll      is mark-all \ Used in the menu bar.
+         ['] CopyConsole  is copy-console
+         ['] PasteLoad    is paste-load
+         ['] CutConsole   is cut-console
          ;
  
***************
*** 303,306 ****
--- 311,318 ----
          ['] X_SETMAXCOLROW      IS SETMAXCOLROW
          ['] X_&THE-SCREEN       IS &THE-SCREEN
+         ['] mark_all            IS mark-all
+         ['] copy_console        IS copy-console
+         ['] _paste-load         IS paste-load
+         ['] cut_console         IS cut-console
          ;
  

Index: ConsoleMenu.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/console/ConsoleMenu.f,v
retrieving revision 1.10
retrieving revision 1.11
diff -C2 -d -r1.10 -r1.11
*** ConsoleMenu.f	12 May 2007 07:49:21 -0000	1.10
--- ConsoleMenu.f	11 Nov 2007 01:01:18 -0000	1.11
***************
*** 6,13 ****
--- 6,22 ----
  only forth also definitions
  
+ defer mark-all
+ ' mark_all     is mark-all
+ 
  in-application
  
  INTERNAL        \ internal definitions start here
  
+ defer copy-console
+ defer cut-console
+ 
+ ' copy_console is copy-console
+ ' cut_console  is cut-console
+ 
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

Index: CommandWindow.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/console/CommandWindow.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** CommandWindow.f	1 Nov 2007 22:03:54 -0000	1.2
--- CommandWindow.f	11 Nov 2007 01:01:18 -0000	1.3
***************
*** 3,7 ****
--- 3,9 ----
  Font CommandFont
  10 Height: CommandFont
+ \ FW_HEAVY Weight: CommandFont          \ Optional
  s" Courier" SetFaceName: CommandFont
+ \ s" Terminal" SetFaceName: CommandFont \ Optional choise
  
  
***************
*** 743,746 ****
--- 745,749 ----
          Copy: self
          ptrNull InsertText: self
+         DA: Self
          ;M
  
***************
*** 883,884 ****
--- 886,889 ----
  
  ;Class
+ 
+ 

Index: Console2.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/console/Console2.f,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
*** Console2.f	28 Sep 2006 10:16:48 -0000	1.6
--- Console2.f	11 Nov 2007 01:01:18 -0000	1.7
***************
*** 70,74 ****
                  mkstlin mkstcol mkedlin mkedcol markconsole ;
  
! : mark-all      ( -- )          \ makr all console text
                  0 to mkstlin
                  0 to mkstcol
--- 70,74 ----
                  mkstlin mkstcol mkedlin mkedcol markconsole ;
  
! : mark_all      ( -- )          \ makr all console text
                  0 to mkstlin
                  0 to mkstcol

[Win32forth-cvs] hcsredle

[Karima L. <LAN...@av...>]

hey darling win32forth-cvs
save the money you spend on hoes and get all the girls with a big dick
http://www.dideogon.com/

Karima LANTICAN

[Win32forth-cvs] win32forth/src/console BasicWin.f, 1.5, 1.6 CommandWindow.f, 1.1, 1.2 NewConsole.f, 1.2, 1.3 NoConsole.f, 1.8, 1.9 Statbar.f, 1.5, 1.6

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

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

Modified Files:
	BasicWin.f CommandWindow.f NewConsole.f NoConsole.f Statbar.f 
Log Message:
gah: Added $Id: $ identifiers

Index: Statbar.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/console/Statbar.f,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** Statbar.f	17 May 2006 20:13:33 -0000	1.5
--- Statbar.f	1 Nov 2007 22:03:54 -0000	1.6
***************
*** 1,2 ****
--- 1,4 ----
+ \ $Id$
+ 
  \    File: Statbar.f
  \  Author: Jeff Kelm

Index: NewConsole.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/console/NewConsole.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** NewConsole.f	28 Oct 2007 15:51:17 -0000	1.2
--- NewConsole.f	1 Nov 2007 22:03:54 -0000	1.3
***************
*** 1,4 ****
  \ NewConsole.f      Console window to replace w32fConsole.dll
!                                                                   
  Needs CommandWindow.f
  
--- 1,6 ----
+ \ $Id$
+ 
  \ NewConsole.f      Console window to replace w32fConsole.dll
! 
  Needs CommandWindow.f
  
***************
*** 142,147 ****
  : c_cr ( -- )    crlf$ count c_type ;
  : c_?cr ( n -- )   CharsNotFit: cmd IF  c_cr  THEN ;
! \ : c_cls ( -- )  ZeroText: cmd 0  caretX: cmd ptrNull +ztext: cmd  paint: cmd  updateVscroll: cmd   ;  
! : c_cls ( -- )  DA: cmd ;  
  : c_getcolrow ( -- col row )   VisibleColRow: cmd ;
  : c_getxy ( -- x y )   LastColRow: cmd ;
--- 144,149 ----
  : c_cr ( -- )    crlf$ count c_type ;
  : c_?cr ( n -- )   CharsNotFit: cmd IF  c_cr  THEN ;
! \ : c_cls ( -- )  ZeroText: cmd 0  caretX: cmd ptrNull +ztext: cmd  paint: cmd  updateVscroll: cmd   ;
! : c_cls ( -- )  DA: cmd ;
  : c_getcolrow ( -- col row )   VisibleColRow: cmd ;
  : c_getxy ( -- x y )   LastColRow: cmd ;
***************
*** 178,182 ****
          prompt: cmd  ShowCaret: cmd
          KeyBufferEmpty: cmd IF  BEGIN  c_key?  UNTIL  THEN  Hidecaret: cmd
!         GetKey: cmd 
          cmd.CaretX 1- CaretX: cmd
          KeysOn: cmd
--- 180,184 ----
          prompt: cmd  ShowCaret: cmd
          KeyBufferEmpty: cmd IF  BEGIN  c_key?  UNTIL  THEN  Hidecaret: cmd
!         GetKey: cmd
          cmd.CaretX 1- CaretX: cmd
          KeysOn: cmd
***************
*** 188,192 ****
  \        prompt: cmd
          KeyBufferEmpty: cmd IF  BEGIN  c_key?  UNTIL  THEN
!         GetKey: cmd 
  \        cmd.CaretX 1- CaretX: cmd
          KeysOn: cmd
--- 190,194 ----
  \        prompt: cmd
          KeyBufferEmpty: cmd IF  BEGIN  c_key?  UNTIL  THEN
!         GetKey: cmd
  \        cmd.CaretX 1- CaretX: cmd
          KeysOn: cmd
***************
*** 252,256 ****
          ['] c_BG@ IS BG@
             ['] K_NOOP2 IS CHARWH      \ no
!            ['] 2DROP   IS SETCHARWH   \ no  
             ['] 2DROP   IS SETCOLROW   \ no
             ['] DROP    IS SET-CURSOR  \ no  big-cursor, norm-cursor ???
--- 254,258 ----
          ['] c_BG@ IS BG@
             ['] K_NOOP2 IS CHARWH      \ no
!            ['] 2DROP   IS SETCHARWH   \ no
             ['] 2DROP   IS SETCOLROW   \ no
             ['] DROP    IS SET-CURSOR  \ no  big-cursor, norm-cursor ???
***************
*** 303,307 ****
          ;
  
! : NN    NewConsole 
          0 call SetFocus drop
          SetFocus: ConsoleWindow ;
--- 305,309 ----
          ;
  
! : NN    NewConsole
          0 call SetFocus drop
          SetFocus: ConsoleWindow ;

Index: NoConsole.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/console/NoConsole.f,v
retrieving revision 1.8
retrieving revision 1.9
diff -C2 -d -r1.8 -r1.9
*** NoConsole.f	31 Oct 2007 18:51:39 -0000	1.8
--- NoConsole.f	1 Nov 2007 22:03:54 -0000	1.9
***************
*** 1,2 ****
--- 1,4 ----
+ \ $Id$
+ 
  \   File: NoConsole.f
  \ Author: Dirk Busch      di...@wi...

Index: CommandWindow.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/console/CommandWindow.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** CommandWindow.f	28 Oct 2007 13:02:18 -0000	1.1
--- CommandWindow.f	1 Nov 2007 22:03:54 -0000	1.2
***************
*** 1,3 ****
! \ CommandWindow.f
  
  Font CommandFont
--- 1,3 ----
! \ $Id$
  
  Font CommandFont
***************
*** 244,248 ****
          r>  ScrollPos.top + ;
  
! :M UpdateVScroll: ( -- )    
          Top: ScrollPos negate to nPos
          Top: ScrollRange to nMin
--- 244,248 ----
          r>  ScrollPos.top + ;
  
! :M UpdateVScroll: ( -- )
          Top: ScrollPos negate to nPos
          Top: ScrollRange to nMin
***************
*** 255,259 ****
          ;M
  
! :M UpdateHScroll: ( -- )   
          Left: ScrollPos negate to nPos
          Left: ScrollRange  to nMin
--- 255,259 ----
          ;M
  
! :M UpdateHScroll: ( -- )
          Left: ScrollPos negate to nPos
          Left: ScrollRange  to nMin
***************
*** 272,276 ****
              Bottom: ScrollRange - Top: ScrollPos -  max
              dup  ScrollPos 4 + +!  0 swap Scroll: self
! \            Update: self 
              UpdateVScroll: self
          THEN
--- 272,276 ----
              Bottom: ScrollRange - Top: ScrollPos -  max
              dup  ScrollPos 4 + +!  0 swap Scroll: self
! \            Update: self
              UpdateVScroll: self
          THEN
***************
*** 286,290 ****
              SB_PAGEUP        OF      VertPage                      ENDOF
              SB_THUMBTRACK    OF      dup negate  Top: ScrollPos -  ENDOF
!             ( default case)	       0 swap 
          ENDCASE
          VScroll
--- 286,290 ----
              SB_PAGEUP        OF      VertPage                      ENDOF
              SB_THUMBTRACK    OF      dup negate  Top: ScrollPos -  ENDOF
!             ( default case)	       0 swap
          ENDCASE
          VScroll
***************
*** 296,302 ****
          IF
              Left: ScrollPos negate min  Right: ScrollPage
!             Right: ScrollRange - Left: ScrollPos -  max  
              dup  ScrollPos +!  0 Scroll: self
!             Update: self 
              UpdateHScroll: self
          THEN
--- 296,302 ----
          IF
              Left: ScrollPos negate min  Right: ScrollPage
!             Right: ScrollRange - Left: ScrollPos -  max
              dup  ScrollPos +!  0 Scroll: self
!             Update: self
              UpdateHScroll: self
          THEN
***************
*** 318,322 ****
          ;M
  
! :M WM_MOUSEWHEEL ( h m w l -- res )   over word-split 32768 and 
          \ get the Key flags (loword of wParam) and the WHEEL_DELTA (hiword of wParam)
          \ A positive value indicates that the wheel was rotated forward, away
--- 318,322 ----
          ;M
  
! :M WM_MOUSEWHEEL ( h m w l -- res )   over word-split 32768 and
          \ get the Key flags (loword of wParam) and the WHEEL_DELTA (hiword of wParam)
          \ A positive value indicates that the wheel was rotated forward, away
***************
*** 359,363 ****
          CaretStart caretX +  TextEnd #chars - CaretStart -
          GetHandle: dc call GetTabbedTextExtent
!         loword scrollpos.left + iLeftMargin + 
          vertline  lines 1- * scrollpos.top +
          width iLeftMargin + iRightMargin + height setrect: CaretPos
--- 359,363 ----
          CaretStart caretX +  TextEnd #chars - CaretStart -
          GetHandle: dc call GetTabbedTextExtent
!         loword scrollpos.left + iLeftMargin +
          vertline  lines 1- * scrollpos.top +
          width iLeftMargin + iRightMargin + height setrect: CaretPos
***************
*** 389,393 ****
          ScrollRange -1 Text GetHandle: dc call DrawTextEx  VertLine / to lines
          DRAWTEXTPARAMS  DT_NOCLIP   DT_EXPANDTABS or DT_TABSTOP or DT_NOPREFIX or
!         ScrollPos   -1 Text GetHandle: dc call DrawTextEx  drop 
  
  \ Set the caret on the commandline (last line)
--- 389,393 ----
          ScrollRange -1 Text GetHandle: dc call DrawTextEx  VertLine / to lines
          DRAWTEXTPARAMS  DT_NOCLIP   DT_EXPANDTABS or DT_TABSTOP or DT_NOPREFIX or
!         ScrollPos   -1 Text GetHandle: dc call DrawTextEx  drop
  
  \ Set the caret on the commandline (last line)
***************
*** 442,446 ****
  ((
  :M gt: ( x a n -- n )
!         get-dc  hFont SetFont: dc        
          GetTabbedCharsFromPoint
          release-dc
--- 442,446 ----
  ((
  :M gt: ( x a n -- n )
!         get-dc  hFont SetFont: dc
          GetTabbedCharsFromPoint
          release-dc
***************
*** 449,453 ****
  : GetColRow ( X Y -- col row )   \ needs dc
          ScrollRange.bottom min scrollpos.top - VertLine / lines 1- min  0max  >r
!         ScrollRange.right  iRightMargin - ( HorzLine + )   min scrollpos.left - iLeftMargin - 
          r@ RowAddress r@ RowLength GetTabbedCharsFromPoint
          r@ RowLength min  r>  ;
--- 449,453 ----
  : GetColRow ( X Y -- col row )   \ needs dc
          ScrollRange.bottom min scrollpos.top - VertLine / lines 1- min  0max  >r
!         ScrollRange.right  iRightMargin - ( HorzLine + )   min scrollpos.left - iLeftMargin -
          r@ RowAddress r@ RowLength GetTabbedCharsFromPoint
          r@ RowLength min  r>  ;
***************
*** 464,468 ****
          StartY EndY < dup
          IF
!             StartX width min  StartY  width     \ more than one line 
          ELSE
              StartX  StartY  EndX    \ one line only
--- 464,468 ----
          StartY EndY < dup
          IF
!             StartX width min  StartY  width     \ more than one line
          ELSE
              StartX  StartY  EndX    \ one line only
***************
*** 472,476 ****
  
          BEGIN  StartY EndY <
!         WHILE   
              0 StartY width  VertLine +to StartY  StartY   \ whole lines
              true UpdateRectangle
--- 472,476 ----
  
          BEGIN  StartY EndY <
!         WHILE
              0 StartY width  VertLine +to StartY  StartY   \ whole lines
              true UpdateRectangle
***************
*** 488,492 ****
  
  :M Select: ( col row -- )   \ select text from SelStart to SelEnd - col row
!         get-dc  hFont SetFont: dc        
          SelEndCol SelEndRow         \ previous SelEnd col row
          2swap to SelEndRow to SelEndCol
--- 488,492 ----
  
  :M Select: ( col row -- )   \ select text from SelStart to SelEnd - col row
!         get-dc  hFont SetFont: dc
          SelEndCol SelEndRow         \ previous SelEnd col row
          2swap to SelEndRow to SelEndCol
***************
*** 504,508 ****
              IF  SelEndCol SelStartCol -
              ELSE  0
!             THEN  to CaretLength  
          THEN
          release-dc
--- 504,508 ----
              IF  SelEndCol SelStartCol -
              ELSE  0
!             THEN  to CaretLength
          THEN
          release-dc
***************
*** 510,514 ****
  
  : On_Track ( h m -- h m )
!         get-dc  hFont SetFont: dc        
          MouseX MouseY GetColRow
          release-dc
--- 510,514 ----
  
  : On_Track ( h m -- h m )
!         get-dc  hFont SetFont: dc
          MouseX MouseY GetColRow
          release-dc
***************
*** 518,524 ****
  
  :M Deselect: ( -- )
!         0 to SelectedLength 
          0 to CaretLength
!         get-dc  hFont SetFont: dc        
          SelStartCol SelStartRow ColRow>XY  ScrollAdjust
          SelEndCol SelEndRow ColRow>XY  ScrollAdjust
--- 518,524 ----
  
  :M Deselect: ( -- )
!         0 to SelectedLength
          0 to CaretLength
!         get-dc  hFont SetFont: dc
          SelStartCol SelStartRow ColRow>XY  ScrollAdjust
          SelEndCol SelEndRow ColRow>XY  ScrollAdjust
***************
*** 528,532 ****
  
  : SetStart ( x y -- )
!         get-dc  hFont SetFont: dc        
          GetColRow  2dup to SelStartRow to SelStartCol  2dup to SelEndRow to SelEndCol  2dup ColRow>XY to SelEndY to SelEndX
          over >r  OnCommandLine
--- 528,532 ----
  
  : SetStart ( x y -- )
!         get-dc  hFont SetFont: dc
          GetColRow  2dup to SelStartRow to SelStartCol  2dup to SelEndRow to SelEndCol  2dup ColRow>XY to SelEndY to SelEndX
          over >r  OnCommandLine
***************
*** 583,587 ****
          ;M
  :M DR: ( a n -- )
!         ptrNull 0 2swap ReplaceGivenText: self 
          paint: self
          Update: self
--- 583,587 ----
          ;M
  :M DR: ( a n -- )
!         ptrNull 0 2swap ReplaceGivenText: self
          paint: self
          Update: self
***************
*** 589,593 ****
          UpdateHScroll: self
          ;M
!    
  :M ReplaceText: { a n n1 n2 \ a1 -- }   \ replace selected range (on commandline) n1 n2 with string a n
          n1 n2 2dup min to n1 max to n2   \ make sure n2 > n1
--- 589,593 ----
          UpdateHScroll: self
          ;M
! 
  :M ReplaceText: { a n n1 n2 \ a1 -- }   \ replace selected range (on commandline) n1 n2 with string a n
          n1 n2 2dup min to n1 max to n2   \ make sure n2 > n1
***************
*** 629,633 ****
          IF
              0 to CaretX  #chars to CaretLength
!             ptrNull InsertText: self 
              true CaretPos InvalidateRect: self
          THEN
--- 629,633 ----
          IF
              0 to CaretX  #chars to CaretLength
!             ptrNull InsertText: self
              true CaretPos InvalidateRect: self
          THEN
***************
*** 646,650 ****
  :M ForwardDelete: ( -- )
          SelStartCol SelStartRow OnCommandLine IF
!         #chars CaretX > 
          IF
              CaretLength 0= IF  1 to CaretLength  THEN
--- 646,650 ----
  :M ForwardDelete: ( -- )
          SelStartCol SelStartRow OnCommandLine IF
!         #chars CaretX >
          IF
              CaretLength 0= IF  1 to CaretLength  THEN
***************
*** 668,672 ****
          Text zcount dup>r + swap move
          0 text 2r> + + c!
!         0  ScrollRange.bottom ScrollPage.bottom min VertLine - 
          width height             \ update from previous line to bottom of window
          false UpdateRectangle    \ no erase background
--- 668,672 ----
          Text zcount dup>r + swap move
          0 text 2r> + + c!
!         0  ScrollRange.bottom ScrollPage.bottom min VertLine -
          width height             \ update from previous line to bottom of window
          false UpdateRectangle    \ no erase background
***************
*** 715,720 ****
  :M Paste: ( -- )   \ paste only the first line (less CR) in commandline
          CF_TEXT call IsClipboardFormatAvailable
!         IF   
!             hWnd call OpenClipboard drop   
              CF_TEXT call GetClipboardData
              dup call GlobalLock zcount
--- 715,720 ----
  :M Paste: ( -- )   \ paste only the first line (less CR) in commandline
          CF_TEXT call IsClipboardFormatAvailable
!         IF
!             hWnd call OpenClipboard drop
              CF_TEXT call GetClipboardData
              dup call GlobalLock zcount
***************
*** 729,735 ****
          SelectedLength
          IF
!             hWnd call OpenClipboard drop   
              call EmptyClipboard drop
!             SelectedLength 1+ GMEM_DDESHARE call GlobalAlloc  
              dup Call GlobalLock  dup SelectedLength 1+ erase
              SelectedAddress over SelectedLength move
--- 729,735 ----
          SelectedLength
          IF
!             hWnd call OpenClipboard drop
              call EmptyClipboard drop
!             SelectedLength 1+ GMEM_DDESHARE call GlobalAlloc
              dup Call GlobalLock  dup SelectedLength 1+ erase
              SelectedAddress over SelectedLength move
***************
*** 772,776 ****
          THEN  ScrollAdjust  SetSelection ;M
  
! :M ShiftRight:  ( -- )   SelEndCol SelEndRow lines 1- dup RowLength  swap d= IF exitm THEN  SelEndCol SelEndRow RowLength  = 
          IF    0 SelEndX SelEndY VertLine + nip
          ELSE  get-dc  hFont SetFont: dc  SelEndCol 1+ SelEndRow  ColRow>XY  release-dc
--- 772,776 ----
          THEN  ScrollAdjust  SetSelection ;M
  
! :M ShiftRight:  ( -- )   SelEndCol SelEndRow lines 1- dup RowLength  swap d= IF exitm THEN  SelEndCol SelEndRow RowLength  =
          IF    0 SelEndX SelEndY VertLine + nip
          ELSE  get-dc  hFont SetFont: dc  SelEndCol 1+ SelEndRow  ColRow>XY  release-dc
***************
*** 791,797 ****
          EndCase
          ;M
!         
  :M WM_CHAR ( h m w l -- res )
!         over  KeysOn 
          IF  HandleChar: self  ELSE  dup 27 = IF  true to Abort?  THEN  PutKey: self
          ELSE  false to Abort?
--- 791,797 ----
          EndCase
          ;M
! 
  :M WM_CHAR ( h m w l -- res )
!         over  KeysOn
          IF  HandleChar: self  ELSE  dup 27 = IF  true to Abort?  THEN  PutKey: self
          ELSE  false to Abort?
***************
*** 800,804 ****
  
  :M HandleKeyDown: ( n -- )
!         CASE 
              VK_HOME    of  ?shift IF  0 0 ?control IF  CtrlShiftHome: self  ELSE  ShiftHome: self  THEN  ELSE  SB_TOP    WM_HSCROLL  THEN  endof
              VK_END     of  ?shift IF  0 0 ?control IF  CtrlShiftEnd: self   ELSE  ShiftEnd: self   THEN  ELSE  SB_BOTTOM WM_HSCROLL  THEN  endof
--- 800,804 ----
  
  :M HandleKeyDown: ( n -- )
!         CASE
              VK_HOME    of  ?shift IF  0 0 ?control IF  CtrlShiftHome: self  ELSE  ShiftHome: self  THEN  ELSE  SB_TOP    WM_HSCROLL  THEN  endof
              VK_END     of  ?shift IF  0 0 ?control IF  CtrlShiftEnd: self   ELSE  ShiftEnd: self   THEN  ELSE  SB_BOTTOM WM_HSCROLL  THEN  endof

Index: BasicWin.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/console/BasicWin.f,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** BasicWin.f	7 Nov 2006 11:24:29 -0000	1.5
--- BasicWin.f	1 Nov 2007 22:03:54 -0000	1.6
***************
*** 1,2 ****
--- 1,4 ----
+ \ $Id$
+ 
  \    File: BasicWin.f
  \  Author: Jeff Kelm