Menu
▾
▴
[Win32forth-cvs] win32forth/src CONTROLS.F, 1.13, 1.14 Class.f, 1.44, 1.45 GENERIC.F, 1.30, 1.31 Primutil.f, 1.64, 1.65 SEE.F, 1.13, 1.14 WINMSG.F, 1.6, 1.7 Window.f, 1.33, 1.34
|
From: George H. <geo...@us...> - 2013-11-20 12:28:38
|
Update of /cvsroot/win32forth/win32forth/src In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv21636 Modified Files: CONTROLS.F Class.f GENERIC.F Primutil.f SEE.F WINMSG.F Window.f Log Message: Added UserObject: (see new version of TEMPRECT in class.f) for example of use (easy). Made rectangles in windows all use a User object (it's task safe). WaitforMessage now forwards WM_QUIT to the outer message loop. Added UserObject: to see and improved seeing of switches. Minor tidy up. Index: WINMSG.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/WINMSG.F,v retrieving revision 1.6 retrieving revision 1.7 diff -C2 -d -r1.6 -r1.7 *** WINMSG.F 11 Jun 2007 22:26:51 -0000 1.6 --- WINMSG.F 20 Nov 2013 12:28:36 -0000 1.7 *************** *** 137,141 **** INTERNAL ! : ("message) ( f -- ) \ display message window OnTop: msg-window MessageText: msg-window --- 137,141 ---- INTERNAL ! : ("message) ( addr len f -- ) \ display message window OnTop: msg-window MessageText: msg-window Index: GENERIC.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/GENERIC.F,v retrieving revision 1.30 retrieving revision 1.31 diff -C2 -d -r1.30 -r1.31 *** GENERIC.F 15 Nov 2013 19:35:03 -0000 1.30 --- GENERIC.F 20 Nov 2013 12:28:36 -0000 1.31 *************** *** 19,31 **** \ ** any instances. \n \ ** The Global Rectangle objects wRect and WndRect ( originally ! \ ** defined in Window.f ) have been replaced by a Rectangle IVAR WinRect so that \ ** Windows in different threads don't interfere with each other's drawing \ ** operations. \n ! \ ** For backwards compatibility wRect is defined as an int which is set ! \ ** to the address of WinRect by the ClassInit: method ( and WndRect is defined as ! \ ** an alias of wRect in Window.f. Also ) however WinRect should be used in new ! \ ** code since it uses early binding. ClientRect in class EditControl ( in Controls.f ) ! \ ** is also defined as an alias of wRect for compatibility. \n ! \ ** We also provide wRect as an alias of TempRect for compatibility. \n --- 19,27 ---- \ ** any instances. \n \ ** The Global Rectangle objects wRect and WndRect ( originally ! \ ** defined in Window.f ) are now synonyms of temprect ( defined in class.f ) ! \ ** which has been made a User Object so that \ ** Windows in different threads don't interfere with each other's drawing \ ** operations. \n ! *************** *** 55,58 **** --- 51,55 ---- ' TempRect Alias wRect \ Can't be made a colon def - [cdo-2008May13] + ' TempRect Alias WinRect \ Moved from control.f since it's also used by descendants of the class window. *************** *** 71,75 **** \ *G Base class for all window objects. ! \ Macros for backward compatibility : wRect.addrof s" addrof: winrect" evaluate ; immediate --- 68,72 ---- \ *G Base class for all window objects. ! (( \ Macros for backward compatibility : wRect.addrof s" addrof: winrect" evaluate ; immediate *************** *** 94,98 **** : TempRect.bottom \ synonym of wRect.bottom for backward compatibility postpone wRect.bottom ; IMMEDIATE ! in-application --- 91,95 ---- : TempRect.bottom \ synonym of wRect.bottom for backward compatibility postpone wRect.bottom ; IMMEDIATE ! )) in-application *************** *** 151,162 **** 1 bits wStatus31 ! Rectangle WinRect \ The following is for backward compatibility. Use WinRect for new code since it will \ be early bound whereas wRect will be latebound. ! int wRect ! synonym tempRect wRect \ ----------------------------------------------------------------- --- 148,159 ---- 1 bits wStatus31 ! \ Rectangle WinRect \ The following is for backward compatibility. Use WinRect for new code since it will \ be early bound whereas wRect will be latebound. ! \ int wRect ! \ synonym tempRect wRect \ ----------------------------------------------------------------- *************** *** 206,210 **** \in-system-ok if link-window then \ turnkeyed application so skip linking dialoglink off \ added Sonntag, Juni 04 2006 dbu ! addr: WinRect to wRect ;M --- 203,207 ---- \in-system-ok if link-window then \ turnkeyed application so skip linking dialoglink off \ added Sonntag, Juni 04 2006 dbu ! \ addr: WinRect to wRect ;M Index: CONTROLS.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/CONTROLS.F,v retrieving revision 1.13 retrieving revision 1.14 diff -C2 -d -r1.13 -r1.14 *** CONTROLS.F 6 Nov 2013 21:56:29 -0000 1.13 --- CONTROLS.F 20 Nov 2013 12:28:36 -0000 1.14 *************** *** 22,25 **** --- 22,27 ---- cr .( Loading Low Level Controls...) + synonym ClientRect wRect + \ *W <a name="EditControl"></a> \ *S EditControl class *************** *** 35,58 **** int pWmKillFocus \ function returns '0' if it handled message, non-zero otherwise - \ For backwards compatibility. NOTE must be defined with synonym for typing in the object compiler. - synonym ClientRect wRect \ made colon defs - [cdo-2008May13]. Undone Tuesday, February 09 2010 gah. - synonym ClientRect.addrof wRect.addrof - synonym ClientRect.left wRect.left - synonym ClientRect.right wRect.right - synonym ClientRect.top wRect.top - \ Synonym ClientRect.bottom wRect.bottom - \ : ClientRect \ synonym of wRect - for backwards compatibility - \ wRect ; - \ : ClientRect.addrof \ synonym of wRect.addrof - for backwards compatibility - \ wRect.addrof ; - \ : ClientRect.left \ synonym of wRect.left - for backwards compatibility - \ wRect.left ; - \ : ClientRect.right \ synonym of wRect.right - for backwards compatibility - \ wRect.right ; - \ : ClientRect.top \ synonym of wRect.top - for backwards compatibility - \ wRect.top ; - \ : ClientRect.bottom \ synonym of wRect.bottom - for backwards compatibility - \ wRect.bottom ; - :M ClassInit: ( -- ) \ *G Initialise the class. --- 37,40 ---- Index: Class.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/Class.f,v retrieving revision 1.44 retrieving revision 1.45 diff -C2 -d -r1.44 -r1.45 *** Class.f 6 Nov 2013 21:56:29 -0000 1.44 --- Class.f 20 Nov 2013 12:28:36 -0000 1.45 *************** *** 13,20 **** REQUIRE CLASS-ERRS.F - -4105 constant warn_clash - - throw_msgs link, warn_clash , ," has a hash value that is already recognised by this class." - true value ?win-error-enabled \ initially errors are enabled --- 13,16 ---- *************** *** 24,27 **** --- 20,27 ---- IN-SYSTEM + -4105 constant warn_clash + + throw_msgs link, warn_clash , ," has a hash value that is already recognised by this class." + : @word ( -<word>- addr ) bl word uppercase ; *************** *** 369,374 **** r> r> swap XFA ! ; \ restore XFA contents ! : (Building) ( #elems ^class OR ^class -- ) ! doObj , \ cfa dup , \ class here (newObject) ! --- 369,373 ---- r> r> swap XFA ! ; \ restore XFA contents ! : <Building> ( #elems ^class OR ^class -- ) dup , \ class here (newObject) ! *************** *** 378,381 **** --- 377,383 ---- ClassInit ; \ send CLASSINIT: message + : (Building) ( #elems ^class OR ^class -- ) + doObj , <Building> ; \ cfa + : (|Build) ( #elems ^class OR ^class -- ) \ Build an instance of a class ^class *************** *** 404,411 **** in-previous - external - \ ( <number_of_elements> theClass -- ) ! : (heapObj) { theClass \ dLen obAddr idWid #els -- } 0 to #els theClass DFA @ to dLen --- 406,411 ---- in-previous \ ( <number_of_elements> theClass -- ) ! : (heapObj) { theClass \ dLen obAddr idWid #els -- addr } 0 to #els theClass DFA @ to dLen *************** *** 430,433 **** --- 430,435 ---- in-system + external + \ The following definition is executed at compile time so as long as its run-time (heapobj) is \ in application space it can go in system space *************** *** 448,451 **** --- 450,500 ---- internal + cfa-code DoUserObj + push ebx + mov ecx, 4 [eax] + add ecx, edx \ ecx is now address of pointer in user area. + mov ebx, 0 [ecx] + cmp ebx, # 0 + jne short @@3 + mov ebx, useroffs negate [edx] + and ebx, # Main-Task + test ebx, # Main-Task + je short @@1 + lea ebx, 12 [eax] + jmp short @@2 + @@1: mov ebx, 8 [eax] + push ecx + fcall (heapObj) + pop ecx + @@2: mov 0 [ecx], ebx + @@3: next + ;c + + : ?isUserObj ( cfa -- f ) + @ doUserObj = ; + + get-current also hidden definitions + + : .USEROBJECT: ( cfa -- ) + ." USEROBJECT: " dup 2 cells+ @ body> .name .name ; + + : _.USEROBJECT: ( cfa -- cfa|0 ) + -if dup ?isUserObj if .USEROBJECT: 0 then then ; + + \in-system-ok .other-class-chain chain-add _.USEROBJECT: + + previous set-current + + external + + : UserObject: ( Define: "class" "name" -- Child: -- addr ) + \ *G Create a new user variable that is a pointer to either the object following object ( for the main task only ) + \ ** or to a dynamic object on the heap ( for other tasks ). The dynamic object is only created the first time it's + \ ** referenced. The pointer is set for the main task at compile time or the first usage for a saved program. + ' dup ?isClass not THROW_NOT_CLASS ?throw >body Header DoUserObj compile, + NEXT-USER @ dup cell+ NEXT-USER ! , <building> ; + + internal + \ --------------- Build SUPER and SELF pseudo ivars --------------- *************** *** 703,713 **** \ by str. parmfind ?missing ! dup ?IsObj if 1 exit then ! dup ?IsClass if 2 exit then ! dup ?IsLocal if 4 exit then ! dup ?IsParen if 5 exit then \ needs to preceed next line, ! dup ?IsVect if 3 exit then \ because [ is a deferred word ! dup ?Is** if 6 exit then ! dup ?Is[self] if 7 exit then 1 THROW_INVALID_OBJ_REF ?throw ; --- 752,763 ---- \ by str. parmfind ?missing ! dup ?IsObj if 1 exit then ! dup ?IsClass if 2 exit then ! dup ?IsLocal if 4 exit then ! dup ?IsParen if 5 exit then \ needs to preceed next line, ! dup ?IsVect if 3 exit then \ because [ is a deferred word ! dup ?Is** if 6 exit then ! dup ?Is[self] if 7 exit then ! dup ?isUserObj if 8 exit then 1 THROW_INVALID_OBJ_REF ?throw ; *************** *** 793,796 **** --- 843,853 ---- selID Class (findm) compile, ; + : UserObj.Var, { selID ObjCfa \ Obj Class -- } + ObjCfa 3 cells+ dup NestedObject to Obj to Class obj_hstring c@ + if Class VarFind POSTPONE LITERAL + then + ObjCfa compile, Obj swap - ?dup if POSTPONE LITERAL postpone + then + selID Class (findm) compile, ; + 0 value varCfa *************** *** 825,836 **** : objRef ( selID $str -- ) \ Build a reference to an object or vector Case refToken ! 0 ( ? ) of abort endof ! 1 ( object ) of Obj.Var, endof ! 2 ( class ) of >Class (findm) , endof ! 3 ( vector ) of compile, POSTPONE (defer) , endof ! 4 ( parm ) of compile, POSTPONE (defer) , endof ! 5 ( paren ) of drop LateBound endof ! 6 ( ** ) of drop postpone (defer) , endof ! 7 ( [self] ) of drop postpone ^base postpone (defer) , endof Endcase ; --- 882,894 ---- : objRef ( selID $str -- ) \ Build a reference to an object or vector Case refToken ! 0 ( ? ) of abort endof ! 1 ( object ) of Obj.Var, endof ! 2 ( class ) of >Class (findm) , endof ! 3 ( vector ) of compile, POSTPONE (defer) , endof ! 4 ( parm ) of compile, POSTPONE (defer) , endof ! 5 ( paren ) of drop LateBound endof ! 6 ( ** ) of drop postpone (defer) , endof ! 7 ( [self] ) of drop postpone ^base postpone (defer) , endof ! 8 ( User Object ) of UserObj.Var, endof Endcase ; *************** *** 838,849 **** 0 to varCfa Case refToken ! 0 ( ? ) of abort endof ! 1 ( object ) of RunObj.Var endof ! 2 ( class ) of >Class (findm) endof ! 3 ( vector ) of execute Find-Method endof ! 4 ( parm ) of abort endof ! 5 ( paren ) of drop LateBound ['] noop endof ! 6 ( ** ) of drop swap Find-Method endof ! 7 ( [self] ) of abort endof Endcase ; --- 896,908 ---- 0 to varCfa Case refToken ! 0 ( ? ) of abort endof ! 1 ( object ) of RunObj.Var endof ! 2 ( class ) of >Class (findm) endof ! 3 ( vector ) of execute Find-Method endof ! 4 ( parm ) of abort endof ! 5 ( paren ) of drop LateBound ['] noop endof ! 6 ( ** ) of drop swap Find-Method endof ! 7 ( [self] ) of abort endof ! 8 ( User Object ) of dup execute -rot 2 cells+ @ (findm) endof Endcase ; *************** *** 903,907 **** ! : x.do_message ( -- ) x.buf (do_message) ; IMMEDIATE --- 962,966 ---- ! : x.do_message ( -- ) \ Not normally used directly x.buf (do_message) ; IMMEDIATE *************** *** 941,945 **** then x.buf find ! ( check it is obj ) ( arm) -if drop dup ?isObj then ( arm) nip ?dup 0= --- 1000,1004 ---- then x.buf find ! ( check it is obj ) ( arm) -if drop dup ?isObj over ?isUserObj or then ( arm) nip ?dup 0= *************** *** 1423,1427 **** ;Class ! RECTANGLE temprect \ a sample rectangle object, used by the system sometimes --- 1482,1486 ---- ;Class ! UserObject: RECTANGLE temprect \ a sample rectangle object, used by the system sometimes Index: SEE.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/SEE.F,v retrieving revision 1.13 retrieving revision 1.14 diff -C2 -d -r1.13 -r1.14 *** SEE.F 20 Mar 2013 23:51:21 -0000 1.13 --- SEE.F 20 Nov 2013 12:28:36 -0000 1.14 *************** *** 264,270 **** : .OTHER ( cfa -- ) - DUP .NAME .other-class-chain do-chain ?dup ! if DUP @ OVER CELL+ = IF .CODE EXIT THEN \ will need changed for code sect DUP DOES>? IF .DOES> EXIT THEN .;CODE --- 264,269 ---- : .OTHER ( cfa -- ) .other-class-chain do-chain ?dup ! if DUP .NAME DUP @ OVER CELL+ = IF .CODE EXIT THEN \ will need changed for code sect DUP DOES>? IF .DOES> EXIT THEN .;CODE Index: Window.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/Window.f,v retrieving revision 1.33 retrieving revision 1.34 diff -C2 -d -r1.33 -r1.34 *** Window.f 15 Nov 2013 19:35:03 -0000 1.33 --- Window.f 20 Nov 2013 12:28:36 -0000 1.34 *************** *** 42,56 **** \ ------------------------------------------------------------ :CLASS Window <SUPER Generic-Window \ *G Base class for window objects. - \ The following synonyms replace the original global rectangle object - \ and dotted notations for it, for backward compatibility: see Generic.f - synonym WndRect.addrof wRect.addrof - synonym WndRect.left wRect.left - synonym WndRect.right wRect.right - synonym WndRect.top wRect.top - synonym WndRect.bottom wRect.bottom - int CurrentPopup \ current right mouse popup menu int CurrentMenu \ current menubar --- 42,50 ---- \ ------------------------------------------------------------ + synonym WndRect wrect + :CLASS Window <SUPER Generic-Window \ *G Base class for window objects. int CurrentPopup \ current right mouse popup menu int CurrentMenu \ current menubar *************** *** 74,82 **** int hWndParent \ handle of the parent window (added Sonntag, Juni 04 2006 dbu) - \ The following is for backward compatibility. Use WinRect for new code since it will - \ be early bound whereas wRect will be latebound. - - synonym WndRect wrect - :M ClassInit: ( -- ) \ *G Initialise the class. --- 68,71 ---- Index: Primutil.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/Primutil.f,v retrieving revision 1.64 retrieving revision 1.65 diff -C2 -d -r1.64 -r1.65 *** Primutil.f 15 Nov 2013 19:35:03 -0000 1.64 --- Primutil.f 20 Nov 2013 12:28:36 -0000 1.65 *************** *** 80,84 **** IN-APPLICATION ! defer "message ' 2drop is "message defer "top-message ' 2drop is "top-message defer message-off ' noop is message-off --- 80,84 ---- IN-APPLICATION ! defer "message ( addr len -- ) ' 2drop is "message defer "top-message ' 2drop is "top-message defer message-off ' noop is message-off *************** *** 850,855 **** 7 cells LocalAlloc: pMsg 0 0 0 pMsg Call GetMessage ! IF pMsg HandleMessages drop ! THEN ; --- 850,856 ---- 7 cells LocalAlloc: pMsg 0 0 0 pMsg Call GetMessage ! IF pMsg HandleMessages ! ELSE 0 Call PostQuitMessage ! THEN drop ; |
