Update of /cvsroot/win32forth/win32forth/src/lib
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv7434/src/lib
Modified Files:
FCOM.F
Log Message:
Newer version of FCOM added. This contains a fix to the dispatch interface. It also has moved the unicode words into another file, where it is better suited.
Index: FCOM.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/FCOM.F,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** FCOM.F 6 May 2006 09:28:54 -0000 1.3
--- FCOM.F 19 Aug 2006 01:50:52 -0000 1.4
***************
*** 2,5 ****
--- 2,7 ----
\ Tom Dixon
+ needs Unicode
+
anew -FCOM.f
***************
*** 7,23 ****
external
! winlibrary OLE32.DLL
1 proc CoInitialize
5 proc CoCreateInstance
- 6 proc MultiByteToWideChar
- 8 proc WideCharToMultiByte
2 proc CLSIDFromProgID
2 proc StringFromCLSID
2 proc CLSIDFromString
-
-
- winlibrary oleaut32.dll
-
5 proc LoadRegTypeLib
2 proc LoadTypeLib
--- 9,20 ----
external
!
! winlibrary oleaut32.dll
1 proc CoInitialize
5 proc CoCreateInstance
2 proc CLSIDFromProgID
2 proc StringFromCLSID
2 proc CLSIDFromString
5 proc LoadRegTypeLib
2 proc LoadTypeLib
***************
*** 29,67 ****
[UNDEFINED] ISTR= [IF] synonym ISTR= STR(NC)= [THEN]
- \ unicode string functions
-
- : UniPlace ( addr len destaddr -- ) 2dup ! 4 + 2dup + 0 swap w! swap cmove ;
- : UniAppend ( addr len destaddr -- )
- 2dup @ + >r dup >r dup @ + 4 + 2dup + 0 swap ! swap cmove r> r> swap ! ;
- : UniCount ( addr -- addr len ) dup 4 + swap @ ;
- : ZUniCount ( addr -- addr len ) dup 0 begin over w@ while 2 2 d+ repeat nip ;
- : UniType ( addr len -- ) 2/ 0 ?do dup i 2* + c@ emit loop drop ;
-
- : (U") r> UniCount 2dup + 2 + aligned >r ;
-
- : Ustr, ( addr n -- ) HERE over 6 + allot uniplace ALIGN ;
-
- : Asc>Uni ( str len -- str len ) \ !!! MUST FREE STRING AFTER !!!
- dup 2* dup allocate abort" Unable to Allocate Unicode String!"
- dup >r 2swap swap MB_PRECOMPOSED 0 MultiByteToWideChar r> swap 2* ;
-
- : Uni>Asc ( str len -- str len ) \ !!! MUST FREE STRING AFTER !!!
- 0 0 2over 0 here 2swap swap 0 0 WideCharToMultiByte >r
- 0 0 2swap r> dup Allocate abort" Unable to Allocate String!"
- 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 ;
-
- : >ascii ( str len -- str len ) \ convert unicode to ascii
- uni>asc 2dup new$ dup >r place drop free drop r> count ;
-
- : U" STATE @ IF COMPILE (U") ascii " PARSE
- asc>uni 2dup ustr, drop free drop EXIT THEN
- ascii " PARSE >unicode ; IMMEDIATE
-
-
-
-
\ Defining GUIDs
--- 26,29 ----
***************
*** 965,974 ****
create VTstack 16 maxvt * allot \ stack
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 ;
--- 927,940 ----
create VTstack 16 maxvt * allot \ stack
+ create VTNStack DISPID_PROPERTYPUT ,
DISPPARAMS Struct DispCall \ calling structure
! vtstack DispCall rgvarg !
! vtnstack Dispcall rgdispidNamedArgs !
VARIANT Struct RetVT \ return value - only one allowed :-(
+ external
+
: vt@ ( addr -- n VT )
dup w@ swap 8 + over argcells 2 = if 2@ rot else @ swap then ;
***************
*** 976,981 ****
2dup w! 8 + swap argcells 2 = if 2! else ! then ;
- external
-
: VT> ( -- n VT ) \ pop virtual type off stack
DispCall cargs @ ?dup if 1- dup DispCall cargs !
--- 942,945 ----
***************
*** 992,995 ****
--- 956,961 ----
argcells 2 = if d. else . then loop ;
+ : retVT@ ( -- n VT ) RetVT vt@ ;
+
internal
***************
*** 998,1002 ****
: 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
--- 964,968 ----
: 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 ! 0 DispCall cnamedargs ! ;
: GetDispID ( ustr Interface -- ID ) \ Get Dispatch ID
***************
*** 1005,1010 ****
: 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 ;
--- 971,979 ----
: methkind ( str len -- ustr kind )
! over 6 s" PutRef" Istr= if 3 /string >unicode drop INVOKE_PROPERTYPUTREF
! 1 DispCall cnamedargs ! exit then
! over 3 s" Put" Istr= if 3 /string >unicode drop INVOKE_PROPERTYPUT
! DISPID_PROPERTYPUT VTNStack !
! 1 DispCall cnamedargs ! exit then
over 3 s" Get" Istr= if 3 /string >unicode drop INVOKE_PROPERTYGET exit then
>unicode drop INVOKE_FUNC ;
***************
*** 1105,1111 ****
))
- \ 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 .
--- 1074,1075 ----
|
