Menu
▾
▴
win32forth-cvs — CVS Commit List
You can subscribe to this list here.
| 2004 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
(70) |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2005 |
Jan
(38) |
Feb
(4) |
Mar
(11) |
Apr
(49) |
May
(81) |
Jun
(65) |
Jul
(36) |
Aug
(57) |
Sep
(63) |
Oct
(57) |
Nov
(49) |
Dec
(41) |
| 2006 |
Jan
(75) |
Feb
(80) |
Mar
(10) |
Apr
(13) |
May
(100) |
Jun
(100) |
Jul
(77) |
Aug
(87) |
Sep
(80) |
Oct
(124) |
Nov
(39) |
Dec
(41) |
| 2007 |
Jan
(20) |
Feb
(32) |
Mar
(32) |
Apr
(43) |
May
(146) |
Jun
(40) |
Jul
(49) |
Aug
(33) |
Sep
(25) |
Oct
(19) |
Nov
(11) |
Dec
(8) |
| 2008 |
Jan
(4) |
Feb
(11) |
Mar
(31) |
Apr
(40) |
May
(34) |
Jun
(24) |
Jul
(39) |
Aug
(104) |
Sep
(27) |
Oct
(35) |
Nov
(34) |
Dec
(97) |
| 2009 |
Jan
(75) |
Feb
(29) |
Mar
(45) |
Apr
(76) |
May
(121) |
Jun
(103) |
Jul
(67) |
Aug
(28) |
Sep
(22) |
Oct
(39) |
Nov
(9) |
Dec
(15) |
| 2010 |
Jan
(7) |
Feb
(39) |
Mar
(40) |
Apr
(57) |
May
(67) |
Jun
(69) |
Jul
(49) |
Aug
(68) |
Sep
(22) |
Oct
(7) |
Nov
(2) |
Dec
(10) |
| 2011 |
Jan
|
Feb
|
Mar
(10) |
Apr
(4) |
May
(6) |
Jun
(10) |
Jul
(16) |
Aug
(23) |
Sep
(9) |
Oct
|
Nov
(28) |
Dec
(3) |
| 2012 |
Jan
(11) |
Feb
(10) |
Mar
(1) |
Apr
|
May
(4) |
Jun
(3) |
Jul
(3) |
Aug
(4) |
Sep
(2) |
Oct
|
Nov
|
Dec
(1) |
| 2013 |
Jan
|
Feb
(7) |
Mar
(30) |
Apr
(4) |
May
(4) |
Jun
(8) |
Jul
(10) |
Aug
(4) |
Sep
|
Oct
(2) |
Nov
(24) |
Dec
(13) |
| 2014 |
Jan
(7) |
Feb
(2) |
Mar
|
Apr
(1) |
May
(9) |
Jun
|
Jul
(3) |
Aug
(9) |
Sep
|
Oct
(2) |
Nov
|
Dec
(3) |
| 2015 |
Jan
(4) |
Feb
(2) |
Mar
|
Apr
|
May
|
Jun
(1) |
Jul
|
Aug
(5) |
Sep
(1) |
Oct
(4) |
Nov
(7) |
Dec
(39) |
| 2016 |
Jan
(17) |
Feb
(2) |
Mar
(2) |
Apr
|
May
(1) |
Jun
(1) |
Jul
|
Aug
|
Sep
|
Oct
|
Nov
(1) |
Dec
(2) |
| 2017 |
Jan
|
Feb
(3) |
Mar
|
Apr
|
May
(1) |
Jun
(2) |
Jul
|
Aug
(3) |
Sep
|
Oct
|
Nov
|
Dec
(2) |
| 2018 |
Jan
|
Feb
|
Mar
(2) |
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
| 2019 |
Jan
|
Feb
|
Mar
(1) |
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
| 2022 |
Jan
|
Feb
|
Mar
|
Apr
|
May
(1) |
Jun
|
Jul
|
Aug
|
Sep
(1) |
Oct
(2) |
Nov
(1) |
Dec
(1) |
| 2023 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
(1) |
Sep
|
Oct
(1) |
Nov
|
Dec
|
| 2025 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
(1) |
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
|
From: Dirk B. <db...@us...> - 2006-05-06 12:31:28
|
Update of /cvsroot/win32forth/win32forth/demos In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv16888/demos Modified Files: ListViewDemo.f Log Message: Removed some of my bad mods... Index: ListViewDemo.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/demos/ListViewDemo.f,v retrieving revision 1.9 retrieving revision 1.10 diff -C2 -d -r1.9 -r1.10 *** ListViewDemo.f 6 May 2006 07:59:48 -0000 1.9 --- ListViewDemo.f 6 May 2006 12:31:16 -0000 1.10 *************** *** 26,29 **** --- 26,34 ---- ;M + :M On_Init: ( -- ) + \ CS_DBLCLKS only to prevent flicker in window on sizing. + CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop + ;M + ;object *************** *** 38,41 **** --- 43,51 ---- ;M + :M On_Init: ( -- ) + \ CS_DBLCLKS only to prevent flicker in window on sizing. + CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop + ;M + ;object *************** *** 52,63 **** out$ ;M - :M WindowStyle: ( -- style ) - WindowStyle: Super - - \ CS_DBLCLKS to prevent flicker in window on sizing. - \ (But why should this be needed, to prevent flicker?!? - \ Samstag, Mai 06 2006 dbu) - CS_DBLCLKS or ;M - :M ExWindowStyle: ( -- style ) ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M --- 62,65 ---- *************** *** 68,71 **** --- 70,76 ---- s" Courier" SetFaceName: vFont Create: vFont + + \ CS_DBLCLKS only to prevent flicker in window on sizing. + CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop ;M *************** *** 158,161 **** --- 163,171 ---- ;M + :M On_Init: ( -- ) + \ CS_DBLCLKS only to prevent flicker in window on sizing. + CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop + ;M + ;Object *************** *** 181,184 **** --- 191,199 ---- ;M + :M On_Init: ( -- ) + \ CS_DBLCLKS only to prevent flicker in window on sizing. + CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop + ;M + ;Object *************** *** 207,210 **** --- 222,230 ---- ;M + :M On_Init: ( -- ) + \ CS_DBLCLKS only to prevent flicker in window on sizing. + CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop + ;M + ;Object *************** *** 294,302 **** :M WindowStyle: ( -- style ) WindowStyle: Super ! ! \ CS_DBLCLKS to prevent flicker in window on sizing. ! \ (But why should this be needed, to prevent flicker?!? ! \ Samstag, Mai 06 2006 dbu) ! [ WS_CLIPCHILDREN CS_DBLCLKS or ] literal or ;M :M StartSize: ( -- w h ) --- 314,318 ---- :M WindowStyle: ( -- style ) WindowStyle: Super ! WS_CLIPCHILDREN or ;M :M StartSize: ( -- w h ) *************** *** 312,315 **** --- 328,334 ---- self Start: Splitter self OnInit \ perform user function + + \ CS_DBLCLKS only to prevent flicker in window on sizing. + CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop ;M |
|
From: Dirk B. <db...@us...> - 2006-05-06 07:59:51
|
Update of /cvsroot/win32forth/win32forth/demos In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv20709/demos Modified Files: ListViewDemo.f Log Message: Some minor mods. Index: ListViewDemo.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/demos/ListViewDemo.f,v retrieving revision 1.8 retrieving revision 1.9 diff -C2 -d -r1.8 -r1.9 *** ListViewDemo.f 5 May 2006 16:10:28 -0000 1.8 --- ListViewDemo.f 6 May 2006 07:59:48 -0000 1.9 *************** *** 52,55 **** --- 52,63 ---- out$ ;M + :M WindowStyle: ( -- style ) + WindowStyle: Super + + \ CS_DBLCLKS to prevent flicker in window on sizing. + \ (But why should this be needed, to prevent flicker?!? + \ Samstag, Mai 06 2006 dbu) + CS_DBLCLKS or ;M + :M ExWindowStyle: ( -- style ) ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M *************** *** 60,69 **** s" Courier" SetFaceName: vFont Create: vFont - \ prevent flicker in all child-windows on sizing - CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop ;M ! :M On_size: ( -- ) Paint: self ;M ! \ need to repaint in this child-window as the position of the text depends on its size :M On_Paint: ( -- ) --- 68,77 ---- s" Courier" SetFaceName: vFont Create: vFont ;M ! :M On_size: ( -- ) ! \ need to repaint in this child-window as the position of the ! \ text depends on its size ! Paint: self ;M :M On_Paint: ( -- ) *************** *** 202,207 **** 200 value LeftWidth ! 5 value thickness ! 30 value RightTopHeight \ ------------------------------------------------------------------------ --- 210,215 ---- 200 value LeftWidth ! 2 value thickness ! 30 value RightTopHeight \ ------------------------------------------------------------------------ *************** *** 216,221 **** int mousedown? ! : LeftHeight ( -- n ) Height StatusBarHeight - ToolBarHeight - ; ! : RightBottomHeight ( -- n ) Height StatusBarHeight - ToolBarHeight - RightTopHeight - ; : position-windows ( -- ) --- 224,232 ---- int mousedown? ! : LeftHeight ( -- n ) ! Height StatusBarHeight - ToolBarHeight - ; ! ! : RightBottomHeight ( -- n ) ! Height StatusBarHeight - ToolBarHeight - RightTopHeight - ; : position-windows ( -- ) *************** *** 226,230 **** self OnPosition ; ! : InSplitter? ( -- f1 ) \ is cursor on splitter window hWnd get-mouse-xy 0 height within --- 237,241 ---- self OnPosition ; ! : InSplitter? ( -- f1 ) \ is cursor on splitter window hWnd get-mouse-xy 0 height within *************** *** 233,237 **** \ mouse click routines for Main Window to track the Splitter movement ! : DoSizing ( -- ) mousedown? dragging? or 0= ?EXIT mousex ( 1+ ) width min thickness 2/ - to LeftWidth --- 244,248 ---- \ mouse click routines for Main Window to track the Splitter movement ! : DoSizing ( -- ) mousedown? dragging? or 0= ?EXIT mousex ( 1+ ) width min thickness 2/ - to LeftWidth *************** *** 239,243 **** WINPAUSE ; ! : On_clicked ( -- ) mousedown? 0= IF hWnd Call SetCapture drop THEN true to mousedown? --- 250,254 ---- WINPAUSE ; ! : On_clicked ( -- ) mousedown? 0= IF hWnd Call SetCapture drop THEN true to mousedown? *************** *** 278,285 **** ;M ! :M WindowHasMenu: ( -- f ) true ;M ! :M WindowStyle: ( -- style ) ! WindowStyle: Super WS_CLIPCHILDREN or ;M :M StartSize: ( -- w h ) --- 289,302 ---- ;M ! :M WindowHasMenu: ( -- f ) ! true ;M ! :M WindowStyle: ( -- style ) ! WindowStyle: Super ! ! \ CS_DBLCLKS to prevent flicker in window on sizing. ! \ (But why should this be needed, to prevent flicker?!? ! \ Samstag, Mai 06 2006 dbu) ! [ WS_CLIPCHILDREN CS_DBLCLKS or ] literal or ;M :M StartSize: ( -- w h ) *************** *** 290,303 **** :M On_Init: ( -- ) - 395 Setid: LeftPane self Start: LeftPane - 396 Setid: RightTopPane self Start: RightTopPane - 397 Setid: RightBottomPane self Start: RightBottomPane self Start: Splitter self OnInit \ perform user function - \ prevent flicker in window on sizing - CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop ;M --- 307,315 ---- |
|
From: Dirk B. <db...@us...> - 2006-05-06 07:59:51
|
Update of /cvsroot/win32forth/win32forth/doc In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv20709/doc Modified Files: p-relnotes.6.12.htm Log Message: Some minor mods. Index: p-relnotes.6.12.htm =================================================================== RCS file: /cvsroot/win32forth/win32forth/doc/p-relnotes.6.12.htm,v retrieving revision 1.8 retrieving revision 1.9 diff -C2 -d -r1.8 -r1.9 *** p-relnotes.6.12.htm 9 Feb 2006 18:01:44 -0000 1.8 --- p-relnotes.6.12.htm 6 May 2006 07:59:48 -0000 1.9 *************** *** 161,164 **** --- 161,166 ---- </pre><p> </li> + <li><a href="../src/lib/ListView.f">ListView Control</a> + </li> </ul> *************** *** 212,215 **** --- 214,219 ---- <li>demos\GdiDemo\*.f - Various demos for the new GDI class library. Most of them were original written by David R. Pochin.</li> + <li><a href="../demos/ListViewDemo.f">demos/ListViewDemo.f - Shows how to use the ListView control. Also shows how + to implement a Spliiter window</a></li> </ul> |
|
From: Rod O. <rod...@us...> - 2006-05-04 21:48:04
|
Update of /cvsroot/win32forth/win32forth/demos In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv21396/demos Modified Files: ListViewDemo.f Log Message: Rod: Splitter window modified to prevent flicker Index: ListViewDemo.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/demos/ListViewDemo.f,v retrieving revision 1.6 retrieving revision 1.7 diff -C2 -d -r1.6 -r1.7 *** ListViewDemo.f 3 May 2006 17:34:06 -0000 1.6 --- ListViewDemo.f 4 May 2006 21:47:59 -0000 1.7 *************** *** 1,2 **** --- 1,3 ---- + \ Splitter window modified to prevent flicker - May 4th, 2006 Rod \ ForthForm generated splitter-window template \ Modify according to your needs *************** *** 59,68 **** s" Courier" SetFaceName: vFont Create: vFont ;M :M On_Paint: ( -- ) GetSize: Self white Fillarea: dc Out$ c@ 0<> ! if SaveDC: dc \ save device context vFont SelectObject: dc ltblue SetTextColor: dc --- 60,75 ---- s" Courier" SetFaceName: vFont Create: vFont + \ prevent flicker in all child-windows on sizing + CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop ;M + :M On_size: ( -- ) Paint: self ;M + \ need to repaint in this child-window as the position of the text depends on its size + :M On_Paint: ( -- ) + SaveDC: dc \ save device context GetSize: Self white Fillarea: dc Out$ c@ 0<> ! if vFont SelectObject: dc ltblue SetTextColor: dc *************** *** 73,78 **** lparmLeft 0 (D.) pad +place pad +null pad count Textout: dc ! RestoreDC: dc ! then ;M :M ShowLeftSelected: ( Z$text Lparm flNew - ) --- 80,86 ---- lparmLeft 0 (D.) pad +place pad +null pad count Textout: dc ! then ! RestoreDC: dc ! ;M :M ShowLeftSelected: ( Z$text Lparm flNew - ) *************** *** 175,178 **** --- 183,209 ---- ENDBAR + + \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ + \ \\\\\ Splitter window \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ + \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ + + :Object Splitter <Super child-window + + :M WindowStyle: ( -- style ) \ return the window style + WindowStyle: super + WS_DISABLED or + WS_CLIPSIBLINGS or + ;M + + :M On_Paint: ( -- ) \ screen redraw method + 0 0 Width Height LTGRAY FillArea: dc + ;M + + ;Object + + 200 value LeftWidth + 5 value thickness + 30 value RightTopHeight + \ ------------------------------------------------------------------------ \ Define the the splitter window (this is the main window). *************** *** 180,261 **** :Object SplitterWindow <Super Window ! 0 value toolbarH \ set to height of toolbar if any ! 0 value statusbarH \ set to height of status bar if any ! 0 value clicked ! 0 value wline ! 0 value SeparatorX ! 0 value SeparatorY ! :M WindowStyle: ( -- style ) ! WindowStyle: Super WS_CLIPCHILDREN or ;M ! : position-windows ( -- ) \ auto adjust windows ! 0 toolbarH SeparatorX 1- Height toolbarH - statusbarH - Move: LeftPane ! SeparatorX 2 + dup>r toolbarH Width r@ - SeparatorY 1- 25 min toolbarH - Move: RightTopPane ! r@ SeparatorY 2 + 25 min Width r> - Height 2 pick - statusbarH - Move: RightBottomPane ! self OnPosition ; ! : horizline ( -- ) ! \ SeparatorX 2+ SeparatorY MoveTo: dc ! \ Width SeparatorY LineTo: dc ! ; ! : vertline ( -- ) ! SeparatorX 0 MoveTo: dc ! SeparatorX Height LineTo: dc ; ! : ?line ( -- ) ! wline ! if vertline ! else horizline ! then ; ! : on_clicked ( -- ) ! true to clicked ! get-dc ! R2_NOT SetRop2: dc ! black LineColor: dc ! mousex SeparatorX = mousex SeparatorX 1+ = or ! if vertline true to wline ! else horizline false to wline ! then hwnd Call SetCapture drop ; ! : On_Mousemove ( -- ) ! mousex SeparatorX = ! mousex SeparatorX 1+ = or ! if SIZEWE-CURSOR exit ! then mousey Separatory = ! mousey Separatory 1+ = or ! if SIZENS-CURSOR ! else arrow-cursor ! then ; ! :M WM_MOUSEMOVE ( h w m l -- res ) ! WM_MOUSEMOVE WM: super ! on_mousemove ;M ! : dosizing ( -- ) ! clicked 0= ?exit ! ?line ! \ a minimum width of 4 pixels for windows are set, but it can be changed ! mousex 2 cells < mousex width 2 cells - > or ! mousey 2 cells < mousey height 2 cells - > or or ! if position-windows ! false to clicked ! release-dc ! hwnd Call ReleaseCapture ?win-error ! else wline ! if mousex to SeparatorX ! else mousey to SeparatorY ! then ?line ! then ; ! : on_unclicked ( -- ) ! clicked 0= ?exit ! ?line ! position-windows ! release-dc ! false to clicked ! hwnd Call ReleaseCapture ?win-error ; :M StartSize: ( -- w h ) --- 211,286 ---- :Object SplitterWindow <Super Window ! 0 value ToolBarHeight \ set to height of toolbar if any ! 0 value StatusBarHeight \ set to height of status bar if any ! int dragging? ! int mousedown? ! : LeftHeight ( -- n ) Height StatusBarHeight - ToolBarHeight - ; ! : RightBottomHeight ( -- n ) Height StatusBarHeight - ToolBarHeight - RightTopHeight - ; ! : position-windows ( -- ) ! 0 ToolBarHeight LeftWidth LeftHeight Move: LeftPane ! LeftWidth thickness + ToolBarHeight Width LeftWidth thickness + - RightTopHeight Move: RightTopPane ! LeftWidth thickness + ToolBarHeight RightTopHeight + Width LeftWidth thickness + - RightBottomHeight Move: RightBottomPane ! LeftWidth ToolBarHeight thickness LeftHeight Move: Splitter ! self OnPosition ; ! : InSplitter? ( -- f1 ) \ is cursor on splitter window ! hWnd get-mouse-xy ! 0 height within ! swap LeftWidth dup thickness + within and ; ! \ mouse click routines for Main Window to track the Splitter movement ! : DoSizing ( -- ) ! mousedown? dragging? or 0= ?EXIT ! mousex ( 1+ ) width min thickness 2/ - to LeftWidth ! position-windows ! WINPAUSE ; ! : On_clicked ( -- ) ! mousedown? 0= IF hWnd Call SetCapture drop THEN ! true to mousedown? ! InSplitter? to dragging? ! DoSizing ; ! : On_unclicked ( -- ) ! mousedown? IF Call ReleaseCapture drop THEN ! false to mousedown? ! false to dragging? ; ! : On_DblClick ( -- ) ! false to mousedown? ! InSplitter? 0= ?EXIT ! LeftWidth 8 > ! IF 0 thickness 2/ - to LeftWidth ! ELSE 132 Width 2/ min to LeftWidth ! THEN ! position-windows ! ; ! :M WM_SETCURSOR ( h m w l -- ) ! hWnd get-mouse-xy ! ToolBarHeight dup LeftHeight + within ! swap 0 width within and ! IF InSplitter? IF SIZEWE-CURSOR ELSE arrow-cursor THEN 1 ! ELSE DefWindowProc: self ! THEN ! ;M ! ! :M Classinit: ( -- ) ! ClassInit: super \ init super class ! TestBar to CurrentMenu ! ['] On_clicked SetClickFunc: self ! ['] On_unclicked SetUnClickFunc: self ! ['] DoSizing SetTrackFunc: self ! ['] On_DblClick SetDblClickFunc: self ! ;M ! ! :M WindowHasMenu: ( -- f ) true ;M ! ! :M WindowStyle: ( -- style ) ! WindowStyle: Super WS_CLIPCHILDREN or ;M :M StartSize: ( -- w h ) *************** *** 266,273 **** :M On_Init: ( -- ) - ['] dosizing to track-func - ['] on_clicked to click-func - ['] on_unclicked to unclick-func - 395 Setid: LeftPane self Start: LeftPane --- 291,294 ---- *************** *** 276,286 **** 397 Setid: RightBottomPane self Start: RightBottomPane ! self OnInit \ perform user function ! ! Startsize: self 2 / to SeparatorY 5 / to SeparatorX ! TestBar SetMenuBar: self ! ! position-windows ;M :M On_Done: ( h m w l -- res ) --- 297,305 ---- 397 Setid: RightBottomPane self Start: RightBottomPane ! self Start: Splitter self OnInit \ perform user function ! \ prevent flicker in window on sizing ! CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop ! ;M :M On_Done: ( h m w l -- res ) |
|
From: Jos v.d.V. <jo...@us...> - 2006-05-02 21:17:10
|
Update of /cvsroot/win32forth/win32forth/demos In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18199/demos Modified Files: ListViewDemo.f Log Message: Jos: Improved the text change for subitems. Index: ListViewDemo.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/demos/ListViewDemo.f,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** ListViewDemo.f 2 May 2006 15:55:48 -0000 1.4 --- ListViewDemo.f 2 May 2006 21:17:01 -0000 1.5 *************** *** 289,296 **** LVIF_TEXT SetMask: LvItem \ Inserting a subitem ! SetiItem: LvItem \ Uses the index from "Jack" 2 SetiSubItem: LvItem z" 2043 VD" SetpszText: LvItem ! Addr: LvItem SetItem: ListViewRightBottom --- 289,296 ---- LVIF_TEXT SetMask: LvItem \ Inserting a subitem ! dup>r SetiItem: LvItem \ Uses the index from "Jack" 2 SetiSubItem: LvItem z" 2043 VD" SetpszText: LvItem ! Addr: LvItem r> SetItemText: ListViewRightBottom |
|
From: Jos v.d.V. <jo...@us...> - 2006-05-02 21:16:32
|
Update of /cvsroot/win32forth/win32forth/src/lib In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv17817/src/lib Modified Files: Listview.f Log Message: Jos: Improved the text change for subitems. Index: Listview.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/lib/Listview.f,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** Listview.f 2 May 2006 12:14:49 -0000 1.3 --- Listview.f 2 May 2006 21:16:20 -0000 1.4 *************** *** 565,573 **** Addr: lv4 InsertItem: bb drop ! LVIF_TEXT SetMask: lv2 ! 1 SetiItem: lv2 ! 2 SetiSubItem: lv2 ! z" s0" SetpszText: lv2 ! Addr: lv2 SetItem: bb ; --- 565,573 ---- Addr: lv4 InsertItem: bb drop ! LVIF_TEXT SetMask: lv2 ! 1 >r SetiItem: lv2 ! 2 SetiSubItem: lv2 ! z" s0" SetpszText: lv2 ! Addr: lv2 r> SetItemText: bb \ SetItemText: is more reliable than SetItem: for subitems ; |
|
From: Jos v.d.V. <jo...@us...> - 2006-05-02 15:55:50
|
Update of /cvsroot/win32forth/win32forth/demos In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv32201/demos Modified Files: ListViewDemo.f Log Message: Jos: Corrected the updated item and the order of the columns right. Index: ListViewDemo.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/demos/ListViewDemo.f,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** ListViewDemo.f 2 May 2006 12:29:03 -0000 1.3 --- ListViewDemo.f 2 May 2006 15:55:48 -0000 1.4 *************** *** 80,84 **** ! : GetParmsItem ( nItem - Z$text Lparm flNew ) LVIF_TEXT LVIF_PARAM or SetMask: LvItem out$: RightTopPane SetpszText: LvItem --- 80,84 ---- ! : 0GetParmsItem ( nItem - Z$text Lparm flNew ) LVIF_TEXT LVIF_PARAM or SetMask: LvItem out$: RightTopPane SetpszText: LvItem *************** *** 92,95 **** --- 92,107 ---- ; + : GetParmsItem ( nItem - Z$text Lparm flNew ) + >r LVIF_TEXT LVIF_PARAM or SetMask: LvItem + out$: RightTopPane SetpszText: LvItem + maxstring SetcchTextMax: LvItem + r@ SetiItem: LvItem + Addr: LvItem GetItem: ListViewLeft drop out$: RightTopPane + GetlParam: LvItem r@ SelectedItemLeft <> + if r> to SelectedItemLeft true + else r>drop false + then + ; + : HandleListViewLeft ( msg - ) LVNI_SELECTED -1 GetNextItem: ListViewLeft dup -1 = *************** *** 308,327 **** z" Location" SetpszText: lvc ! Addr: lvc 1 InsertColumn: ListViewLeft z" Contact" SetpszText: lvc ! Addr: lvc swap InsertColumn: ListViewRightBottom z" Street and number" SetpszText: lvc ! Addr: lvc swap InsertColumn: ListViewRightBottom z" Postal code" SetpszText: lvc ! Addr: lvc swap InsertColumn: ListViewRightBottom z" Place" SetpszText: lvc ! Addr: lvc swap InsertColumn: ListViewRightBottom drop ; - :Class ListViewClass <Super Object --- 320,342 ---- z" Location" SetpszText: lvc ! Addr: lvc 1 InsertColumn: ListViewLeft drop ! ! LVCF_FMT LVCF_WIDTH LVCF_TEXT LVCF_SUBITEM or or or Setmask: lvc ! LVCFMT_LEFT Setfmt: lvc ! 120 Setcx: lvc z" Contact" SetpszText: lvc ! Addr: lvc 0 InsertColumn: ListViewRightBottom z" Street and number" SetpszText: lvc ! Addr: lvc swap 1+ InsertColumn: ListViewRightBottom z" Postal code" SetpszText: lvc ! Addr: lvc swap 1+ InsertColumn: ListViewRightBottom z" Place" SetpszText: lvc ! Addr: lvc swap 1+ InsertColumn: ListViewRightBottom drop ; :Class ListViewClass <Super Object |
|
From: Jos v.d.V. <jo...@us...> - 2006-05-02 12:29:11
|
Update of /cvsroot/win32forth/win32forth/demos In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv6718/demos Modified Files: ListViewDemo.f Log Message: Jos: Erase the topwindow before repainting it. Index: ListViewDemo.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/demos/ListViewDemo.f,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** ListViewDemo.f 2 May 2006 12:14:09 -0000 1.2 --- ListViewDemo.f 2 May 2006 12:29:03 -0000 1.3 *************** *** 39,45 **** :M On_Paint: ( -- ) Out$ c@ 0<> if SaveDC: dc \ save device context - GetSize: Self white Fillarea: dc vFont SelectObject: dc ltblue SetTextColor: dc --- 39,45 ---- :M On_Paint: ( -- ) + GetSize: Self white Fillarea: dc Out$ c@ 0<> if SaveDC: dc \ save device context vFont SelectObject: dc ltblue SetTextColor: dc |
|
From: Jos v.d.V. <jo...@us...> - 2006-05-02 12:21:44
|
Update of /cvsroot/win32forth/win32forth/apps/Player4 In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv1126/apps/Player4 Modified Files: PLAYER4.F Log Message: Jos: WS_CLIPCHILDREN reduced the flickering screeen Index: PLAYER4.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Player4/PLAYER4.F,v retrieving revision 1.44 retrieving revision 1.45 diff -C2 -d -r1.44 -r1.45 *** PLAYER4.F 19 Apr 2006 12:39:20 -0000 1.44 --- PLAYER4.F 2 May 2006 12:21:40 -0000 1.45 *************** *** 184,187 **** --- 184,189 ---- LoadAppIcon ;M + :M WindowStyle: ( -- style ) WindowStyle: Super WS_CLIPCHILDREN or ;M + : position-windows ( -- ) \ auto adjust windows 0 toolbarH SeparatorX @ 1- Height toolbarH - statusbarH - dup>r Move: Catalog |
|
From: Jos v.d.V. <jo...@us...> - 2006-05-02 12:14:54
|
Update of /cvsroot/win32forth/win32forth/src/lib In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv28500/src/lib Modified Files: Listview.f Log Message: Jos: Disabled the demo. Index: Listview.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/lib/Listview.f,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** Listview.f 2 May 2006 10:12:20 -0000 1.2 --- Listview.f 2 May 2006 12:14:49 -0000 1.3 *************** *** 467,471 **** ;Class ! \ s A simple demo: ( -------------------------------------------------------------------) --- 467,471 ---- ;Class ! \s A simple demo: ( -------------------------------------------------------------------) |
|
From: Jos v.d.V. <jo...@us...> - 2006-05-02 12:14:12
|
Update of /cvsroot/win32forth/win32forth/demos In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv28116/demos Modified Files: ListViewDemo.f Log Message: Jos: WS_CLIPCHILDREN reduces the flickering in the window Index: ListViewDemo.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/demos/ListViewDemo.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** ListViewDemo.f 2 May 2006 09:57:16 -0000 1.1 --- ListViewDemo.f 2 May 2006 12:14:09 -0000 1.2 *************** *** 142,155 **** 0 value SeparatorY ! :M ClassInit: ( -- ) ! ClassInit: super ! \ Insert your code here ! ;M - : 0position-windows ( -- ) \ auto adjust windows - 0 toolbarH SeparatorX 1- Height toolbarH - statusbarH - Move: LeftPane - SeparatorX 2+ dup>r toolbarH Width r@ - SeparatorY 1- toolbarH - Move: RightTopPane - r@ SeparatorY 2+ Width r> - Height 2 pick - statusbarH - Move: RightBottomPane - self OnPosition ; : position-windows ( -- ) \ auto adjust windows --- 142,149 ---- 0 value SeparatorY ! :M ClassInit: ( -- ) ClassInit: super ;M ! ! :M WindowStyle: ( -- style ) WindowStyle: Super WS_CLIPCHILDREN or ;M : position-windows ( -- ) \ auto adjust windows |
|
From: Jos v.d.V. <jo...@us...> - 2006-05-02 10:12:28
|
Update of /cvsroot/win32forth/win32forth/src/lib In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv940/src/lib Modified Files: Listview.f Log Message: Jos: Forget to update a few wrong stacknotations. Index: Listview.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/lib/Listview.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** Listview.f 2 May 2006 09:55:39 -0000 1.1 --- Listview.f 2 May 2006 10:12:20 -0000 1.2 *************** *** 33,42 **** :M Sizeof: ( -- n ) /NMHDR ;M ! :M GethwndFrom: ( -- ) hwndFrom ;M ! :M GetidFrom: ( -- ) idFrom ;M ! :M Getcode: ( -- ) code ;M ! :M SethwndFrom: ( -- ) to hwndFrom ;M ! :M SetidFrom: ( -- ) to idFrom ;M ! :M Setcode: ( -- ) to code ;M ;Class --- 33,42 ---- :M Sizeof: ( -- n ) /NMHDR ;M ! :M GethwndFrom: ( -- hwndFrom ) hwndFrom ;M ! :M GetidFrom: ( -- idFrom ) idFrom ;M ! :M Getcode: ( -- code ) code ;M ! :M SethwndFrom: ( hwndFrom -- ) to hwndFrom ;M ! :M SetidFrom: ( idFrom -- ) to idFrom ;M ! :M Setcode: ( code -- ) to code ;M ;Class *************** *** 62,84 **** :M Sizeof: ( -- n ) /LV_ITEM ;M ! :M GetMask: ( -- ) mask ;M ! :M GetiItem: ( -- ) iItem ;M ! :M GetiSubItem: ( -- ) iSubItem ;M ! :M Getstate: ( -- ) state ;M ! :M GetstateMask: ( -- ) stateMask ;M ! :M GetpszText: ( -- ) pszText ;M ! :M GetcchTextMax: ( -- ) cchTextMax ;M ! :M GetiImage: ( -- ) iImage ;M ! :M GetlParam: ( -- ) lParam ;M ! :M SetMask: ( -- ) _LV_ITEM /LV_ITEM erase to mask ;M ! :M SetiItem: ( -- ) to iItem ;M ! :M SetiSubItem: ( -- ) to iSubItem ;M ! :M Setstate: ( -- ) to state ;M ! :M SetstateMask: ( -- ) to stateMask ;M ! :M SetpszText: ( -- ) to pszText ;M ! :M SetcchTextMax: ( -- ) to cchTextMax ;M ! :M SetiImage: ( -- ) to iImage ;M ! :M SetlParam: ( -- ) to lParam ;M ;Class --- 62,84 ---- :M Sizeof: ( -- n ) /LV_ITEM ;M ! :M GetMask: ( -- mask ) mask ;M ! :M GetiItem: ( -- iItem ) iItem ;M ! :M GetiSubItem: ( -- iSubItem ) iSubItem ;M ! :M Getstate: ( -- state ) state ;M ! :M GetstateMask: ( -- stateMask ) stateMask ;M ! :M GetpszText: ( -- pszText ) pszText ;M ! :M GetcchTextMax: ( -- cchTextMax ) cchTextMax ;M ! :M GetiImage: ( -- iImage ) iImage ;M ! :M GetlParam: ( -- lParam) lParam ;M ! :M SetMask: ( mask -- ) _LV_ITEM /LV_ITEM erase to mask ;M ! :M SetiItem: ( iItem -- ) to iItem ;M ! :M SetiSubItem: ( iSubItem -- ) to iSubItem ;M ! :M Setstate: ( state -- ) to state ;M ! :M SetstateMask: ( stateMask -- ) to stateMask ;M ! :M SetpszText: ( pszText -- ) to pszText ;M ! :M SetcchTextMax: ( cchTextMax -- ) to cchTextMax ;M ! :M SetiImage: ( iImage -- ) to iImage ;M ! :M SetlParam: ( lParam-- ) to lParam ;M ;Class *************** *** 104,126 **** :M Sizeof: ( -- n ) /LV_DISPINFO ;M ! :M GetMask: ( -- ) mask ;M ! :M GetiItem: ( -- ) iItem ;M ! :M GetiSubItem: ( -- ) iSubItem ;M ! :M Getstate: ( -- ) state ;M ! :M GetstateMask: ( -- ) stateMask ;M ! :M GetpszText: ( -- ) pszText ;M ! :M GetcchTextMax: ( -- ) cchTextMax ;M ! :M GetiImage: ( -- ) iImage ;M ! :M GetlParam: ( -- ) lParam ;M ! :M SetMask: ( -- ) _LV_DISPINFO /LV_DISPINFO erase to mask ;M ! :M SetiItem: ( -- ) to iItem ;M ! :M SetiSubItem: ( -- ) to iSubItem ;M ! :M Setstate: ( -- ) to state ;M ! :M SetstateMask: ( -- ) to stateMask ;M ! :M SetpszText: ( -- ) to pszText ;M ! :M SetcchTextMax: ( -- ) to cchTextMax ;M ! :M SetiImage: ( -- ) to iImage ;M ! :M SetlParam: ( -- ) to lParam ;M ;Class --- 104,126 ---- :M Sizeof: ( -- n ) /LV_DISPINFO ;M ! :M GetMask: ( -- mask ) mask ;M ! :M GetiItem: ( -- iItem ) iItem ;M ! :M GetiSubItem: ( -- iSubItem ) iSubItem ;M ! :M Getstate: ( -- state ) state ;M ! :M GetstateMask: ( -- stateMask ) stateMask ;M ! :M GetpszText: ( -- pszText ) pszText ;M ! :M GetcchTextMax: ( -- cchTextMax ) cchTextMax ;M ! :M GetiImage: ( -- iImage ) iImage ;M ! :M GetlParam: ( -- lParam ) lParam ;M ! :M SetMask: ( mask -- ) _LV_DISPINFO /LV_DISPINFO erase to mask ;M ! :M SetiItem: ( iItem -- ) to iItem ;M ! :M SetiSubItem: ( iSubItem -- ) to iSubItem ;M ! :M Setstate: ( state -- ) to state ;M ! :M SetstateMask: ( stateMask -- ) to stateMask ;M ! :M SetpszText: ( pszText -- ) to pszText ;M ! :M SetcchTextMax: ( cchTextMax -- ) to cchTextMax ;M ! :M SetiImage: ( iImage -- ) to iImage ;M ! :M SetlParam: ( lParam -- ) to lParam ;M ;Class *************** *** 143,159 **** :M Sizeof: ( -- n ) /LV_COLUMN ;M ! :M Getmask: ( -- ) mask ;M ! :M Getfmt: ( -- ) fmt ;M ! :M Getcx: ( -- ) cx ;M ! :M GetpszText: ( -- ) pszText ;M ! :M GetcchTextMax: ( -- ) cchTextMax ;M ! :M GetiSubItem: ( -- ) iSubItem ;M ! :M Setmask: ( -- ) _LV_COLUMN /LV_COLUMN erase to mask ;M ! :M Setfmt: ( -- ) to fmt ;M ! :M Setcx: ( -- ) to cx ;M ! :M SetpszText: ( -- ) to pszText ;M ! :M SetcchTextMax: ( -- ) to cchTextMax ;M ! :M SetiSubItem: ( -- ) to iSubItem ;M ;Class --- 143,159 ---- :M Sizeof: ( -- n ) /LV_COLUMN ;M ! :M Getmask: ( -- mask ) mask ;M ! :M Getfmt: ( -- fmt ) fmt ;M ! :M Getcx: ( -- cx ) cx ;M ! :M GetpszText: ( -- pszText ) pszText ;M ! :M GetcchTextMax: ( -- cchTextMax ) cchTextMax ;M ! :M GetiSubItem: ( -- iSubItem ) iSubItem ;M ! :M Setmask: ( mask -- ) _LV_COLUMN /LV_COLUMN erase to mask ;M ! :M Setfmt: ( fmt -- ) to fmt ;M ! :M Setcx: ( cx -- ) to cx ;M ! :M SetpszText: ( pszText -- ) to pszText ;M ! :M SetcchTextMax: ( cchTextMax -- ) to cchTextMax ;M ! :M SetiSubItem: ( iSubItem -- ) to iSubItem ;M ;Class *************** *** 176,188 **** :M Sizeof: ( -- n ) /LV_FINDINFO ;M ! :M Getflags: ( -- ) flags ;M ! :M Getpsz: ( -- ) psz ;M ! :M GetlParam: ( -- ) lparam ;M ! :M GetvkDirection: ( -- ) vkDirection ;M ! :M Setflags: ( -- ) to flags ;M ! :M Setpsz: ( -- ) to psz ;M ! :M SetlParam: ( -- ) to lparam ;M ! :M SetvkDirection: ( -- ) to vkDirection ;M :M Getpt: ( -- x y ) x y ;M --- 176,188 ---- :M Sizeof: ( -- n ) /LV_FINDINFO ;M ! :M Getflags: ( -- flags ) flags ;M ! :M Getpsz: ( -- psz ) psz ;M ! :M GetlParam: ( -- lparam ) lparam ;M ! :M GetvkDirection: ( -- vkDirection ) vkDirection ;M ! :M Setflags: ( flags -- ) to flags ;M ! :M Setpsz: ( psz -- ) to psz ;M ! :M SetlParam: ( lparam -- ) to lparam ;M ! :M SetvkDirection: ( vkDirection -- ) to vkDirection ;M :M Getpt: ( -- x y ) x y ;M *************** *** 206,214 **** :M Sizeof: ( -- n ) /LV_HITTESTINFO ;M ! :M Getflags: ( -- ) flags ;M ! :M GetiItem: ( -- ) iItem ;M ! :M Setflags: ( -- ) to flags ;M ! :M SetiItem: ( -- ) to iItem ;M :M Getpt: ( -- x y ) x y ;M --- 206,214 ---- :M Sizeof: ( -- n ) /LV_HITTESTINFO ;M ! :M Getflags: ( -- flags ) flags ;M ! :M GetiItem: ( -- iItem ) iItem ;M ! :M Setflags: ( flags -- ) to flags ;M ! :M SetiItem: ( iItem -- ) to iItem ;M :M Getpt: ( -- x y ) x y ;M *************** *** 230,235 **** :M Sizeof: ( -- n ) /LV_KEYDOWN ;M ! :M GetwvKey: ( -- ) wVKey ;M ! :M Getflags: ( -- ) flags ;M :M SetwvKey: ( -- ) to wVKey ;M --- 230,235 ---- :M Sizeof: ( -- n ) /LV_KEYDOWN ;M ! :M GetwvKey: ( -- wVKey ) wVKey ;M ! :M Getflags: ( -- flags ) flags ;M :M SetwvKey: ( -- ) to wVKey ;M *************** *** 258,274 **** :M Sizeof: ( -- n ) /NM_LISTVIEW ;M ! :M GetiItem: ( -- ) iItem ;M ! :M GetiSubItem: ( -- ) iSubItem ;M ! :M GetuNewState: ( -- ) uNewState ;M ! :M GetuOldState: ( -- ) uOldState ;M ! :M GetuChanged: ( -- ) uChanged ;M ! :M GetlParam: ( -- ) lParam ;M ! :M SetiItem: ( -- ) to iItem ;M ! :M SetiSubItem: ( -- ) to iSubItem ;M ! :M SetuNewState: ( -- ) to uNewState ;M ! :M SetuOldState: ( -- ) to uOldState ;M ! :M SetuChanged: ( -- ) to uChanged ;M ! :M SetlParam: ( -- ) to lParam ;M :M Getpt: ( -- x y ) x y ;M --- 258,274 ---- :M Sizeof: ( -- n ) /NM_LISTVIEW ;M ! :M GetiItem: ( -- iItem ) iItem ;M ! :M GetiSubItem: ( -- iSubItem ) iSubItem ;M ! :M GetuNewState: ( -- uNewState ) uNewState ;M ! :M GetuOldState: ( -- uOldState ) uOldState ;M ! :M GetuChanged: ( -- uChanged ) uChanged ;M ! :M GetlParam: ( -- lParam ) lParam ;M ! :M SetiItem: ( iItem -- ) to iItem ;M ! :M SetiSubItem: ( iSubItem -- ) to iSubItem ;M ! :M SetuNewState: ( uNewState -- ) to uNewState ;M ! :M SetuOldState: ( uOldState -- ) to uOldState ;M ! :M SetuChanged: ( uChanged -- ) to uChanged ;M ! :M SetlParam: ( lParam -- ) to lParam ;M :M Getpt: ( -- x y ) x y ;M |
|
From: Jos v.d.V. <jo...@us...> - 2006-05-02 09:57:23
|
Update of /cvsroot/win32forth/win32forth/demos In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv22065/demos Added Files: ListViewDemo.f Log Message: Jos: A demo to show some interactions with a listview in a splitter window --- NEW FILE: ListViewDemo.f --- \ ForthForm generated splitter-window template \ Modify according to your needs \ A primarly demo to show some interactions with a ListView Anew -ListViewDemo Needs NoConsole.f Needs gdi/gdi.f Needs Resources.f Needs ListView.f 0 value turnkey? 0 value ListViewRightBottom 0 value ListViewLeft 20 constant FontHeight LV_ITEM LvItem \ LV_ITEM LvItem defer OnPosition ( window -- ) ' drop is OnPosition \ called when window panes are repositioned defer OnInit ( window -- ) ' drop is OnInit \ called during window On_init method \- 2+ : 2+ 2 + ; :Object RightTopPane <Super Child-Window int lparmLeft String: Out$ Font vFont :M out$: ( - adrOt$ ) out$ ;M :M ExWindowStyle: ( -- style ) ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M :M On_Init: ( -- ) 14 Width: vFont FontHeight Height: vFont s" Courier" SetFaceName: vFont Create: vFont ;M :M On_Paint: ( -- ) Out$ c@ 0<> if SaveDC: dc \ save device context GetSize: Self white Fillarea: dc vFont SelectObject: dc ltblue SetTextColor: dc TA_CENTER SetTextAlign: dc drop GetSize: self 10 - swap 2/ swap 4 / 2dup Out$ zcount pad place s" lParam:" pad +place lparmLeft 0 (D.) pad +place pad +null pad count Textout: dc RestoreDC: dc then ;M :M ShowLeftSelected: ( Z$text Lparm flNew - ) if to lparmLeft drop paint: Self else 2drop then ;M ;Object :Object LeftPane <Super Child-Window int SelectedItemLeft :M ExWindowStyle: ( -- style ) ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M :M On_Size: ( -- ) gethandle: ListViewLeft if 1 ( repaint flag ) tempRect.AddrOf GetClientRect: Self Bottom: tempRect Right: tempRect 0 0 gethandle: ListViewLeft Call MoveWindow drop then ;M : GetParmsItem ( nItem - Z$text Lparm flNew ) LVIF_TEXT LVIF_PARAM or SetMask: LvItem out$: RightTopPane SetpszText: LvItem maxstring SetcchTextMax: LvItem SetiItem: LvItem Addr: LvItem GetItem: ListViewLeft drop out$: RightTopPane GetlParam: LvItem dup SelectedItemLeft <> if dup to SelectedItemLeft true else false then ; : HandleListViewLeft ( msg - ) LVNI_SELECTED -1 GetNextItem: ListViewLeft dup -1 = if drop else GetParmsItem ShowLeftSelected: RightTopPane then ; :M WM_NOTIFY ( h m w l -- f ) dup @ GetHandle: ListViewLeft = \ EnableNotify? and if HandleListViewLeft then false ;M :M Start: ( - ) start: super -1 to SelectedItemLeft Self start: ListViewLeft ;M ;Object :Object RightBottomPane <Super Child-Window \ Modify this object according to your needs :M ExWindowStyle: ( -- style ) ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M :M On_Size: ( -- ) gethandle: ListViewRightBottom if 1 ( repaint flag ) tempRect.AddrOf GetClientRect: Self Bottom: tempRect Right: tempRect 0 0 gethandle: ListViewRightBottom Call MoveWindow drop then ;M :M Start: start: super Self start: ListViewRightBottom ;M ;Object MENUBAR TestBar POPUP "&File" MENUITEM "Bye" bye ; ENDBAR :Object SplitterWindow <Super Window 0 value toolbarH \ set to height of toolbar if any 0 value statusbarH \ set to height of status bar if any 0 value clicked 0 value wline 0 value SeparatorX 0 value SeparatorY :M ClassInit: ( -- ) ClassInit: super \ Insert your code here ;M : 0position-windows ( -- ) \ auto adjust windows 0 toolbarH SeparatorX 1- Height toolbarH - statusbarH - Move: LeftPane SeparatorX 2+ dup>r toolbarH Width r@ - SeparatorY 1- toolbarH - Move: RightTopPane r@ SeparatorY 2+ Width r> - Height 2 pick - statusbarH - Move: RightBottomPane self OnPosition ; : position-windows ( -- ) \ auto adjust windows 0 toolbarH SeparatorX 1- Height toolbarH - statusbarH - Move: LeftPane SeparatorX 2+ dup>r toolbarH Width r@ - SeparatorY 1- 25 min toolbarH - Move: RightTopPane r@ SeparatorY 2+ 25 min Width r> - Height 2 pick - statusbarH - Move: RightBottomPane self OnPosition ; : horizline ( -- ) \ SeparatorX 2+ SeparatorY MoveTo: dc \ Width SeparatorY LineTo: dc ; : vertline ( -- ) SeparatorX 0 MoveTo: dc SeparatorX Height LineTo: dc ; : ?line ( -- ) wline if vertline else horizline then ; : on_clicked ( -- ) true to clicked get-dc R2_NOT SetRop2: dc black LineColor: dc mousex SeparatorX = mousex SeparatorX 1+ = or if vertline true to wline else horizline false to wline then hwnd Call SetCapture drop ; : On_Mousemove ( -- ) mousex SeparatorX = mousex SeparatorX 1+ = or if SIZEWE-CURSOR exit then mousey Separatory = mousey Separatory 1+ = or if SIZENS-CURSOR else arrow-cursor then ; :M WM_MOUSEMOVE ( h w m l -- res ) WM_MOUSEMOVE WM: super on_mousemove ;M : dosizing ( -- ) clicked 0= ?exit ?line \ a minimum width of 4 pixels for windows are set, but it can be changed mousex 2 cells < mousex width 2 cells - > or mousey 2 cells < mousey height 2 cells - > or or if position-windows false to clicked release-dc hwnd Call ReleaseCapture ?win-error else wline if mousex to SeparatorX else mousey to SeparatorY then ?line then ; : on_unclicked ( -- ) clicked 0= ?exit ?line position-windows release-dc false to clicked hwnd Call ReleaseCapture ?win-error ; :M StartSize: ( -- w h ) screen-size >r 2/ r> 2/ ;M :M On_Size: ( -- ) position-windows ;M :M On_Init: ( -- ) ['] dosizing to track-func ['] on_clicked to click-func ['] on_unclicked to unclick-func 395 Setid: LeftPane self Start: LeftPane 396 Setid: RightTopPane self Start: RightTopPane 397 Setid: RightBottomPane self Start: RightBottomPane self OnInit \ perform user function Startsize: self 2 / to SeparatorY 5 / to SeparatorX TestBar SetMenuBar: self position-windows ;M :M InitListViewItems: ( -- ) LVIF_TEXT LVIF_PARAM or SetMask: LvItem \ SetMask: Also erases old parameters 0 SetiItem: LvItem 31 SetlParam: LvItem z" Sweden" SetpszText: LvItem Addr: LvItem InsertItem: ListViewLeft LVIF_TEXT LVIF_PARAM or SetMask: LvItem 1+ SetiItem: LvItem 32 SetlParam: LvItem z" Germany" SetpszText: LvItem Addr: LvItem InsertItem: ListViewLeft LVIF_TEXT SetMask: LvItem 1+ SetiItem: LvItem z" America" SetpszText: LvItem Addr: LvItem InsertItem: ListViewLeft drop LVIF_TEXT LVIF_PARAM or SetMask: LvItem 0 SetiItem: LvItem 41 SetlParam: LvItem z" Gordon" SetpszText: LvItem Addr: LvItem InsertItem: ListViewRightBottom LVIF_TEXT LVIF_PARAM or SetMask: LvItem 1+ SetiItem: LvItem 42 SetlParam: LvItem z" Jack" SetpszText: LvItem Addr: LvItem InsertItem: ListViewRightBottom LVIF_TEXT SetMask: LvItem \ Inserting a subitem SetiItem: LvItem \ Uses the index from "Jack" 2 SetiSubItem: LvItem z" 2043 VD" SetpszText: LvItem Addr: LvItem SetItem: ListViewRightBottom LVIF_TEXT LVIF_PARAM or SetMask: LvItem 1+ SetiItem: LvItem 43 SetlParam: LvItem z" Vern" SetpszText: LvItem Addr: LvItem InsertItem: ListViewRightBottom drop ;M :M On_Done: ( h m w l -- res ) Close: self 0 call PostQuitMessage drop On_Done: super 0 ;M ;Object LV_COLUMN lvc : InitListViewColumns ( -- ) LVCF_FMT LVCF_WIDTH LVCF_TEXT LVCF_SUBITEM or or or Setmask: lvc LVCFMT_LEFT Setfmt: lvc 120 Setcx: lvc z" Location" SetpszText: lvc Addr: lvc 1 InsertColumn: ListViewLeft z" Contact" SetpszText: lvc Addr: lvc swap InsertColumn: ListViewRightBottom z" Street and number" SetpszText: lvc Addr: lvc swap InsertColumn: ListViewRightBottom z" Postal code" SetpszText: lvc Addr: lvc swap InsertColumn: ListViewRightBottom z" Place" SetpszText: lvc Addr: lvc swap InsertColumn: ListViewRightBottom drop ; :Class ListViewClass <Super Object :M ClassInit: ( -- ) ;M :M ~: ( -- ) ;M :M Start: ( -- ) \ new> Window to aa new> listview to ListViewRightBottom new> listview to ListViewLeft WS_CHILD WS_VISIBLE or LVS_REPORT or LVS_EDITLABELS or WS_BORDER or SetStyleListView: ListViewRightBottom \ Set the syle for the listview WS_CHILD WS_VISIBLE or LVS_REPORT or LVS_SORTASCENDING or \ Automatic sorting LVS_EDITLABELS or WS_BORDER or SetStyleListView: ListViewLeft \ Set the syle for the listview start: SplitterWindow InitListViewColumns InitListViewItems: SplitterWindow 0 0 GetSize: SplitterWindow Move: SplitterWindow \ To force the listview to be seen ;M Point ppt Record: _Rect int left int top int right int bottom ;RecordSize: /Rect ;Class ListViewClass tt : main ( - ) Start: tt turnkey? if MessageLoop bye then ; turnkey? [if] NoConsoleIO NoConsoleInImage ' main turnkey Qds.exe \ s" WIN32FOR.ICO" s" Qds.exe" AddAppIcon 1 pause-seconds bye [else] main \ s" WIN32FOR.ICO" s" Qds.exe" AddAppIcon [then] \s |
|
From: Jos v.d.V. <jo...@us...> - 2006-05-02 09:55:45
|
Update of /cvsroot/win32forth/win32forth/src/lib In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv20634/src/lib Added Files: Listview.f Log Message: Jos: Added a Listview. --- NEW FILE: Listview.f --- anew -ListView ( -------------------------------------------------------------------) ( Point ) :Class Point <Super Object Record: _Point int x int y ;RecordSize: /Point :M Addr: ( -- a ) _Point ;M :M Sizeof: ( -- n ) /Point ;M :M Getpt: ( -- x y ) x y ;M :M Setpt: ( x y -- ) to y to x ;M ;Class ( -------------------------------------------------------------------) ( NMHDR ) :Class NMHDR <Super Object Record: _NMHDR int hwndFrom int idFrom int code ;RecordSize: /NMHDR :M Addr: ( -- a ) _NMHDR ;M :M Sizeof: ( -- n ) /NMHDR ;M :M GethwndFrom: ( -- ) hwndFrom ;M :M GetidFrom: ( -- ) idFrom ;M :M Getcode: ( -- ) code ;M :M SethwndFrom: ( -- ) to hwndFrom ;M :M SetidFrom: ( -- ) to idFrom ;M :M Setcode: ( -- ) to code ;M ;Class ( -------------------------------------------------------------------) ( LV_ITEM ) :Class LV_ITEM <Super Object Record: _LV_ITEM int mask int iItem int iSubItem int state int stateMask int pszText int cchTextMax int iImage int lParam ;RecordSize: /LV_ITEM :M Addr: ( -- a ) _LV_ITEM ;M :M Sizeof: ( -- n ) /LV_ITEM ;M :M GetMask: ( -- ) mask ;M :M GetiItem: ( -- ) iItem ;M :M GetiSubItem: ( -- ) iSubItem ;M :M Getstate: ( -- ) state ;M :M GetstateMask: ( -- ) stateMask ;M :M GetpszText: ( -- ) pszText ;M :M GetcchTextMax: ( -- ) cchTextMax ;M :M GetiImage: ( -- ) iImage ;M :M GetlParam: ( -- ) lParam ;M :M SetMask: ( -- ) _LV_ITEM /LV_ITEM erase to mask ;M :M SetiItem: ( -- ) to iItem ;M :M SetiSubItem: ( -- ) to iSubItem ;M :M Setstate: ( -- ) to state ;M :M SetstateMask: ( -- ) to stateMask ;M :M SetpszText: ( -- ) to pszText ;M :M SetcchTextMax: ( -- ) to cchTextMax ;M :M SetiImage: ( -- ) to iImage ;M :M SetlParam: ( -- ) to lParam ;M ;Class ( -------------------------------------------------------------------) ( LV_DISPINFO ) :Class LV_DISPINFO <Super NMHDR Record: _LV_DISPINFO int mask int iItem int iSubItem int state int stateMask int pszText int cchTextMax int iImage int lParam ;RecordSize: /LV_DISPINFO :M Addr: ( -- a ) _LV_DISPINFO ;M :M Sizeof: ( -- n ) /LV_DISPINFO ;M :M GetMask: ( -- ) mask ;M :M GetiItem: ( -- ) iItem ;M :M GetiSubItem: ( -- ) iSubItem ;M :M Getstate: ( -- ) state ;M :M GetstateMask: ( -- ) stateMask ;M :M GetpszText: ( -- ) pszText ;M :M GetcchTextMax: ( -- ) cchTextMax ;M :M GetiImage: ( -- ) iImage ;M :M GetlParam: ( -- ) lParam ;M :M SetMask: ( -- ) _LV_DISPINFO /LV_DISPINFO erase to mask ;M :M SetiItem: ( -- ) to iItem ;M :M SetiSubItem: ( -- ) to iSubItem ;M :M Setstate: ( -- ) to state ;M :M SetstateMask: ( -- ) to stateMask ;M :M SetpszText: ( -- ) to pszText ;M :M SetcchTextMax: ( -- ) to cchTextMax ;M :M SetiImage: ( -- ) to iImage ;M :M SetlParam: ( -- ) to lParam ;M ;Class ( -------------------------------------------------------------------) ( LV_COLUMN ) :Class LV_COLUMN <Super Object Record: _LV_COLUMN int mask int fmt int cx int pszText int cchTextMax int iSubItem ;RecordSize: /LV_COLUMN :M Addr: ( -- a ) _LV_COLUMN ;M :M Sizeof: ( -- n ) /LV_COLUMN ;M :M Getmask: ( -- ) mask ;M :M Getfmt: ( -- ) fmt ;M :M Getcx: ( -- ) cx ;M :M GetpszText: ( -- ) pszText ;M :M GetcchTextMax: ( -- ) cchTextMax ;M :M GetiSubItem: ( -- ) iSubItem ;M :M Setmask: ( -- ) _LV_COLUMN /LV_COLUMN erase to mask ;M :M Setfmt: ( -- ) to fmt ;M :M Setcx: ( -- ) to cx ;M :M SetpszText: ( -- ) to pszText ;M :M SetcchTextMax: ( -- ) to cchTextMax ;M :M SetiSubItem: ( -- ) to iSubItem ;M ;Class ( -------------------------------------------------------------------) ( LV_FINDINFO ) :Class _LV_FINDINFO <Super Object Record: LV_FINDINFO int flags int psz int lParam int x int y int vkDirection ;RecordSize: /LV_FINDINFO :M Addr: ( -- a ) _LV_FINDINFO ;M :M Sizeof: ( -- n ) /LV_FINDINFO ;M :M Getflags: ( -- ) flags ;M :M Getpsz: ( -- ) psz ;M :M GetlParam: ( -- ) lparam ;M :M GetvkDirection: ( -- ) vkDirection ;M :M Setflags: ( -- ) to flags ;M :M Setpsz: ( -- ) to psz ;M :M SetlParam: ( -- ) to lparam ;M :M SetvkDirection: ( -- ) to vkDirection ;M :M Getpt: ( -- x y ) x y ;M :M Setpt: ( x y -- ) to y to x ;M ;Class ( -------------------------------------------------------------------) ( LV_HITTESTINFO ) :Class LV_HITTESTINFO <Super Object Record: _LV_HITTESTINFO int x int y int flags int iItem ;RecordSize: /LV_HITTESTINFO :M Addr: ( -- a ) _LV_HITTESTINFO ;M :M Sizeof: ( -- n ) /LV_HITTESTINFO ;M :M Getflags: ( -- ) flags ;M :M GetiItem: ( -- ) iItem ;M :M Setflags: ( -- ) to flags ;M :M SetiItem: ( -- ) to iItem ;M :M Getpt: ( -- x y ) x y ;M :M Setpt: ( x y -- ) to y to x ;M ;Class ( -------------------------------------------------------------------) ( LV_KEYDOWN ) :Class LV_KEYDOWN <Super NMHDR Record: _LV_KEYDOWN int wVKey int flags ;RecordSize: /LV_KEYDOWN :M Addr: ( -- a ) _LV_KEYDOWN ;M :M Sizeof: ( -- n ) /LV_KEYDOWN ;M :M GetwvKey: ( -- ) wVKey ;M :M Getflags: ( -- ) flags ;M :M SetwvKey: ( -- ) to wVKey ;M :M Setflags: ( -- ) to flags ;M ;Class ( -------------------------------------------------------------------) ( NM_LISTVIEW ) :Class NM_LISTVIEW <Super NMHDR Record: _NM_LISTVIEW int iItem int iSubItem INT uNewState INT uOldState INT uChanged int x int y int lParam ;RecordSize: /NM_LISTVIEW :M Addr: ( -- a ) _NM_LISTVIEW ;M :M Sizeof: ( -- n ) /NM_LISTVIEW ;M :M GetiItem: ( -- ) iItem ;M :M GetiSubItem: ( -- ) iSubItem ;M :M GetuNewState: ( -- ) uNewState ;M :M GetuOldState: ( -- ) uOldState ;M :M GetuChanged: ( -- ) uChanged ;M :M GetlParam: ( -- ) lParam ;M :M SetiItem: ( -- ) to iItem ;M :M SetiSubItem: ( -- ) to iSubItem ;M :M SetuNewState: ( -- ) to uNewState ;M :M SetuOldState: ( -- ) to uOldState ;M :M SetuChanged: ( -- ) to uChanged ;M :M SetlParam: ( -- ) to lParam ;M :M Getpt: ( -- x y ) x y ;M :M Setpt: ( x y -- ) to y to x ;M ;Class ( -------------------------------------------------------------------) ( ListView Control ) :Class ListView <Super Window int hwndLV ( list view window handle ) int PObj ( parent object ) int nmhdr // NMHDR nmhdr int nmlv // NM_LISTVIEW nmlv int lvdi // LV_DISPINFO lvdi int lvkd // LV_KEYDOWN lvkd int _style :M GetHandle: ( - handle ) hwndLV ;M :M WindowStyle: ( -- style ) _style ;M :M SetStyleListView: ( Style -- ) to _style ;M :M ClassInit: ( -- ) here 8 , ICC_LISTVIEW_CLASSES , Call InitCommonControlsEx not if ." Couldn't initialise common controls" then cr Classinit: Super ;M :M ~: ( -- ) hwndLV Call DestroyWindow ~: Super ;M : create-listview ( -- hWnd ) 0 \ creation parameters appInst \ program instance 0 \ child id Gethandle: PObj \ parent window handle CW_USEDEFAULT CW_USEDEFAULT \ height, width CW_USEDEFAULT CW_USEDEFAULT \ y, x starting position WindowStyle: [ self ] \ the window style WindowTitle: [ self ] \ the window title s" SysListView32" WindowClassName place WindowClassName +NULL WindowClassName 1+ \ class name ExWindowStyle: [ self ] \ extended window style Call CreateWindowEx ; :M Start: ( hwnd -- ) to PObj create-listview to hWndLV ;M ( -------------------------------------------------------------------) ( Items and SubItems ) :M DeleteAllItems: ( -- f ) 0 0 LVM_DELETEALLITEMS hwndLV Call SendMessage ;M :M DeleteItem: ( iitem -- f ) 0 swap LVM_DELETEITEM hwndLV Call SendMessage ;M :M GetItem: ( ptem -- f ) 0 LVM_GETITEM hwndLV Call SendMessage ;M :M GetItemCount: ( -- n ) 0 0 LVM_GETITEMCOUNT hwndLV Call SendMessage ;M :M GetItemSpacing: ( fsmall -- f ) 0 swap LVM_GETITEMSPACING hwndLV Call SendMessage ;M :M GetItemState: ( mask i -- f ) LVM_GETITEMSTATE hwndLV Call SendMessage ;M :M GetItemText: ( pitem iItem -- ) LVM_GETITEMTEXT hwndLV Call SendMessage drop ;M :M GetSelectedCount: ( -- n ) 0 0 LVM_GETSELECTEDCOUNT hwndLV Call SendMessage ;M :M InsertItem: ( pitem -- index | -1 ) 0 LVM_INSERTITEM hwndLV Call SendMessage ;M :M SetItem: ( pitem -- index | -1 ) 0 LVM_SETITEM hwndLV Call SendMessage ;M :M SetItemCount: ( cItems -- ) 0 swap LVM_SETITEMCOUNT hwndLV Call SendMessage ;M :M SetItemState: ( pitem i -- f ) LVM_SETITEMSTATE hwndLV Call SendMessage ;M :M SetItemText: ( pitem i -- f ) LVM_SETITEMTEXT hwndLV Call SendMessage ;M ( -------------------------------------------------------------------) ( Callback Items ) :M GetCallBackMask: ( -- mask ) 0 0 LVM_GETCALLBACKMASK hwndLV Call SendMessage ;M :M ReDrawItems: ( iLast iFirst -- f ) LVM_REDRAWITEMS hwndLV Call SendMessage ;M :M SetCallBackMask: ( mask -- f ) 0 swap LVM_SETCALLBACKMASK hwndLV Call SendMessage ;M :M Update: ( iItem -- f ) 0 swap LVM_UPDATE hwndLV Call SendMessage ;M ( -------------------------------------------------------------------) ( Columns ) :M DeleteColumn: ( icol -- f ) 0 swap LVM_DELETECOLUMN hwndLV Call SendMessage ;M :M GetColumn: ( pcol icol -- f ) LVM_GETCOLUMN hwndLV Call SendMessage ;M :M GetColumnWidth: ( icol -- width|0 ) 0 swap LVM_GETCOLUMNWIDTH hwndLV Call SendMessage ;M :M GetStringWidth: ( psz -- width|0 ) 0 LVM_GETSTRINGWIDTH hwndLV Call SendMessage ;M :M InsertColumn: ( pcol icol -- index|-1 ) LVM_INSERTCOLUMN hwndLV Call SendMessage ;M :M SetColumn: ( pcol icol -- f ) LVM_SETCOLUMN hwndLV Call SendMessage ;M :M SetColumnWidth: ( cx -- ) -1 LVM_SETCOLUMNWIDTH hwndLV Call SendMessage drop ;M ( -------------------------------------------------------------------) ( Arranging, Sorting and Finding ) :M Arrange: ( code -- f ) 0 swap LVM_ARRANGE hwndLV Call SendMessage ;M :M FindItem: ( plvfi iStart -- index|-1 ) LVM_FINDITEM hwndLV Call SendMessage ;M :M GetNextItem: ( flags iStart -- index|-1 ) LVM_GETNEXTITEM hwndLV Call SendMessage ;M :M SortItems: ( pfnCompare lParamsort -- f ) LVM_SORTITEMS hwndLV Call SendMessage ;M ( -------------------------------------------------------------------) ( Items Positions and Scrolling ) :M EnsureVisible: ( fPartialOK i -- f ) LVM_ENSUREVISIBLE hwndLV Call SendMessage ;M :M GetCountPerPage: ( -- n ) 0 0 LVM_GETCOUNTPERPAGE hwndLV Call SendMessage ;M :M GetItemPosition: ( ppt i -- f ) LVM_GETITEMPOSITION hwndLV Call SendMessage ;M :M GetItemRect: ( prc i -- f ) LVM_GETITEMRECT hwndLV Call SendMessage ;M :M GetOrigin: ( lpptOrg -- f ) 0 LVM_GETORIGIN hwndLV Call SendMessage ;M :M GetTopIndex: ( -- index|0 ) 0 0 LVM_GETTOPINDEX hwndLV Call SendMessage ;M :M GetViewRect: ( prc -- f ) 0 LVM_GETVIEWRECT hwndLV Call SendMessage ;M :M HitTest: ( pinfo -- index|-1 ) 0 LVM_HITTEST hwndLV Call SendMessage ;M :M Scroll: ( dy dx -- f ) LVM_SCROLL hwndLV Call SendMessage ;M :M SetItemPosition: ( x y i -- f ) >r word-join r> LVM_SETITEMPOSITION hwndLV Call SendMessage ;M :M SetItemPosition32: ( lpptNewPos iItem -- f ) LVM_SETITEMPOSITION32 hwndLV Call SendMessage ;M ( -------------------------------------------------------------------) ( Colours ) :M GetBkColor: ( -- col ) 0 0 LVM_GETBKCOLOR hwndLV Call SendMessage ;M :M GetTextBkColor: ( -- col ) 0 0 LVM_GETTEXTBKCOLOR hwndLV Call SendMessage ;M :M GetTextColor: ( -- col ) 0 0 LVM_GETTEXTCOLOR hwndLV Call SendMessage ;M :M SetBkColor: ( clrBk -- f ) 0 LVM_SETBKCOLOR hwndLV Call SendMessage ;M :M SetTextBkColor: ( clrText -- f ) 0 LVM_SETTEXTBKCOLOR hwndLV Call SendMessage ;M :M SetTextColor: ( clrText -- f ) 0 LVM_SETTEXTCOLOR hwndLV Call SendMessage ;M ( -------------------------------------------------------------------) ( Miscellaneous ) :M CreateDragImage: ( lpptUpLeft iItem -- hndl|NULL ) LVM_CREATEDRAGIMAGE hwndLV Call SendMessage ;M :M EditLabel: ( iItem -- hndl|NULL ) 0 swap LVM_EDITLABEL hwndLV Call SendMessage ;M :M GetEditControl: ( -- ) 0 0 LVM_GETEDITCONTROL hwndLV Call SendMessage ;M :M GetImageList: ( iImageList -- hndl|NULL ) 0 swap LVM_GETIMAGELIST hwndLV Call SendMessage ;M :M SetImageList: ( himl iImageList -- hndl|NULL ) LVM_SETIMAGELIST hwndLV Call SendMessage ;M ( -------------------------------------------------------------------) ( -Window Message Processing performed by a list contol- ) :M WM_CHAR: ( -- ) ;M :M WM_COMMAND: ( -- ) ;M :M WM_CREATE: ( -- ) ;M :M WM_DESTROY: ( -- ) ;M :M WM_ERASEBKGND: ( -- ) ;M :M WM_GETDLGCODE: ( -- ) ;M :M WM_GETFONT: ( -- ) ;M :M WM_HSCROLL: ( -- ) ;M :M WM_KEYDOWN: ( -- ) ;M :M WM_KILLFOCUS: ( -- ) ;M :M WM_LBUTTONDBLCLK: ( -- ) ;M :M WM_LBUTTONDOWN: ( -- ) ;M :M WM_NCCREATE: ( -- ) ;M :M WM_NOTIFY: ( h m w l -- ) dup @ to nmhdr Getcode: nmhdr ( A list view control sends notification ( messages to its owner window when events occur in the control. ) case LVN_BEGINDRAG OF @ to nmlv ENDOF // NM_LISTVIEW LVN_BEGINLABELEDITA OF @ to lvdi ENDOF // LV_DISPINFO LVN_BEGINRDRAG OF @ to nmlv ENDOF // NM_LISTVIEW LVN_COLUMNCLICK OF @ to nmlv ENDOF // NM_LISTVIEW LVN_DELETEALLITEMS OF @ to nmlv ENDOF // NM_LISTVIEW LVN_DELETEITEM OF @ to nmlv ENDOF // NM_LISTVIEW LVN_ENDLABELEDITA OF @ to lvdi ENDOF // LV_DISPINFO LVN_GETDISPINFOA OF @ to lvdi ENDOF // LV_DISPINFO LVN_INSERTITEM OF @ to nmlv ENDOF // NM_LISTVIEW LVN_ITEMCHANGED OF @ to nmlv ENDOF // NM_LISTVIEW LVN_ITEMCHANGING OF @ to nmlv ENDOF // NM_LISTVIEW LVN_KEYDOWN OF @ to lvkd ENDOF // LV_KEYDOWN LVN_SETDISPINFOA OF @ to lvdi ENDOF // LV_DISPINFO endcase ;M :M WM_NCCREATE: ( -- ) ;M :M WM_NCDESTROY: ( -- ) ;M :M WM_PAINT: ( -- ) ;M :M WM_RBUTTONDOWN: ( -- ) ;M :M WM_SETFOCUS: ( -- ) ;M :M WM_SETFONT: ( -- ) ;M :M WM_SETREDRAW: ( -- ) ;M :M WM_TIMER: ( -- ) ;M :M WM_VSCROLL: ( -- ) ;M :M WM_WINDOWPOSCHANGED: ( -- ) ;M :M WM_WININICHANGE: ( -- ) ;M ;Class \ s A simple demo: ( -------------------------------------------------------------------) ( -------------------------------------------------------------------) ( Example ) ( Get it all started just to see if it works ) 0 value bb :Object aa <super Window ColorObject FrmColor \ the background color :M ClassInit: ( -- ) ClassInit: super ;M :M WindowStyle: ( -- style ) WS_OVERLAPPEDWINDOW ;M :M StartSize: ( -- width height ) 400 200 ;M :M StartPos: ( -- x y ) 0 0 ;M :M On_Size: ( -- ) gethandle: bb if 1 ( repaint flag ) tempRect.AddrOf GetClientRect: Self Bottom: tempRect Right: tempRect 0 0 gethandle: bb Call MoveWindow drop then ;M :M On_Done: ( h m w l -- res ) On_Done: super 0 ;M ;Object :Class Test <Super Object \ int aa ( window ) \ int bb ( Listview ) int hiconItem // HICON hiconItem; // icon for list view items int himlLarge // HIMAGELIST himlLarge; // image list for icon view int himlSmall // HIMAGELIST himlSmall; // image list for other views :M ClassInit: ( -- ) ;M :M ~: ( -- ) ;M LV_COLUMN lvc : InitListViewColumns ( -- ) LVCF_FMT LVCF_WIDTH LVCF_TEXT LVCF_SUBITEM or or or Setmask: lvc LVCFMT_LEFT Setfmt: lvc 120 Setcx: lvc z" Columns 1" SetpszText: lvc Addr: lvc 1 InsertColumn: bb -1 = if ." Not Successful " cr then z" Columns 2" SetpszText: lvc Addr: lvc 2 InsertColumn: bb -1 = if ." Not Successful " cr then z" Columns 3" SetpszText: lvc Addr: lvc 3 InsertColumn: bb -1 = if ." Not Successful " cr then z" Columns 4" SetpszText: lvc Addr: lvc 4 InsertColumn: bb -1 = if ." Not Successful " cr then ; LV_ITEM lv1 LV_ITEM lv2 LV_ITEM lv3 LV_ITEM lv4 : InitListViewItems ( -- ) LVIF_TEXT SetMask: lv1 0 SetiItem: lv1 z" subitem 1" SetpszText: lv1 LVIF_TEXT SetMask: lv2 1 SetiItem: lv2 z" subitem 2" SetpszText: lv2 LVIF_TEXT SetMask: lv3 2 SetiItem: lv3 z" subitem 3" SetpszText: lv3 LVIF_TEXT SetMask: lv4 3 SetiItem: lv4 z" subitem 4" SetpszText: lv4 Addr: lv1 InsertItem: bb drop Addr: lv2 InsertItem: bb drop Addr: lv3 InsertItem: bb drop Addr: lv4 InsertItem: bb drop LVIF_TEXT SetMask: lv2 1 SetiItem: lv2 2 SetiSubItem: lv2 z" s0" SetpszText: lv2 Addr: lv2 SetItem: bb ; :M Start: ( -- ) \ new> Window to aa new> listview to bb WS_CHILD WS_VISIBLE or LVS_REPORT or LVS_EDITLABELS or WS_BORDER or SetStyleListView: bb \ Set the syle for the listview start: aa aa start: bb InitListViewColumns ." Done Ok" cr InitListViewItems ." Done Ok" cr 0 0 GetSize: aa Move: aa \ To force the listview to be seen ;M Point ppt Record: _Rect int left int top int right int bottom ;RecordSize: /Rect :M Test1: ( -- ) GetBkColor: bb ." The background colour is = " . cr GetTextBkColor: bb ." The text background colour is = " . cr GetTextColor: bb ." The text colour is = " . cr GetCountPerPage: bb ." Count per page " . cr Addr: ppt 1 GetItemPosition: bb if ." Item position " getpt: ppt swap . . cr then LVIR_BOUNDS _Rect GetItemRect: bb if ." Bounds: Item Rect (l,t,r,b) " left . top . right . bottom . cr then LVIR_ICON _Rect GetItemRect: bb if ." Icon: Item Rect (l,t,r,b) " left . top . right . bottom . cr then LVIR_LABEL _Rect GetItemRect: bb if ." Label: Item Rect (l,t,r,b) " left . top . right . bottom . cr then LVIR_SELECTBOUNDS _Rect GetItemRect: bb if ." Select: Item Rect (l,t,r,b) " left . top . right . bottom . cr then Addr: ppt GetOrigin: bb if ." Origin " getpt: ppt swap . . cr then GetTopIndex: bb ." Top Index " . cr _Rect GetViewRect: bb if ." View Rect (l,t,r,b) " left . top . right . bottom . cr then ;M ;Class Test tt Start: tt Test1: tt ( -------------------------------------------------------------------) |
|
From: bob a. <rd...@us...> - 2006-05-01 03:11:52
|
Update of /cvsroot/win32forth/win32forth/src/kernel In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv3491/src/kernel Modified Files: fkernel.f Log Message: move 'defer start/stop' up so it can be called in 'slow' to help in seeing warnings during build Index: fkernel.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/kernel/fkernel.f,v retrieving revision 1.27 retrieving revision 1.28 diff -C2 -d -r1.27 -r1.28 *** fkernel.f 8 Apr 2006 19:46:58 -0000 1.27 --- fkernel.f 1 May 2006 03:11:48 -0000 1.28 *************** *** 4252,4255 **** --- 4252,4257 ---- ; + DEFER START/STOP ' noop is start/stop \ has to be in systemspace + in-application *************** *** 4273,4278 **** mov eax, VHEAD VOC#0 - [ecx] \ fetch header word to execute exec c; 0 value slfactor \ adjust this to slow down loading ! : SLOW ( -- ) slfactor ms ; \ set 'slfactor' to slow down loading : HEADER ( -<name>- ) \ build a header BL WORD COUNT (HEADER) slow ; \ self-call the header word --- 4275,4281 ---- mov eax, VHEAD VOC#0 - [ecx] \ fetch header word to execute exec c; + 0 value slfactor \ adjust this to slow down loading ! : SLOW ( -- ) slfactor ms start/stop ; \ set 'slfactor' to slow down loading : HEADER ( -<name>- ) \ build a header BL WORD COUNT (HEADER) slow ; \ self-call the header word *************** *** 5618,5622 **** THEN ; ! DEFER START/STOP ' _START/STOP IS START/STOP VARIABLE ECHO \ ECHO ON echos everything to the console that's included --- 5621,5625 ---- THEN ; ! ' _START/STOP IS START/STOP VARIABLE ECHO \ ECHO ON echos everything to the console that's included |
|
From: bob a. <rd...@us...> - 2006-04-29 19:47:31
|
Update of /cvsroot/win32forth/win32forth/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv20591/src Modified Files: Keysave.f Log Message: catch error if globallock fails; defer paste-load b/c it hangs my app when i vector key and do a ctrl-v Index: Keysave.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/Keysave.f,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** Keysave.f 3 May 2005 10:04:30 -0000 1.3 --- Keysave.f 29 Apr 2006 19:47:17 -0000 1.4 *************** *** 472,482 **** then ; ! : paste-load ( -- ) ! conhndl call OpenClipboard 0= if beep else CF_TEXT call GetClipboardData ?dup ! if dup to paste-hdl ! call GlobalLock to paste-ptr \ lock memory ! paste-ptr zcount nip dup to paste-len \ get len if 0 to paste-off 0 to play0cnt --- 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 *************** *** 496,499 **** --- 498,502 ---- then then ; + ' _paste-load is paste-load : win-paste-load ( wParam lParam -- wParam lParam ) *************** *** 572,574 **** MODULE \ finish up the module ! |
|
From: George H. <geo...@us...> - 2006-04-25 10:25:09
|
Update of /cvsroot/win32forth/win32forth/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv4685/win32forth/src Modified Files: FLOAT.F Log Message: gah: Fixed bug in decompiling Fliterals plus minor mods Index: FLOAT.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/FLOAT.F,v retrieving revision 1.43 retrieving revision 1.44 diff -C2 -d -r1.43 -r1.44 *** FLOAT.F 25 Feb 2006 10:39:32 -0000 1.43 --- FLOAT.F 25 Apr 2006 10:24:56 -0000 1.44 *************** *** 102,106 **** \ *P \b WARNING! \d do not alter the settings unless you know what you're doing. ! code >fregs ( addr -- ) \ W32F Floating extra \ *G Restore x87 FPU State. frstor DATASTACK_MEMORY --- 102,106 ---- \ *P \b WARNING! \d do not alter the settings unless you know what you're doing. ! code >fregs ( addr -- ) \ W32F Floating extra \ *G Restore x87 FPU State. frstor DATASTACK_MEMORY *************** *** 109,113 **** end-code ! code >fregs> ( addr -- ) \ W32F Floating extra \ *G Save and Restore x87 FPU State. fsave DATASTACK_MEMORY --- 109,113 ---- end-code ! code >fregs> ( addr -- ) \ W32F Floating extra \ *G Save and Restore x87 FPU State. fsave DATASTACK_MEMORY *************** *** 117,121 **** end-code ! code fpcw> ( -- n ) \ W32F Floating extra \ *G Get x87 FPU Control Word. push tos --- 117,121 ---- end-code ! code fpcw> ( -- n ) \ W32F Floating extra \ *G Get x87 FPU Control Word. push tos *************** *** 127,131 **** end-code ! code >fpcw ( n -- ) \ W32F Floating extra \ *G Set x87 FPU Control Word. push tos --- 127,131 ---- end-code ! code >fpcw ( n -- ) \ W32F Floating extra \ *G Set x87 FPU Control Word. push tos *************** *** 136,140 **** end-code ! code fpsw> ( -- n ) \ W32F Floating extra \ *G Get x87 FPU Status Word. push tos --- 136,140 ---- end-code ! code fpsw> ( -- n ) \ W32F Floating extra \ *G Get x87 FPU Status Word. push tos *************** *** 145,149 **** [undefined] B/FLOAT [if] ! 10 constant B/FLOAT ( -- n ) \ W32F Floating extra \ *G Number of bytes in a floating-point number. Note the default is 8 bytes. [then] --- 145,149 ---- [undefined] B/FLOAT [if] ! 10 constant B/FLOAT ( -- n ) \ W32F Floating extra \ *G Number of bytes in a floating-point number. Note the default is 8 bytes. [then] *************** *** 170,174 **** previous definitions ! cell NEWUSER FLOATSP \ floating point stack pointer in the user area (new) 256 constant fstack-elements \ 256 floating point elements in stack next-user @ 0x10 naligned next-user ! \ align next user to quadword --- 170,175 ---- previous definitions ! cell NEWUSER FLOATSP ( -- addr ) \ W32F Floating extra ! \ *G Address of floating point stack pointer in the user area. 256 constant fstack-elements \ 256 floating point elements in stack next-user @ 0x10 naligned next-user ! \ align next user to quadword *************** *** 241,245 **** end-code ! code finit ( -- ) \ W32F Floating extra \ *G Clears the floating-point stack & sets the appropriate byte mode. \ ** It is executed by the system on start-up and by the default exception handler. --- 242,246 ---- end-code ! code finit ( -- ) \ W32F Floating extra \ *G Clears the floating-point stack & sets the appropriate byte mode. \ ** It is executed by the system on start-up and by the default exception handler. *************** *** 363,367 **** \ *N Memory Access ! code F@ ( addr -- ; fs: -- r ) \ ANSI Floating \ *G Fetch a float. fld FSIZE DATASTACK_MEMORY --- 364,368 ---- \ *N Memory Access ! code F@ ( addr -- ; fs: -- r ) \ ANSI Floating \ *G Fetch a float. fld FSIZE DATASTACK_MEMORY *************** *** 408,412 **** float; ! code F+! ( addr -- ; fs: r -- ) \ W32F Floating extra \ *G Add the value to a float. fstack-check_1 --- 409,413 ---- float; ! code F+! ( addr -- ; fs: r -- ) \ W32F Floating extra \ *G Add the value to a float. fstack-check_1 *************** *** 418,422 **** float; ! : F, ( fs: r -- ) \ compile a float here f! B/FLOAT allot ; --- 419,424 ---- float; ! : F, ( fs: r -- ) \ W32F Floating extra ! \ *G Compile a float into the dictionary. here f! B/FLOAT allot ; *************** *** 456,461 **** in-system ! : FTO \ W32F Floating extra ! \ *G \b Interpretation: ( -<fvalue>- -- FS: r -- ) \n \ ** Compilation: ( -<fvalue>- -- Run-time: FS: r -- ) \d \ *P Store r into -<fvalue>-. If -<fvalue>- is not defined with fvalue then memory may --- 458,463 ---- in-system ! : FTO \ W32F Floating extra ! \ *G \b Interpretation: ( -<fvalue>- -- fs: r -- ) \n \ ** Compilation: ( -<fvalue>- -- Run-time: FS: r -- ) \d \ *P Store r into -<fvalue>-. If -<fvalue>- is not defined with fvalue then memory may *************** *** 897,901 **** s>d d>f ; ! : f>s ( -- n ; fs: r -- ) \ W32F Floating extra \ *G Convert the floating point number r to single number n. f>d drop ; --- 899,903 ---- s>d d>f ; ! : f>s ( -- n ; fs: r -- ) \ W32F Floating extra \ *G Convert the floating point number r to single number n. f>d drop ; *************** *** 984,988 **** \ *G Return true if r1 equals r2. Returns false if either number is a NAN. fcomppx FCOMP_EQUAL = ; ! : F< ( -- f ; fs: r1 r2 -- ) \ ANSI Floating \ *G Return true if r1 is less than r2. Returns false if either number is a NAN. fcomppx FCOMP_LESS = ; --- 986,990 ---- \ *G Return true if r1 equals r2. Returns false if either number is a NAN. fcomppx FCOMP_EQUAL = ; ! : F< ( -- f ; fs: r1 r2 -- ) \ ANSI Floating \ *G Return true if r1 is less than r2. Returns false if either number is a NAN. fcomppx FCOMP_LESS = ; *************** *** 1718,1724 **** : init->float ( -- ) ! ( 0 expsign ! ) 0 intcnt ! \ initialize various ! 0 fracnt ! ( 0 expcnt ! ) \ counts and such ! 0 zerochar ! 0 mantsign ! false havedigits ! fbcd-buf 10 erase \ clear bcd buffer --- 1720,1725 ---- : init->float ( -- ) ! 0 intcnt ! 0 fracnt ! \ initialize various counts ! 0 zerochar ! 0 mantsign ! \ and such false havedigits ! fbcd-buf 10 erase \ clear bcd buffer *************** *** 1928,1932 **** internal ! code f>bcd ( fs: r -- ) ( addr -- ) fstack-check_1 >fpu --- 1929,1933 ---- internal ! code f>bcd ( addr -- ; fs: r -- ) fstack-check_1 >fpu *************** *** 2032,2036 **** THEN ; ! : +represent { $buf \ -- flag } $ftemp precision represent 0= -IF 3drop $ftemp precision $buf +PLACE s" " $buf +PLACE true --- 2033,2037 ---- THEN ; ! : +represent { $buf -- true | exp sign false ; fs: r -- } $ftemp precision represent 0= -IF 3drop $ftemp precision $buf +PLACE s" " $buf +PLACE true *************** *** 2096,2100 **** $buf +represent ?EXIT ! drop 1- 3 /mod swap 1+ $ftemp over $buf +PLACE s" ." $buf +PLACE $ftemp over + swap precision swap - $buf +PLACE --- 2097,2101 ---- $buf +represent ?EXIT ! drop 1- s>d 3 fm/mod swap 1+ $ftemp over $buf +PLACE s" ." $buf +PLACE $ftemp over + swap precision swap - $buf +PLACE *************** *** 2131,2138 **** fdup fabs precision 2/ negate 10**n f< ! IF (e.) ELSE fdup fabs precision 10**n f< IF (f.) ! ELSE (e.) THEN THEN ; --- 2132,2139 ---- fdup fabs precision 2/ negate 10**n f< ! IF (fs.) ELSE fdup fabs precision 10**n f< IF (f.) ! ELSE (fs.) THEN THEN ; *************** *** 2383,2390 **** \ If you don't understand what the following definition is doing, don't \ concern yourself. It is moving a floating point number from a1 into ! \ the body of its own definition so it can display it easily. : .onefloat ( -- r1 ) ! f0.0 g. ; : see.float ( a1 -- a2 ) --- 2384,2392 ---- \ If you don't understand what the following definition is doing, don't \ concern yourself. It is moving a floating point number from a1 into ! \ the body of its own definition so it can display it easily. Note it must ! \ compile an fliteral NOT a fconstant. : .onefloat ( -- r1 ) ! [ f0.0 ] fliteral g. ; : see.float ( a1 -- a2 ) |
|
From: Jos v.d.V. <jo...@us...> - 2006-04-19 12:53:24
|
Update of /cvsroot/win32forth/win32forth/src/lib In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv10880/src/lib Modified Files: ExtStruct.f Log Message: Jos: Removed the unneeded allignment. Index: ExtStruct.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/lib/ExtStruct.f,v retrieving revision 1.6 retrieving revision 1.7 diff -C2 -d -r1.6 -r1.7 *** ExtStruct.f 19 Apr 2006 11:11:25 -0000 1.6 --- ExtStruct.f 19 Apr 2006 12:53:18 -0000 1.7 *************** *** 170,176 **** \ create a struct in the dictionary and fill it with zero's ! \ 19-4-2006 aligned the memory structures. : mkstruct: ( size-struct <-name-> -- ) ! here dup aligned - allot create here over allot swap erase ; in-application --- 170,176 ---- \ create a struct in the dictionary and fill it with zero's ! \ Note create alignes the memory structures. : mkstruct: ( size-struct <-name-> -- ) ! create here over allot swap erase ; in-application |
|
From: Jos v.d.V. <jo...@us...> - 2006-04-19 12:39:33
|
Update of /cvsroot/win32forth/win32forth/apps/Player4 In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv30727/apps/Player4 Modified Files: PLAYER4.F PopupWindow.f Log Message: Jos: No need anymore for w32fconsole.dll in the turnkey app. Index: PLAYER4.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Player4/PLAYER4.F,v retrieving revision 1.43 retrieving revision 1.44 diff -C2 -d -r1.43 -r1.44 *** PLAYER4.F 12 Apr 2006 19:44:24 -0000 1.43 --- PLAYER4.F 19 Apr 2006 12:39:20 -0000 1.44 *************** *** 42,45 **** --- 42,46 ---- defer RequestRecord ' noop is RequestRecord + needs NoConsole.f needs Pl_Toolset.f needs volinfo.f *************** *** 55,58 **** --- 56,60 ---- needs view.f + : invert-check ( check - ) dup c@ not swap c! RefreshWindow ; *************** *** 568,572 **** InitPlayer HandleCmdLine ! PLAYER-LOOP ; \ ----------------------------------------------------------------------------- --- 570,577 ---- InitPlayer HandleCmdLine ! PLAYER-LOOP ! turnkey? ! IF MessageLoop bye ! THEN ; \ ----------------------------------------------------------------------------- *************** *** 576,582 **** ' QuitPlayer is StopPlayer false to MciDebug? ' player4 turnkey Player4.exe s" Player4.ico" s" Player4.exe" AddAppIcon ! 1 pause-seconds [else] true to MciDebug? --- 581,588 ---- ' QuitPlayer is StopPlayer false to MciDebug? + NoConsoleIO NoConsoleInImage ' player4 turnkey Player4.exe s" Player4.ico" s" Player4.exe" AddAppIcon ! 1 pause-seconds bye [else] true to MciDebug? Index: PopupWindow.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Player4/PopupWindow.f,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** PopupWindow.f 12 Apr 2006 19:44:24 -0000 1.3 --- PopupWindow.f 19 Apr 2006 12:39:20 -0000 1.4 *************** *** 31,36 **** :M WindowStyle: ( -- style ) WS_POPUP ;M :M StartSize: ( -- width height ) 70 30 ;M ! :M StartPos: ( -- x y ) mousex mousey ;M ! :M WM_LBUTTONDOWN ( h m w l -- res ) 2drop 0 close: Self 0 ;M :M On_KillFocus: ( h m w l -- ) 2drop focus if SetFocus: self then ;M --- 31,36 ---- :M WindowStyle: ( -- style ) WS_POPUP ;M :M StartSize: ( -- width height ) 70 30 ;M ! :M StartPos: ( -- x y ) mousex mousey ;M ! :M WM_LBUTTONDOWN ( h m w l -- res ) 2drop 0 close: Self ;M :M On_KillFocus: ( h m w l -- ) 2drop focus if SetFocus: self then ;M |
|
From: Jos v.d.V. <jo...@us...> - 2006-04-19 11:11:29
|
Update of /cvsroot/win32forth/win32forth/src/lib In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15388a/src/lib Modified Files: ExtStruct.f Log Message: Jos: Added: FOURCC Index: ExtStruct.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/lib/ExtStruct.f,v retrieving revision 1.5 retrieving revision 1.6 diff -C2 -d -r1.5 -r1.6 *** ExtStruct.f 19 Apr 2006 10:00:29 -0000 1.5 --- ExtStruct.f 19 Apr 2006 11:11:25 -0000 1.6 *************** *** 60,63 **** --- 60,64 ---- ' dword alias int ' dword alias uint + ' dword alias FOURCC \ for storing four ASCII bytes in a 32-bit field ' dword alias ulong ' dword alias langid |
|
From: Jos v.d.V. <jo...@us...> - 2006-04-19 10:00:34
|
Update of /cvsroot/win32forth/win32forth/src/lib In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv16165/src/lib Modified Files: ExtStruct.f Log Message: Jos :aligned the memory structures. Index: ExtStruct.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/lib/ExtStruct.f,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** ExtStruct.f 29 Oct 2005 09:44:38 -0000 1.4 --- ExtStruct.f 19 Apr 2006 10:00:29 -0000 1.5 *************** *** 169,174 **** \ create a struct in the dictionary and fill it with zero's : mkstruct: ( size-struct <-name-> -- ) ! create here over allot swap erase ; in-application --- 169,175 ---- \ create a struct in the dictionary and fill it with zero's + \ 19-4-2006 aligned the memory structures. : mkstruct: ( size-struct <-name-> -- ) ! here dup aligned - allot create here over allot swap erase ; in-application |
|
From: Jos v.d.V. <jo...@us...> - 2006-04-14 19:12:49
|
Update of /cvsroot/win32forth/win32forth/src/lib In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv30930/src/lib Modified Files: treeview.f Log Message: Jos: Added an other font for the treeview in the demo. Also added ExpandItem: and CollapseItem:. Index: treeview.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/lib/treeview.f,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** treeview.f 8 Mar 2006 21:40:17 -0000 1.3 --- treeview.f 14 Apr 2006 19:12:44 -0000 1.4 *************** *** 249,252 **** --- 249,260 ---- ;M + :M ExpandItem: ( hItem -- ) + TVE_EXPAND TVM_EXPAND hWnd Call SendMessage drop + ;M + + :M CollapseItem: ( hItem -- ) + TVE_COLLAPSE TVM_EXPAND hWnd Call SendMessage drop + ;M + :M SortChildren: ( hItem -- ) false TVM_SORTCHILDREN hWnd Call SendMessage drop *************** *** 309,312 **** --- 317,322 ---- :Class NewTVC <super TreeViewControl + Font WinFont + :M WindowStyle: ( -- style ) *************** *** 354,357 **** --- 364,373 ---- Start: super + 8 Width: WinFont + 16 Height: WinFont + s" Courier New" SetFaceName: WinFont + Create: WinFont + true Handle: WinFont WM_SETFONT hWnd CALL SendMessage drop \ activate a new font + \ Insert items... FillTreeView |
|
From: Jos v.d.V. <jo...@us...> - 2006-04-12 19:44:29
|
Update of /cvsroot/win32forth/win32forth/apps/Player4 In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv11421/apps/Player4 Modified Files: Catalog.f Mediatree.f PLAYER4.F Pl_MciWindow.f PopupWindow.f Log Message: Jos: Improved the request handling. Index: PLAYER4.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Player4/PLAYER4.F,v retrieving revision 1.42 retrieving revision 1.43 diff -C2 -d -r1.42 -r1.43 *** PLAYER4.F 5 Apr 2006 16:26:47 -0000 1.42 --- PLAYER4.F 12 Apr 2006 19:44:24 -0000 1.43 *************** *** 20,23 **** --- 20,24 ---- decimal + true value turnkey? true value MciDebug? *************** *** 39,42 **** --- 40,44 ---- defer RefreshWindow ' noop is SortSize defer PlaySelectedFromTreeView ' noop is PlaySelectedFromTreeView + defer RequestRecord ' noop is RequestRecord needs Pl_Toolset.f *************** *** 75,79 **** SUBMENU "S&ort and view" MENUITEM "Define a view and sort" StartViewForm ; ! MENUITEM "&Sort" SortCatalog ; MENUSEPARATOR MENUITEM "Se&t maximum random level" SetRandomLevel ; --- 77,81 ---- SUBMENU "S&ort and view" MENUITEM "Define a view and sort" StartViewForm ; ! MENUITEM "&Sort / Refresh" SortCatalog ; MENUSEPARATOR MENUITEM "Se&t maximum random level" SetRandomLevel ; *************** *** 82,89 **** SUBMENU "Re&quest handling" :MENUITEM mHandelReq "Ignore requests" ! vadr-config IgnoreRequests invert-check ; :MENUITEM mKeepReq "Keep requests" vadr-config KeepRequests invert-check ; ! MENUITEM "&Enable all kept requests" EnableKeptRequests ; MENUITEM "Se&t request level" player-base SetRequestLevel ; MENUITEM "Set a&ll requests to the same level" Level-requests SortCatalog ; --- 84,94 ---- SUBMENU "Re&quest handling" :MENUITEM mHandelReq "Ignore requests" ! vadr-config IgnoreRequests dup invert-check c@ not ! if SortCatalog ! then ! ; :MENUITEM mKeepReq "Keep requests" vadr-config KeepRequests invert-check ; ! \ MENUITEM "&Enable all kept requests" EnableKeptRequests ; MENUITEM "Se&t request level" player-base SetRequestLevel ; MENUITEM "Set a&ll requests to the same level" Level-requests SortCatalog ; *************** *** 386,390 **** :noname ( -- ) \ sort catalog by file names catalog-exist? ! if SortByFlags RefreshCatalog then ; is SortCatalog --- 391,395 ---- :noname ( -- ) \ sort catalog by file names catalog-exist? ! if EnableKeptRequests SortByFlags RefreshCatalog then ; is SortCatalog Index: Pl_MciWindow.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Player4/Pl_MciWindow.f,v retrieving revision 1.16 retrieving revision 1.17 diff -C2 -d -r1.16 -r1.17 *** Pl_MciWindow.f 12 Mar 2006 18:01:27 -0000 1.16 --- Pl_MciWindow.f 12 Apr 2006 19:44:24 -0000 1.17 *************** *** 278,287 **** Playing?: Self not if next-not-played dup -1 = ! if cr cr ." All done. Reset randomlevel and shuffle..." set-all-not-played random-shuffle else cr 2 spaces dup . 2 spaces n>record dup>r RecordDef File_name r@ Cnt_File_name c@ 2dup type-space r@ incr-#played - r@ RequestDone r> mark-played PlayFile: Self --- 278,288 ---- Playing?: Self not if next-not-played dup -1 = ! if MciDebug? ! if cr cr ." All done. Reset randomlevel and shuffle..." ! then set-all-not-played random-shuffle else cr 2 spaces dup . 2 spaces n>record dup>r RecordDef File_name r@ Cnt_File_name c@ 2dup type-space r@ incr-#played r> mark-played PlayFile: Self Index: PopupWindow.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Player4/PopupWindow.f,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** PopupWindow.f 12 Mar 2006 17:00:40 -0000 1.2 --- PopupWindow.f 12 Apr 2006 19:44:24 -0000 1.3 *************** *** 8,25 **** 0 value _hwnd ! : ClosePopupWindow ( - ) _hwnd call DestroyWindow drop ; POPUPBAR PopupOnRecord POPUP " " ! MENUITEM "Play file" PlaySelectedFromTreeView ClosePopupWindow ; ! MENUITEM "Request record" RequestRecord ClosePopupWindow ; ! MENUITEM "Exit menu" ClosePopupWindow ; ENDBAR :Object PopupWindow <super Window ColorObject FrmColor \ the background color ! ! :M ClassInit: ( -- ) ClassInit: super PopupOnRecord SetPopupBar: Self ;M --- 8,27 ---- 0 value _hwnd ! ! defer ClosePopupWindow ' noop is ClosePopupWindow POPUPBAR PopupOnRecord POPUP " " ! MENUITEM "Play file" ClosePopupWindow PlaySelectedFromTreeView ; ! MENUITEM "Request record" ClosePopupWindow RequestRecord ; ! MENUITEM "Exit menu" ClosePopupWindow ; ENDBAR :Object PopupWindow <super Window + int focus ColorObject FrmColor \ the background color ! :M ClassInit: ( -- ) ClassInit: super PopupOnRecord ! SetPopupBar: Self true to Focus ;M *************** *** 27,44 **** : StartPopup ( -- ) 0 WM_RBUTTONDOWN GetHandle: self Call PostMessage drop ; - :M On_Init: ( -- ) COLOR_BTNFACE Call GetSysColor NewColor: FrmColor ;M :M WindowStyle: ( -- style ) WS_POPUP ;M :M StartSize: ( -- width height ) 70 30 ;M :M StartPos: ( -- x y ) mousex mousey ;M :M WM_LBUTTONDOWN ( h m w l -- res ) 2drop 0 close: Self 0 ;M ! :M On_KillFocus: ( h m w l -- ) 2drop 0 SetFocus: self ;M :M On_Paint: ( -- ) ! hwnd to _hwnd ! \ SetActiveWindow: Self ! 0 0 GetSize: self Addr: FrmColor FillArea: dc ! _hwnd start: PopupOnRecord ! StartPopup ;M ;Object --- 29,52 ---- : StartPopup ( -- ) 0 WM_RBUTTONDOWN GetHandle: self Call PostMessage drop ; :M WindowStyle: ( -- style ) WS_POPUP ;M :M StartSize: ( -- width height ) 70 30 ;M :M StartPos: ( -- x y ) mousex mousey ;M :M WM_LBUTTONDOWN ( h m w l -- res ) 2drop 0 close: Self 0 ;M ! :M On_KillFocus: ( h m w l -- ) 2drop focus if SetFocus: self then ;M :M On_Paint: ( -- ) ! focus ! if hwnd to _hwnd ! 0 0 GetSize: self Addr: FrmColor FillArea: dc ! _hwnd start: PopupOnRecord ! StartPopup ! then ;M + + :M On_Done: ( h m w l -- res ) On_Done: super 0 ;M + + :noname ( - ) false to focus + _hwnd call DestroyWindow drop + ; is ClosePopupWindow ;Object Index: Catalog.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Player4/Catalog.f,v retrieving revision 1.30 retrieving revision 1.31 diff -C2 -d -r1.30 -r1.31 *** Catalog.f 5 Apr 2006 16:50:07 -0000 1.30 --- Catalog.f 12 Apr 2006 19:44:24 -0000 1.31 *************** *** 56,59 **** --- 56,61 ---- string: DatFile$ + also configdef + : InitFileNames ( - ) current-dir$ count 2dup database$ place 2dup index$ place DatFile$ place *************** *** 115,119 **** sizeof RecordDef dup to record-size mkstruct: InlineRecord - : >RecordDef ( - rel ) s" 0 RecordDef " EVALUATE ; IMMEDIATE : file-exist? ( adr len -- true-if-file-exist ) file-status nip 0= ; : file-size>s ( fileid -- len ) file-size drop d>s ; --- 117,120 ---- *************** *** 271,275 **** ; - : delete-record ( n - ) dup true swap n>record dup>r RecordDef Deleted- c! --- 272,275 ---- *************** *** 318,327 **** ! >RecordDef File_name /file_name key: FileNameKey ! >RecordDef MediaLabel 255 key: FlexKey ! >RecordDef RandomLevel 1 cells key: RandomKey RandomKey bin-sort ! >RecordDef #played 1 cells key: leastPlayedKey leastPlayedKey bin-sort ! >RecordDef FileSize 1 cells key: FileSizeKey FileSizeKey bin-sort ! >RecordDef Request- 1 cells 2/ key: RequestKey RequestKey Descending word-sort : &FlexKeyLen ( - &FlexKeyLen ) FlexKey &key-len ; --- 318,327 ---- ! 0 RecordDef File_name previous /file_name key: FileNameKey ! 0 RecordDef MediaLabel previous 255 key: FlexKey ! 0 RecordDef RandomLevel previous 1 cells key: RandomKey RandomKey bin-sort ! 0 RecordDef #played previous 1 cells key: leastPlayedKey leastPlayedKey bin-sort ! 0 RecordDef FileSize previous 1 cells key: FileSizeKey FileSizeKey bin-sort ! 0 RecordDef Request- previous 1 cells 2/ key: RequestKey RequestKey Descending word-sort : &FlexKeyLen ( - &FlexKeyLen ) FlexKey &key-len ; *************** *** 331,335 **** : by_record ( - FlexKey ) ! /Record &FlexKeyLen ! FlexKey @ >RecordDef Artist MinFlexKey! FlexKey ; --- 331,335 ---- : by_record ( - FlexKey ) ! /Record &FlexKeyLen ! FlexKey @ 0 RecordDef Artist MinFlexKey! FlexKey ; *************** *** 382,386 **** : Level-request ( n - ) dup request? ! if n>record 1 swap RequestLevelRecord c! else drop then --- 382,386 ---- : Level-request ( n - ) dup request? ! if n>record 1 swap RecordDef RequestLevelRecord c! else drop then *************** *** 445,449 **** : sort_by_size ( - ) by_FileSize sort-database ; - : SortByFlags ( - ) vadr-config >r 1 --- 445,448 ---- *************** *** 465,477 **** r@ s_Drivetype- c@ if [ /Drivetype /MediaLabel + /Record + ] literal &FlexKeyLen ! ! FlexKey @ >RecordDef DriveType MinFlexKey! then r@ s_Label- c@ if [ /MediaLabel /Record + ] literal &FlexKeyLen ! ! FlexKey @ >RecordDef MediaLabel MinFlexKey! then r@ s_Artist_Title- c@ if [ /Record ] literal &FlexKeyLen ! ! FlexKey @ >RecordDef Artist MinFlexKey! then FlexKey &key-len @ 0> --- 464,476 ---- r@ s_Drivetype- c@ if [ /Drivetype /MediaLabel + /Record + ] literal &FlexKeyLen ! ! FlexKey @ 0 RecordDef DriveType MinFlexKey! then r@ s_Label- c@ if [ /MediaLabel /Record + ] literal &FlexKeyLen ! ! FlexKey @ 0 RecordDef MediaLabel MinFlexKey! then r@ s_Artist_Title- c@ if [ /Record ] literal &FlexKeyLen ! ! FlexKey @ 0 RecordDef Artist MinFlexKey! then FlexKey &key-len @ 0> *************** *** 486,492 **** By_Random sort-database \ 1 cells to key-len ! \ >RecordDef RandomLevel to key-start sort-database-bin ! \ >RecordDef #played to key-start sort-database-bin ! \ \ >RecordDef Deleted- to key-start sort-database-bin ; --- 485,491 ---- By_Random sort-database \ 1 cells to key-len ! \ 0 RecordDef RandomLevel to key-start sort-database-bin ! \ 0 RecordDef #played to key-start sort-database-bin ! \ \ 0 RecordDef Deleted- to key-start sort-database-bin ; *************** *** 500,518 **** : mark-played ( adr - ) -1 swap RecordDef Played- c! ; : RequestDone ( adr - ) vadr-config KeepRequests c@ if drop ! else 0 swap RecordDef Request- w! then ; : EnableKeptRequest ( n - ) ! n>record dup RecordDef Request- w@ ! if 0 swap RecordDef Played- c! ! else drop then ; ! : EnableKeptRequests ( - ) for-all-records EnableKeptRequest ; internal --- 499,520 ---- : mark-played ( adr - ) -1 swap RecordDef Played- c! ; + 0 value #requests + : RequestDone ( adr - ) vadr-config KeepRequests c@ if drop ! else 0 swap RecordDef Request- w! -1 +to #requests then ; : EnableKeptRequest ( n - ) ! n>record dup RecordDef Request- c@ ! if 0 swap RecordDef Played- c! ! else drop then ; ! : EnableKeptRequests ( - ) for-all-records EnableKeptRequest ! ; internal *************** *** 586,592 **** 0 value #InCollection ! : next-not-played ( - n ) \ -1 means done. -1 database-mhndl #records-in-database last-selected-rec 0 max \ Starting from the last-selected record ! do i n>record dup>r RecordDef Excluded- c@ not r@ RecordDef Played- c@ 0= and r> RecordDef Deleted- c@ 0= and if drop i leave --- 588,606 ---- 0 value #InCollection ! : NoRequests? ( adr - flag ) #requests 0> vadr-config IgnoreRequests c@ not and ; ! : Requested? ( adr - flag ) RecordDef Request- c@ ; ! ! : next-not-played ( - n ) \ -1 means done. >>> -1 database-mhndl #records-in-database last-selected-rec 0 max \ Starting from the last-selected record ! do i n>record >r NoRequests? ! if r@ Requested? dup ! if r@ RequestDone ! then ! else ! r@ RecordDef Excluded- c@ not ! r@ Requested? not and ! ! then ! r@ RecordDef Played- c@ 0= and r> RecordDef Deleted- c@ 0= and if drop i leave *************** *** 696,706 **** ; - : RequestRecord ( - ) - vadr-config RequestLevel c@ - last-selected-rec dup EnableKeptRequest - n>record dup>r RecordDef RequestLevelRecord c! - 1 r> RecordDef Request- c! - ; - NewEditDialog RequestLevelDlg "Request level" "Enter the level to use:" "Ok" "Cancel" "" --- 710,713 ---- *************** *** 713,715 **** --- 720,724 ---- ; + previous previous previous + \s Index: Mediatree.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Player4/Mediatree.f,v retrieving revision 1.28 retrieving revision 1.29 diff -C2 -d -r1.28 -r1.29 *** Mediatree.f 5 Apr 2006 16:26:47 -0000 1.28 --- Mediatree.f 12 Apr 2006 19:44:24 -0000 1.29 *************** *** 11,15 **** 0 value hItem-last-selected - :Class MediaTree <super TreeViewControl --- 11,14 ---- *************** *** 114,120 **** : root-items ( - hPrev ) NotPlayable TVI_LAST TVI_ROOT 2>r ! TVI_ROOT TVI_LAST z" Movies" 2r@ 1 AddItemHierarical to hMovies ! TVI_ROOT TVI_LAST z" Music" 2r@ 1 AddItemHierarical dup to hMusic ! TVI_ROOT TVI_LAST z" Requests" 2r> 1 AddItemHierarical dup to hRequests dummy dup &PrevMusic ! dup &PrevMovie ! &PrevRequest ! dup &PrevMovie hArtist ! &PrevMovie hArtist ! --- 113,119 ---- : root-items ( - hPrev ) NotPlayable TVI_LAST TVI_ROOT 2>r ! z" Movies" 2r@ 1 AddItemHierarical to hMovies ! z" Music" 2r@ 1 AddItemHierarical dup to hMusic ! z" Requests" 2r> 1 AddItemHierarical dup to hRequests dummy dup &PrevMusic ! dup &PrevMovie ! &PrevRequest ! dup &PrevMovie hArtist ! &PrevMovie hArtist ! *************** *** 166,174 **** : AddRecordHierarical ( n - ) ! dup NotIncollection? over n>record Request- c@ not and if drop else ( 1306 +) >r ResetInlineRecord ! r@ n>record dup Request- c@ ! if &PrevRequest else dup CountedFilename music? if &PrevMusic --- 165,173 ---- : AddRecordHierarical ( n - ) ! dup NotIncollection? over n>record RecordDef Request- c@ not and if drop else ( 1306 +) >r ResetInlineRecord ! r@ n>record dup RecordDef Request- c@ ! if 1 +to #requests &PrevRequest else dup CountedFilename music? if &PrevMusic *************** *** 190,193 **** --- 189,193 ---- :M FillTreeView: ( -- ) 0 to #InCollection + 0 to #requests 0 to last-selected-rec tvins /tvins erase *************** *** 236,239 **** --- 236,240 ---- ;M + :M ~: ( -- ) GetHandle: self call DestroyWindow drop ;M *************** *** 241,245 **** ;Class - \ ----------------------------------------------------------------------------- \ define the child window for the left part of the main window --- 242,245 ---- *************** *** 316,326 **** to EnableNotify? - SW_RESTORE Show: self - arrow-cursor MciDebug? ! if .elapsed ! then ;M --- 316,324 ---- to EnableNotify? SW_RESTORE Show: self arrow-cursor MciDebug? ! if .elapsed ! then ;M *************** *** 331,336 **** --- 329,346 ---- then ;M + :noname ( - ) + vadr-config RequestLevel c@ + last-selected-rec dup EnableKeptRequest + n>record dup>r RecordDef RequestLevelRecord c! + 1 r> RecordDef Request- c! + 1 +to #requests + 0 to last-selected-rec + \ SortCatalog + ; is RequestRecord + ;Object + + \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ End of File |
|
From: bob a. <rd...@us...> - 2006-04-11 17:37:14
|
Update of /cvsroot/win32forth/win32forth/src/tools In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv6784 Modified Files: tools.f Log Message: use prepend<home>\ so tools can be used from outside build directory Index: tools.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/tools/tools.f,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** tools.f 8 Apr 2006 19:40:38 -0000 1.3 --- tools.f 11 Apr 2006 17:37:02 -0000 1.4 *************** *** 9,19 **** INTERNAL EXTERNAL \ externally available definitions start here - create forthbase ," \program files\win32forth" - : sysabspath ( a1 n1 -- a2 n2) - forthbase count MakeAbsolutePath count ; defer class-browser :noname ( -- ) \ load the class and vocabulary browser turnkeyed? 0= ! \in-system-ok IF s" src\Tools\ClassBrowser.f" sysabspath INCLUDED then ; is class-browser --- 9,16 ---- INTERNAL EXTERNAL \ externally available definitions start here defer class-browser :noname ( -- ) \ load the class and vocabulary browser turnkeyed? 0= ! \in-system-ok IF s" src\Tools\ClassBrowser.f" Prepend<home>\ INCLUDED then ; is class-browser *************** *** 21,25 **** :noname ( -- ) \ load the help-system turnkeyed? 0= ! \in-system-ok IF s" src\Tools\HelpSystem.f" sysabspath INCLUDED THEN ; is help-system --- 18,22 ---- :noname ( -- ) \ load the help-system turnkeyed? 0= ! \in-system-ok IF s" src\Tools\HelpSystem.f" Prepend<home>\ INCLUDED THEN ; is help-system *************** *** 27,31 **** :noname ( -- ) \ load the xref tool turnkeyed? 0= ! \in-system-ok IF >system s" src\Tools\xref.f" sysabspath INCLUDED system> THEN ; is xref --- 24,28 ---- :noname ( -- ) \ load the xref tool turnkeyed? 0= ! \in-system-ok IF >system s" src\Tools\xref.f" Prepend<home>\ INCLUDED system> THEN ; is xref *************** *** 33,37 **** :noname ( -- ) \ load the DexH tool turnkeyed? 0= ! \in-system-ok IF >system s" src\Tools\w32fdexh.f" sysabspath INCLUDED system> THEN ; is dexh --- 30,34 ---- :noname ( -- ) \ load the DexH tool turnkeyed? 0= ! \in-system-ok IF >system s" src\Tools\w32fdexh.f" Prepend<home>\ INCLUDED system> THEN ; is dexh |
|
From: bob a. <rd...@us...> - 2006-04-08 19:47:18
|
Update of /cvsroot/win32forth/win32forth/src/kernel In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2638 Modified Files: fkernel.f Log Message: added 'slow' which uses 'slfactor' to slow loading to be able to see warnings Index: fkernel.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/kernel/fkernel.f,v retrieving revision 1.26 retrieving revision 1.27 diff -C2 -d -r1.26 -r1.27 *** fkernel.f 25 Feb 2006 08:33:53 -0000 1.26 --- fkernel.f 8 Apr 2006 19:46:58 -0000 1.27 *************** *** 4273,4279 **** mov eax, VHEAD VOC#0 - [ecx] \ fetch header word to execute exec c; ! : HEADER ( -<name>- ) \ build a header ! BL WORD COUNT (HEADER) ; \ self-call the header word in-system --- 4273,4280 ---- mov eax, VHEAD VOC#0 - [ecx] \ fetch header word to execute exec c; ! 0 value slfactor \ adjust this to slow down loading ! : SLOW ( -- ) slfactor ms ; \ set 'slfactor' to slow down loading : HEADER ( -<name>- ) \ build a header ! BL WORD COUNT (HEADER) slow ; \ self-call the header word in-system |
1040 messages has been excluded from this view by a project administrator.
