Menu
▾
▴
[Win32forth-cvs] win32forth/src/lib AXControl.F,1.1,1.2 FCOM.F,1.1,1.2 FlashControl.F,1.1,1.2 HTMLcontrol.F,1.1,1.2 PDFControl.F,1.1,1.2
|
From: Dirk B. <db...@us...> - 2005-09-18 11:10:41
|
Update of /cvsroot/win32forth/win32forth/src/lib In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv13823/src/lib Modified Files: AXControl.F FCOM.F FlashControl.F HTMLcontrol.F PDFControl.F Log Message: - Moved the demo code for the new ActiveX controls into seperate files in the Demos-Folder - Added two new tool's for exploring ActiveX controls - Added some notes about the new COM and ActiveX support to the release notes. Index: AXControl.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/lib/AXControl.F,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** AXControl.F 15 Sep 2005 16:31:38 -0000 1.1 --- AXControl.F 18 Sep 2005 11:10:31 -0000 1.2 *************** *** 1,6 **** \ ActiveX Control Class \ Thomas Dixon - anew -AXControl.F --- 1,7 ---- + \ $Id$ + \ ActiveX Control Class \ Thomas Dixon anew -AXControl.F *************** *** 40,47 **** \s window win start: win axcontrol ax win start: ax ! s" MSCAL.Calendar.7" axcreate: ax autosize: ax --- 41,79 ---- \s + \ AXControl is a class that can be treated like any other control in + \ win32forth, except it is enabled to host an activex component. A short + \ example of it's usage: + window win start: win axcontrol ax win start: ax ! s" MSCAL.Calendar" axcreate: ax autosize: ax + + \ The example here hosts a calandar control by it's progid. + \ In order to see this work properly, you need to have that activex + \ control installed on your machine. ProgID's may also have some + \ version control to them. "MSCAL.Calendar.7" as the progid would + \ only host version 7 of the caladar control. + \ + \ You may also use the string of the clsid that you want to use instead of + \ the progid, if it suits your purposes better. Ex: + \ + \ s" {8E27C92B-1264-101C-8A2F-040224009C02}" axcreate: ax + \ autosize: ax + \ + \ You may also use a url if you want: + \ + \ s" http://www.google.com" axcreate: ax + \ autosize: ax + \ + \ You may also give it html code, if it is proceeded by "MSHTML:" Ex: + \ + \ s" MSHTML:<HTML><BODY>Hello World!</BODY></HTML>" axcreate: ax + \ autosize: ax + \ + \ + \ Just having the control there is nice, but the REAL trick is to + \ communicate with it and exchange data back and forth. The way that + \ this is done is by getting the control's interface and using it. Index: FlashControl.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/lib/FlashControl.F,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** FlashControl.F 15 Sep 2005 16:31:38 -0000 1.1 --- FlashControl.F 18 Sep 2005 11:10:31 -0000 1.2 *************** *** 1,5 **** --- 1,9 ---- + \ $Id$ + \ Shockwave Flash control written in forth \ Tom Dixon + anew -FlashControl + needs AXControl *************** *** 53,102 **** \ We don't need the typelibrary anymore, so unload it now. - free-lasttypelib \s ! \ Example: ! ! :class Flashwin <super window ! Flashcontrol fcntrl ! ! :M On_Init: ( -- ) ! On_Init: super ! self Start: fcntrl ;M ! ! :M On_Size: ( h m w -- ) 2drop drop autosize: fcntrl ;M ! ! \ ShockWave Methods ! :M PutMovie: ( str len -- f ) PutMovie: fcntrl ;M ! :M GetMovie: ( -- str len ) GetMovie: fcntrl ;M ! :M Play: ( -- ) Play: fcntrl ;M ! :M Stop: ( -- ) Stop: fcntrl ;M ! :M Back: ( -- ) Back: fcntrl ;M ! :M Forward: ( -- ) Forward: fcntrl ;M ! :M Rewind: ( -- ) Rewind: fcntrl ;M ! :M StopPlay: ( -- ) StopPlay: fcntrl ;M ! :M GotoFrame: ( n -- ) GotoFrame: fcntrl ;M ! :M CurrentFrame: ( -- n ) CurrentFrame: fcntrl ;M ! :M TotalFrames: ( -- n ) TotalFrames: fcntrl ;M ! :M Playing?: ( -- flag ) Playing?: fcntrl ;M ! :M Loaded%: ( -- percent ) Loaded%: fcntrl ;M ! :M Loop: ( flag -- ) Loop: fcntrl ;M ! :M Loop?: ( -- flag ) Loop?: fcntrl ;M ! :M Pan: ( n n n -- ) Pan: fcntrl ;M ! :M Zoom: ( n -- ) Zoom: fcntrl ;M ! :M SetZoomRect: ( n n n n -- ) SetZoomRect: fcntrl ;M ! :M BGColor: ( -- color ) BGColor: fcntrl ;M ! :M SetBGColor: ( color -- ) SetBGColor: fcntrl ;M ! ! ;class ! ! Flashwin fwin ! start: fwin ! 0 setbgcolor: fwin ! s" c:\temp\swf\f02[1].swf" putmovie: fwin drop ! true loop: fwin ! ! ! ! --- 57,62 ---- \ We don't need the typelibrary anymore, so unload it now. free-lasttypelib \s ! for an example see demos\FlashControlDemo.f Index: HTMLcontrol.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/lib/HTMLcontrol.F,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** HTMLcontrol.F 15 Sep 2005 16:31:38 -0000 1.1 --- HTMLcontrol.F 18 Sep 2005 11:10:31 -0000 1.2 *************** *** 1,5 **** --- 1,8 ---- + \ $Id$ + \ HTML Control \ Thomas Dixon + anew -HtmlControl.f needs AXControl *************** *** 54,96 **** \ We don't need the typelibrary anymore, so unload it now. - free-lasttypelib - \s ! ! \ Example: ! \ Create a simple browser window ! ! :class Browserwin <super window ! HTMLcontrol html ! ! :M On_Init: ( -- ) ! On_Init: super ! self Start: html ;M ! ! :M On_Size: ( h m w -- ) 2drop drop autosize: html ;M ! ! :M GetPath: ( -- str len ) GetPath: html ;M ! :M GetLocationURL: ( -- str len ) GetLocationURL: html ;M ! :M GetLocationName: ( -- str len ) GetLocationName: html ;M ! :M Busy?: ( -- flag ) Busy?: html ;M ! :M GoHome: ( -- ) GoHome: html ;M ! :M GoSearch: ( -- ) GoSearch: html ;M ! :M GoForward: ( -- ) GoForward: html ;M ! :M GoBack: ( -- ) GoBack: html ;M ! :M Refresh: ( -- ) Refresh: html ;M ! :M Stop: ( -- ) Stop: html ;M ! :M GoURL: ( str len -- ) GoURL: html ;M ! ! ;class ! ! BrowserWin bwin ! start: bwin ! \ gohome: bwin ! s" www.win32forth.org" GoURL: bwin ! \ and you should have a browser window at your home page ! ! ! ! --- 57,62 ---- \ We don't need the typelibrary anymore, so unload it now. free-lasttypelib \s ! \ Example: see demos\HtmlControlDemo.f Index: PDFControl.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/lib/PDFControl.F,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** PDFControl.F 15 Sep 2005 16:31:38 -0000 1.1 --- PDFControl.F 18 Sep 2005 11:10:31 -0000 1.2 *************** *** 1,5 **** --- 1,8 ---- + \ $Id$ + \ Acrobat PDF Control \ Thomas Dixon + anew -PdfControl.f needs AXControl *************** *** 91,145 **** ;CLASS - \s - \ Example: - \ Create a simple pdf window - - :class PDFwin <super window - PDFControl pdf - - :M On_Init: ( -- ) - On_Init: super - self Start: pdf ;M - - :M On_Size: ( h m w -- ) 2drop drop autosize: pdf ;M - - :M LoadFile: ( str len -- flag ) LoadFile: pdf ;M - :M SetPage: ( n -- ) SetPage: pdf ;M - :M gotoFirstPage: ( -- ) gotoFirstPage: pdf ;M - :M gotoLastPage: ( -- ) gotoLastPage: pdf ;M - :M gotoNextPage: ( -- ) gotoNextPage: pdf ;M - :M gotoPreviousPage: ( -- ) gotoPreviousPage: pdf ;M - :M goForward: ( -- ) goForward: pdf ;M - :M goBack: ( -- ) goBack: pdf ;M - - :M Print: ( -- ) Print: pdf ;M - :M PrintWithDialog: ( -- ) PrintWithDialog: pdf ;M - :M PrintPages: ( n n -- ) PrintPages: pdf ;M - :M PrintPagesFit: ( flag n n -- ) PrintPagesFit: pdf ;M - :M PrintAll: ( -- ) PrintAll: pdf ;M - :M PrintAllFit: ( bool -- ) PrintAllFit: pdf ;M - - :M SetZoom: ( float -- ) SetZoom: pdf ;M - :M SetZoomScroll: ( float float float -- ) SetZoomScroll: pdf ;M - :M SetViewRect: ( float float float float -- ) SetViewRect: pdf ;M - - :M SetPageMode: ( str len -- ) SetPageMode: pdf ;M - :M SetLayoutMode: ( str len -- ) SetLayoutMode: pdf ;M - :M SetNamedDest: ( str len -- ) SetNamedDest: pdf ;M - - :M SetShowToolbar: ( flag -- ) SetShowToolbar: pdf ;M - :M SetShowScrollbars: ( flag -- ) SetShowScrollbars: pdf ;M - - :M Aboutbox: ( -- ) Aboutbox: pdf ;M - ;class - - pdfwin pwin - start: pwin - s" doc\Forth_Primer.pdf" Prepend<home>\ loadfile: pwin drop - - \ This should load a pdf file and display it in a window - \ I don't think the PDF viewer was ever ment to be used as an embedded control \ It only supports the dispatch interface and updates (such as resizing) are rather slow ! --- 94,100 ---- ;CLASS \ I don't think the PDF viewer was ever ment to be used as an embedded control \ It only supports the dispatch interface and updates (such as resizing) are rather slow ! \s ! \ Example: see demos/PdfControlDemo.f Index: FCOM.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/lib/FCOM.F,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** FCOM.F 15 Sep 2005 16:31:38 -0000 1.1 --- FCOM.F 18 Sep 2005 11:10:31 -0000 1.2 *************** *** 26,30 **** 3 proc LHashValOfNameSys ! DEFINED ISTR= NIP 0= [IF] synonym ISTR= STR(NC)= [THEN] \ unicode string functions --- 26,30 ---- 3 proc LHashValOfNameSys ! [UNDEFINED] ISTR= [IF] synonym ISTR= STR(NC)= [THEN] \ unicode string functions *************** *** 50,54 **** dup >r 2swap swap 0 0 WideCharToMultiByte drop r> zcount ; ! : >Unicode ( str len -- str len ) asc>uni 2dup new$ dup >r uniplace drop free drop r> unicount ; --- 50,54 ---- dup >r 2swap swap 0 0 WideCharToMultiByte drop r> zcount ; ! : >Unicode ( str len -- str len ) asc>uni 2dup new$ dup >r uniplace drop free drop r> unicount ; *************** *** 65,77 **** \ Defining GUIDs : hatoi number? 2drop ; ! : Guid, ( -- ) \ comments in a guid ! Base @ HEX BL Word count dup 38 <> abort" Invalid Guid Length" 1 /string 2dup ascii - scan 2dup >r >r nip - hatoi , r> r> ascii - skip 2dup ascii - scan 2dup >r >r nip - hatoi w, r> r> ascii - skip 2dup ascii - scan 2dup >r >r nip - hatoi w, r> r> ascii - skip 2dup drop 2 0 do dup i 2 * + 2 hatoi c, loop drop ! ascii - scan ascii - skip drop 6 0 do dup i 2 * + 2 hatoi c, loop drop base ! ; : CLSID>Str ( addr -- str len ) --- 65,82 ---- \ Defining GUIDs + internal : hatoi number? 2drop ; + external ! : (Guid,) ( addr len -- ) \ comments in a guid ! Base @ >r HEX dup 38 <> abort" Invalid Guid Length" 1 /string 2dup ascii - scan 2dup >r >r nip - hatoi , r> r> ascii - skip 2dup ascii - scan 2dup >r >r nip - hatoi w, r> r> ascii - skip 2dup ascii - scan 2dup >r >r nip - hatoi w, r> r> ascii - skip 2dup drop 2 0 do dup i 2 * + 2 hatoi c, loop drop ! ascii - scan ascii - skip drop 6 0 do dup i 2 * + 2 hatoi c, loop drop r> base ! ; ! ! : Guid, ( -- ) \ comments in a guid ! BL Word count (Guid,) ; : CLSID>Str ( addr -- str len ) *************** *** 91,95 **** : COMPILE-INTERFACE ( pointer imethod -- ) \ fast compile interface call ! POSTPONE @ POSTPONE dup POSTPONE @ cell+ @ cells POSTPONE lit , POSTPONE + POSTPONE @ POSTPONE call-proc ; --- 96,100 ---- : COMPILE-INTERFACE ( pointer imethod -- ) \ fast compile interface call ! POSTPONE @ POSTPONE dup POSTPONE @ cell+ @ cells POSTPONE lit , POSTPONE + POSTPONE @ POSTPONE call-proc ; *************** *** 110,115 **** : ComIFace ( interface -- ) create 0 , 16 + , IMMEDIATE does> state @ if dup POSTPONE lit , then ! dup peek rot cell+ @ search-iface ! if state @ if COMPILE-INTERFACE else RUN-INTERFACE then skip-word then state @ if drop then ; --- 115,120 ---- : ComIFace ( interface -- ) create 0 , 16 + , IMMEDIATE does> state @ if dup POSTPONE lit , then ! dup peek rot cell+ @ search-iface ! if state @ if COMPILE-INTERFACE else RUN-INTERFACE then skip-word then state @ if drop then ; *************** *** 119,126 **** : IMethod ( n -- ) \ n is vtable index ! here openiface 16 + @ , openiface 16 + ! , , ! here parse-word dup 1+ allot rot place ; ! : UCOM ( pointer -- ) \ call using an interface bl word find if execute else count type abort" Not an interface!" then peek rot 16 + search-iface --- 124,131 ---- : IMethod ( n -- ) \ n is vtable index ! here openiface 16 + @ , openiface 16 + ! , , ! here parse-word dup 1+ allot rot place ; ! : UCOM ( pointer -- ) \ call using an interface bl word find if execute else count type abort" Not an interface!" then peek rot 16 + search-iface *************** *** 241,246 **** \ Quick Structures - Not very usefull for anything but working with ! \ Com Interface structures, I wanted something simple that would allow ! \ levels of unions and stuff, so I made a quick structure thing. \ structure type --- 246,251 ---- \ Quick Structures - Not very usefull for anything but working with ! \ Com Interface structures, I wanted something simple that would allow ! \ levels of unions and stuff, so I made a quick structure thing. \ structure type *************** *** 392,396 **** 4 field: rgdispidNamedArgs \ Dispatch IDs of named arguments. 8 field: cArgs \ Number of arguments. ! 12 field: cNamedArgs \ Number of named arguments. close-struct --- 397,401 ---- 4 field: rgdispidNamedArgs \ Dispatch IDs of named arguments. 8 field: cArgs \ Number of arguments. ! 12 field: cNamedArgs \ Number of named arguments. close-struct *************** *** 483,487 **** $FFF constant VT_TYPEMASK \ used as a mask for vt_vector, array and what-not ! internal : vt>Str ( vt -- str len ) \ for type to string conversion --- 488,492 ---- $FFF constant VT_TYPEMASK \ used as a mask for vt_vector, array and what-not ! internal : vt>Str ( vt -- str len ) \ for type to string conversion *************** *** 634,638 **** else dup 0 ?do 42 emit loop nip 0 ?do usestruct typedesc lptdesc @ loop 0 >r rp@ swap usestruct typedesc hreftype @ argtypei UCOM ITypeinfo Getreftypeinfo drop ! 0 0 0 rp@ 0 >r rp@ -1 rot UCOM ITypeinfo GetDocumentation drop r@ zunicount unitype r> drop rp@ UCOM ITypeinfo ireleaseref drop r> drop 0 to argtypei then ; --- 639,643 ---- else dup 0 ?do 42 emit loop nip 0 ?do usestruct typedesc lptdesc @ loop 0 >r rp@ swap usestruct typedesc hreftype @ argtypei UCOM ITypeinfo Getreftypeinfo drop ! 0 0 0 rp@ 0 >r rp@ -1 rot UCOM ITypeinfo GetDocumentation drop r@ zunicount unitype r> drop rp@ UCOM ITypeinfo ireleaseref drop r> drop 0 to argtypei then ; *************** *** 656,662 **** tbuf @ usestruct funcdesc invkind @ INVOKE_PROPERTYPUT = if ." Put" then tbuf @ usestruct funcdesc invkind @ INVOKE_PROPERTYPUTREF = if ." PutRef" then ! dup 0 0 rot 0 tbuf 4 + rot tbuf @ @ swap UCOM ITypeinfo getdocumentation drop tbuf 4 + @ zunicount unitype space ." ( " ! tbuf @ usestruct funcdesc cparams w@ 0 ?do dup to argtypei tbuf @ dup usestruct funcdesc cparams w@ i - 1- arg>str space loop ." -- " --- 661,667 ---- tbuf @ usestruct funcdesc invkind @ INVOKE_PROPERTYPUT = if ." Put" then tbuf @ usestruct funcdesc invkind @ INVOKE_PROPERTYPUTREF = if ." PutRef" then ! dup 0 0 rot 0 tbuf 4 + rot tbuf @ @ swap UCOM ITypeinfo getdocumentation drop tbuf 4 + @ zunicount unitype space ." ( " ! tbuf @ usestruct funcdesc cparams w@ 0 ?do dup to argtypei tbuf @ dup usestruct funcdesc cparams w@ i - 1- arg>str space loop ." -- " *************** *** 675,685 **** tbuf @ usestruct vardesc elemdescvar tdesc vt w@ VT_USERDEFINED = if tbuf @ usestruct vardesc oInst @ . ! dup tbuf @ usestruct vardesc elemdescvar tdesc hreftype @ tbuf 4 + swap rot UCOM ITypeinfo GetRefTypeinfo drop ! 0 0 0 tbuf 8 + -1 tbuf 4 + UCOM ITypeinfo GetDocumentation drop ! tbuf 12 + tbuf 4 + UCOM Itypeinfo gettypeattr drop ! tbuf 12 + @ usestruct typeattr cbSizeInstance @ tbuf 12 + @ tbuf 4 + UCOM Itypeinfo releasetypeattr drop ! 4 > if tbuf 8 + @ zunicount unitype tbuf 4 + UCOM ITypeinfo ireleaseref drop ." Struct: " else --- 680,690 ---- tbuf @ usestruct vardesc elemdescvar tdesc vt w@ VT_USERDEFINED = if tbuf @ usestruct vardesc oInst @ . ! dup tbuf @ usestruct vardesc elemdescvar tdesc hreftype @ tbuf 4 + swap rot UCOM ITypeinfo GetRefTypeinfo drop ! 0 0 0 tbuf 8 + -1 tbuf 4 + UCOM ITypeinfo GetDocumentation drop ! tbuf 12 + tbuf 4 + UCOM Itypeinfo gettypeattr drop ! tbuf 12 + @ usestruct typeattr cbSizeInstance @ tbuf 12 + @ tbuf 4 + UCOM Itypeinfo releasetypeattr drop ! 4 > if tbuf 8 + @ zunicount unitype tbuf 4 + UCOM ITypeinfo ireleaseref drop ." Struct: " else *************** *** 707,711 **** dup tbuf i rot Ucom ITypeinfo getvardesc drop tbuf @ usestruct vardesc varkind @ VAR_CONST = ! if dup >r 0 0 0 tbuf 4 + tbuf @ @ r> UCOM ITypeInfo GetDocumentation drop tbuf 4 + @ zunicount unitype space tbuf over Ucom ITypeinfo releasevardesc drop --- 712,716 ---- dup tbuf i rot Ucom ITypeinfo getvardesc drop tbuf @ usestruct vardesc varkind @ VAR_CONST = ! if dup >r 0 0 0 tbuf 4 + tbuf @ @ r> UCOM ITypeInfo GetDocumentation drop tbuf 4 + @ zunicount unitype space tbuf over Ucom ITypeinfo releasevardesc drop *************** *** 713,720 **** : globaltype ( type typelib -- ) ! dup UCOM ITypeLib GetTypeInfoCount 0 ?do 2dup tbuf i rot UCOM ITypeLib GetTypeInfoType abort" Unable to get type info" tbuf @ = if dup 0 0 rot 0 tbuf rot i swap UCOM ITypeLib GetDocumentation ! abort" Unable to get Documentation!" tbuf @ zunicount unitype space then loop 2drop ; --- 718,725 ---- : globaltype ( type typelib -- ) ! dup UCOM ITypeLib GetTypeInfoCount 0 ?do 2dup tbuf i rot UCOM ITypeLib GetTypeInfoType abort" Unable to get type info" tbuf @ = if dup 0 0 rot 0 tbuf rot i swap UCOM ITypeLib GetDocumentation ! abort" Unable to get Documentation!" tbuf @ zunicount unitype space then loop 2drop ; *************** *** 722,729 **** create typelibhead 0 , ! external : typelib ( major minor | guid -- ) \ load a type library into the list ! here typelibhead dup @ , ! here dup >r 0 , here 0 , 2swap swap here guid, LoadRegTypeLib abort" Error Loading Type Library" --- 727,734 ---- create typelibhead 0 , ! external : typelib ( major minor | guid -- ) \ load a type library into the list ! here typelibhead dup @ , ! here dup >r 0 , here 0 , 2swap swap here guid, LoadRegTypeLib abort" Error Loading Type Library" *************** *** 731,749 **** : CoClasses ( -- ) \ print a list of all available coclasses ! cr typelibhead begin @ dup while ! dup cell+ TKIND_COCLASS swap globaltype repeat drop ; ! : Interfaces ( -- ) \ print a list of all available coclasses ! cr typelibhead begin @ dup while ! dup cell+ TKIND_INTERFACE swap globaltype ! dup cell+ TKIND_DISPATCH swap globaltype repeat drop ; ! : Structures ( -- ) \ print a list of all available coclasses ! cr typelibhead begin @ dup while ! dup cell+ TKIND_RECORD swap globaltype repeat drop ; : ComConsts ( -- ) \ print a list of all constants ! cr typelibhead begin @ dup while ! dup cell+ TKIND_ENUM swap globaltype repeat drop ; internal --- 736,754 ---- : CoClasses ( -- ) \ print a list of all available coclasses ! typelibhead begin @ dup while ! dup cell+ TKIND_COCLASS swap globaltype repeat drop ; ! : Interfaces ( -- ) \ print a list of all available interfaces ! typelibhead begin @ dup while ! dup cell+ TKIND_INTERFACE swap globaltype ! dup cell+ TKIND_DISPATCH swap globaltype repeat drop ; ! : Structures ( -- ) \ print a list of all available structures ! typelibhead begin @ dup while ! dup cell+ TKIND_RECORD swap globaltype repeat drop ; : ComConsts ( -- ) \ print a list of all constants ! typelibhead begin @ dup while ! dup cell+ TKIND_ENUM swap globaltype repeat drop ; internal *************** *** 772,776 **** : funcbind ( obj funcdesc tinfo -- ) \ function >r rp@ UCOM ITypeInfo IReleaseref drop r> drop ! dup funcoff swap CoTaskMemFree drop state @ if POSTPONE @ POSTPONE dup POSTPONE @ POSTPONE lit , POSTPONE + POSTPONE @ POSTPONE call-proc --- 777,781 ---- : funcbind ( obj funcdesc tinfo -- ) \ function >r rp@ UCOM ITypeInfo IReleaseref drop r> drop ! dup funcoff swap CoTaskMemFree drop state @ if POSTPONE @ POSTPONE dup POSTPONE @ POSTPONE lit , POSTPONE + POSTPONE @ POSTPONE call-proc *************** *** 800,804 **** : do-struct ( offset itypecomp -- offset ) peek >unicode drop swap >bind ! DESCKIND_VARDESC = if bl word drop over nested-struc? ?dup if 0 >r rp@ swap rot >r rp@ UCOM ITypeInfo GetRefTypeInfo drop --- 805,809 ---- : do-struct ( offset itypecomp -- offset ) peek >unicode drop swap >bind ! DESCKIND_VARDESC = if bl word drop over nested-struc? ?dup if 0 >r rp@ swap rot >r rp@ UCOM ITypeInfo GetRefTypeInfo drop *************** *** 866,870 **** ?dup if >r rp@ UCOM ITypeInfo IReleaseref drop r> drop then ?dup if CoTaskMemFree drop then ! ?dup if dup DESCKIND_VARDESC = swap DESCKIND_TYPECOMP = or if 2drop true exit else 2drop false exit then then swap >bindtype ?dup if --- 871,875 ---- ?dup if >r rp@ UCOM ITypeInfo IReleaseref drop r> drop then ?dup if CoTaskMemFree drop then ! ?dup if dup DESCKIND_VARDESC = swap DESCKIND_TYPECOMP = or if 2drop true exit else 2drop false exit then then swap >bindtype ?dup if *************** *** 879,888 **** repeat ; ! : comfind ( str -- str 0 | cfa flag ) [ defer@ find literal ] execute \ call previous find word ! ?dup 0= if count 0 ?typelib if ['] noop 1 else drop 1- 0 then then ; ! ' comfind is find \ Late-Binding for Types in typelibraries (needed only for interfaces and structures) --- 884,893 ---- repeat ; ! : comfind ( str -- str 0 | cfa flag ) [ defer@ find literal ] execute \ call previous find word ! ?dup 0= if count 0 ?typelib if ['] noop 1 else drop 1- 0 then then ; ! ' comfind is find \ Late-Binding for Types in typelibraries (needed only for interfaces and structures) *************** *** 911,916 **** if state @ if COMPILE-INTERFACE else RUN-INTERFACE then bl word drop then else \ automated interface ! drop typelibhead begin @ dup while ! dup 2 cells + peek rot istype? if 2 cells + parse-word 2dup tfind place >unicode drop swap >bindtype do-late exit then repeat 0= abort" Not An Interface!" --- 916,921 ---- if state @ if COMPILE-INTERFACE else RUN-INTERFACE then bl word drop then else \ automated interface ! drop typelibhead begin @ dup while ! dup 2 cells + peek rot istype? if 2 cells + parse-word 2dup tfind place >unicode drop swap >bindtype do-late exit then repeat 0= abort" Not An Interface!" *************** *** 920,936 **** : free-lasttypelib ( -- ) \ frees the last type library ! typelibhead @ ?dup if ! dup @ typelibhead ! ! dup cell+ UCOM ITypeComp IReleaseref drop 2 cells + UCOM ITypeLib IReleaseref drop then ; : freetypelibs ( -- ) typelibhead begin @ dup while ! dup cell+ UCOM ITypeComp IReleaseref drop dup 2 cells + UCOM ITypeLib IReleaseref drop repeat drop 0 typelibhead ! ; ! : com_init 0 CoInitialize drop ; Initialization-Chain Chain-Add Com_init --- 925,941 ---- : free-lasttypelib ( -- ) \ frees the last type library ! typelibhead @ ?dup if ! dup @ typelibhead ! ! dup cell+ UCOM ITypeComp IReleaseref drop 2 cells + UCOM ITypeLib IReleaseref drop then ; : freetypelibs ( -- ) typelibhead begin @ dup while ! dup cell+ UCOM ITypeComp IReleaseref drop dup 2 cells + UCOM ITypeLib IReleaseref drop repeat drop 0 typelibhead ! ; ! : com_init 0 CoInitialize drop ; Initialization-Chain Chain-Add Com_init *************** *** 947,951 **** \ through a bloated structure, and is slow. Avoid these interfaces if possible. ! \ The way to deal with it here is to pass argments on to a typed stack 16 CONSTANT maxvt \ Height of Stack --- 952,956 ---- \ through a bloated structure, and is slow. Avoid these interfaces if possible. ! \ The way to deal with it here is to pass argments on to a typed stack 16 CONSTANT maxvt \ Height of Stack *************** *** 954,964 **** DISPPARAMS Struct DispCall \ calling structure ! vtstack DispCall rgvarg ! VARIANT Struct RetVT \ return value - only one allowed :-( ! : vt@ ( addr -- n VT ) dup w@ swap 8 + over argcells 2 = if 2@ rot else @ swap then ; ! : vt! ( n VT addr -- ) 2dup w! 8 + swap argcells 2 = if 2! else ! then ; --- 959,969 ---- DISPPARAMS Struct DispCall \ calling structure ! vtstack DispCall rgvarg ! VARIANT Struct RetVT \ return value - only one allowed :-( ! : vt@ ( addr -- n VT ) dup w@ swap 8 + over argcells 2 = if 2@ rot else @ swap then ; ! : vt! ( n VT addr -- ) 2dup w! 8 + swap argcells 2 = if 2! else ! then ; *************** *** 969,1016 **** 16 * DispCall rgvarg @ + vt@ else 0 VT_EMPTY then ; ! ! : >VT ( n VT -- ) \ push Virtual Type onto Stack ! DispCall cargs @ dup maxvt < if ! 16 * DispCall rgvarg @ + vt! 1 DispCall cargs +! else abort" Variant Stack Full!" then ; ! : .vt ( -- ) DispCall cargs @ 0 ?do ! DispCall rgvarg @ i 16 * + vt@ dup vt>str type ." : " argcells 2 = if d. else . then loop ; ! internal variable disperr : DispatchCall ( type ID Interface -- hres ) \ Call IDispatch Invoke method ! 2>r >r disperr 0 RetVT DispCall r> 0 GUID_NULL 2r> UCOM IDispatch Invoke 0 DispCall cargs ! ; ! : GetDispID ( ustr Interface -- ID ) \ Get Dispatch ID ! swap >r rp@ swap disperr 0 2swap 1 -rot GUID_NULL swap ! UCOM IDispatch GetIDsOfNames r> drop if 0 else disperr @ then ; ! : methkind ( str len -- ustr kind ) over 6 s" PutRef" Istr= if 3 /string >unicode drop INVOKE_PROPERTYPUTREF exit then over 3 s" Put" Istr= if 3 /string >unicode drop INVOKE_PROPERTYPUT exit then ! over 3 s" Get" Istr= if 3 /string >unicode drop INVOKE_PROPERTYGET exit then ! >unicode drop INVOKE_FUNC ; ! : .dispwords ( interface -- ) 0 >r rp@ 0 rot 0 swap UCOM IDispatch GetTypeInfo abort" Unable to Call Dispatch!" rp@ .methods rp@ UCOM ITypeLib IReleaseref drop r> drop ; ! external : Do-Disp ( interface -- hres ) \ behavior of a dispatcher ! peek s" Words" Istr= if .dispwords skip-word exit then ! dup peek methkind swap rot ! getdispID dup 0= if 2drop state @ if POSTPONE lit , then exit else rot skip-word then ! state @ if swap POSTPONE lit , POSTPONE lit , POSTPONE DispatchCall else DispatchCall then ; ! : Dispatcher ( <name> <progID> -- ) create here 0 , here dup parse-word >unicode drop CLSIDFromProgID ! abort" Unable to Find ProgID!" IDispatch swap CLSCTX_SERVER 0 rot CoCreateInstance abort" Unable to Get IUnknown!" IMMEDIATE does> do-disp ; --- 974,1021 ---- 16 * DispCall rgvarg @ + vt@ else 0 VT_EMPTY then ; ! ! : >VT ( n VT -- ) \ push Virtual Type onto Stack ! DispCall cargs @ dup maxvt < if ! 16 * DispCall rgvarg @ + vt! 1 DispCall cargs +! else abort" Variant Stack Full!" then ; ! : .vt ( -- ) DispCall cargs @ 0 ?do ! DispCall rgvarg @ i 16 * + vt@ dup vt>str type ." : " argcells 2 = if d. else . then loop ; ! internal variable disperr : DispatchCall ( type ID Interface -- hres ) \ Call IDispatch Invoke method ! 2>r >r disperr 0 RetVT DispCall r> 0 GUID_NULL 2r> UCOM IDispatch Invoke 0 DispCall cargs ! ; ! : GetDispID ( ustr Interface -- ID ) \ Get Dispatch ID ! swap >r rp@ swap disperr 0 2swap 1 -rot GUID_NULL swap ! UCOM IDispatch GetIDsOfNames r> drop if 0 else disperr @ then ; ! : methkind ( str len -- ustr kind ) over 6 s" PutRef" Istr= if 3 /string >unicode drop INVOKE_PROPERTYPUTREF exit then over 3 s" Put" Istr= if 3 /string >unicode drop INVOKE_PROPERTYPUT exit then ! over 3 s" Get" Istr= if 3 /string >unicode drop INVOKE_PROPERTYGET exit then ! >unicode drop INVOKE_FUNC ; ! : .dispwords ( interface -- ) 0 >r rp@ 0 rot 0 swap UCOM IDispatch GetTypeInfo abort" Unable to Call Dispatch!" rp@ .methods rp@ UCOM ITypeLib IReleaseref drop r> drop ; ! external : Do-Disp ( interface -- hres ) \ behavior of a dispatcher ! peek s" Words" Istr= if .dispwords skip-word exit then ! dup peek methkind swap rot ! getdispID dup 0= if 2drop state @ if POSTPONE lit , then exit else rot skip-word then ! state @ if swap POSTPONE lit , POSTPONE lit , POSTPONE DispatchCall else DispatchCall then ; ! : Dispatcher ( <name> <progID> -- ) create here 0 , here dup parse-word >unicode drop CLSIDFromProgID ! abort" Unable to Find ProgID!" IDispatch swap CLSCTX_SERVER 0 rot CoCreateInstance abort" Unable to Get IUnknown!" IMMEDIATE does> do-disp ; *************** *** 1020,1024 **** : DispLate" ( interface <method> -- hres ) \ late-late bound dispatch ! state @ if COMPILE dup COMPILE (s") ," COMPILE do-displate else dup [CHAR] " parse do-displate then ; IMMEDIATE --- 1025,1029 ---- : DispLate" ( interface <method> -- hres ) \ late-late bound dispatch ! state @ if COMPILE dup COMPILE (s") ," COMPILE do-displate else dup [CHAR] " parse do-displate then ; IMMEDIATE *************** *** 1082,1086 **** \ Close-Interface ! \ you can do the same with structures, but there are better ways to do \ structures. --- 1087,1091 ---- \ Close-Interface ! \ you can do the same with structures, but there are better ways to do \ structures. *************** *** 1092,1098 **** )) ! \ 2 5 typelib {00000205-0000-0010-8000-00AA006D2EA4} \ 1 0 typelib {CA8A9783-280D-11CF-A24D-444553540000} \ IDispatch comiface disp ! \ disp IDispatch 1 0 RecordSet CoCreateInstance . |
