[Win32forth-cvs] win32forth/src/lib FCOM.F, 1.8, 1.9 Unicode.F, 1.1, 1.2

SourceForge Headquarters 225 Broadway Suite 1600 San Diego, CA 92101 +1 (858) 422-6466

Update of /cvsroot/win32forth/win32forth/src/lib
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv3867

Modified Files:
	FCOM.F Unicode.F 
Log Message:
Added +UniNull and Unew$ to unicode. Moved words used by FCOM only at compile time to system space.

Index: Unicode.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/Unicode.F,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** Unicode.F	19 Aug 2006 01:52:51 -0000	1.1
--- Unicode.F	28 Nov 2013 21:19:29 -0000	1.2
***************
*** 19,22 ****
--- 19,26 ----
  1 proc SysFreeString

+ : Unew$         ( -- addr )
+ \ *G Allocate 2X MAXSTRING bytes from the dynamic string buffer and return the address. This is
+ \ ** designed for 16bit Unicode strings which are twice as long as Ascii.
+                 MAXSTRING 2* DynAlloc ;

  : UniPlace ( addr len destaddr -- )
***************
*** 28,31 ****
--- 32,39 ----
    2dup @ + >r dup >r dup @ + 4 + 2dup + 0 swap ! swap cmove r> r> swap ! ;

+ : +UniNull  ( destaddr -- )
+ \ *G Append a null to the unicode string at address.
+   dup @ 2* + 0 swap w! ;
+ 
  : UniCount ( addr -- addr len )
  \ *G Fetch a unicode string from an address (stored with uniplace)
***************
*** 60,65 ****

  : >Unicode ( str len -- str len )
! \ *G Convert ascii string to unicode (uses new$)
!   asc>uni 2dup new$ dup >r uniplace drop free drop r> unicount ;

  : >ascii ( str len -- str len )
--- 68,73 ----

  : >Unicode ( str len -- str len )
! \ *G Convert ascii string to unicode (uses Unew$)
!   asc>uni 2dup Unew$ dup >r uniplace drop free drop r> dup +UniNull unicount ;

  : >ascii ( str len -- str len )

Index: FCOM.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/FCOM.F,v
retrieving revision 1.8
retrieving revision 1.9
diff -C2 -d -r1.8 -r1.9
*** FCOM.F	19 Aug 2011 14:42:03 -0000	1.8
--- FCOM.F	28 Nov 2013 21:19:29 -0000	1.9
***************
*** 8,15 ****
  anew -FCOM.f

- internal
- external
- 
- 
  winlibrary oleaut32.dll

--- 8,11 ----
***************
*** 30,35 ****
--- 26,35 ----
  \ Defining GUIDs

+  in-system
+ 
  internal
+ 
  : hatoi number? 2drop ;
+ 
  external

***************
*** 49,53 ****
    begin over w@ while 2 2 d+ repeat nip pad @ swap ;

- 
  internal

--- 49,52 ----
***************
*** 85,94 ****

  internal
  0 value openiface
  external

  : 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
--- 84,95 ----

  internal
+ 
  0 value openiface
+ 
  external

  : IMethod ( n -- ) \ n is vtable index
!   >System here openiface 16 + @ , openiface 16 + ! , ,
!   here parse-word dup 1+ allot rot place System> ;

  : UCOM ( pointer -- ) \ call using an interface
***************
*** 101,105 ****

  : INTERFACE ( interface |guid -- )
!   ?dup if create guid, 16 + here over @ , swap !
      else create guid, 0 , then ;

--- 102,106 ----

  : INTERFACE ( interface |guid -- )
!     ?dup if create guid, 16 + here over @ , swap !
      else create guid, 0 , then ;

***************
*** 107,111 ****
  : Close-Interface ( -- ) 0 to openiface ;

- 
  \ define the unknown interface

--- 108,111 ----
***************
*** 117,121 ****
  Close-Interface

! \ dispatch interface
  IUnknown Interface IDispatch     {00020400-0000-0000-C000-000000000046}
  IDispatch Open-Interface
--- 117,124 ----
  Close-Interface

!  in-previous
! 
! \ dispatch interface. IDispatch must be in application space because it's used by AX controls.
! 
  IUnknown Interface IDispatch     {00020400-0000-0000-C000-000000000046}
  IDispatch Open-Interface
***************
*** 128,131 ****
--- 131,136 ----
  UUID GUID_NULL {00000000-0000-0000-0000-000000000000}

+ in-system
+ 
  \ **** AUTOMATION ****
  \ this is the point where automation tries to control the rigors of
***************
*** 207,211 ****
  Close-Interface

- 
  internal

--- 212,215 ----
***************
*** 229,233 ****

  \ defines a structure
! : Struct ( structtype -- ) create dup cell+ , @ allot IMMEDIATE
    does> dup peek rot @ search-struct
      if skip-word dup 3 cells + @ execute + cell+
--- 233,238 ----

  \ defines a structure
! : Struct ( structtype -- )  create dup cell+ , @ allot IMMEDIATE
!   Suppress-system
    does> dup peek rot @ search-struct
      if skip-word dup 3 cells + @ execute + cell+
***************
*** 244,247 ****
--- 249,253 ----

  internal
+ 
  0 value openstruct

***************
*** 251,254 ****
--- 257,261 ----
    peek rot cell+ search-struct
    if skip-word dup 3 cells + @ execute + then ;
+ 
  external

***************
*** 369,372 ****
--- 376,380 ----
  close-struct

+ in-previous

  \ FuncKind enumeration
***************
*** 459,462 ****
--- 467,472 ----
  internal

+ in-system
+ 
  : vt>Str ( vt -- str len )  \ for type to string conversion
    case
***************
*** 509,512 ****
--- 519,524 ----
   endcase ;

+ in-previous
+ 
  : argcells ( VT -- #cells ) \ returns the number of cells needed for a vtype
    dup 5 = if drop 2 exit then
***************
*** 537,540 ****
--- 549,553 ----
    dup tattr-allot dup UseStruct TYPEATTR cbSizeInstance @ -rot tattr-free ;

+ in-system

  \ function stuff
***************
*** 592,597 ****
    abort" Unable to Bind to type!" r> r> r> -rot ;

- 
- 
  \ These words are for "dumping" interfaces and structures so you don't have
  \ to look at documentation as much while your programming
--- 605,608 ----
***************
*** 861,869 ****

  : comfind ( str -- str 0 | cfa flag )
!   [ action-of 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)
--- 872,880 ----

  : comfind ( str -- str 0 | cfa flag )
!   [ action-of find compile, ]  \ call previous find word
    ?dup 0= if count 0 ?typelib if ['] noop 1 else drop 1- 0 then
    then ;

! \in-system-ok  ' comfind is find

  \ Late-Binding for Types in typelibraries (needed only for interfaces and structures)
***************
*** 912,915 ****
--- 923,927 ----
    drop 0 typelibhead ! ;

+ in-previous

  : com_init 0 CoInitialize drop ;
***************
*** 918,927 ****
  com_init

! unload-chain chain-add-before freetypelibs
! 

  internal

! \ IDipatch Calling Interface
  \ This is for calling methods in the IDispatch Interface.
  \ It is a nasty calling convention that uses run-time type checking, passes arguments
--- 930,938 ----
  com_init

! \in-system-ok unload-chain chain-add-before freetypelibs

  internal

! \ IDispatch Calling Interface
  \ This is for calling methods in the IDispatch Interface.
  \ It is a nasty calling convention that uses run-time type checking, passes arguments
***************
*** 958,965 ****
--- 969,980 ----
    else abort" Variant Stack Full!" then ;

+ in-system
+ 
  : .vt ( -- ) DispCall cargs @ 0 ?do
       DispCall rgvarg @ i 16 * + vt@ dup vt>str type ." : "
       argcells 2 = if d. else . then loop ;

+ in-previous
+ 
  : retVT@ ( -- n VT ) RetVT vt@ ;

***************
*** 985,988 ****
--- 1000,1005 ----
    >unicode drop INVOKE_FUNC ;

+ in-system
+ 
  : .dispwords ( interface -- )
    0 >r rp@ 0 rot 0 swap UCOM IDispatch GetTypeInfo abort" Unable to Call Dispatch!"
***************
*** 991,994 ****
--- 1008,1018 ----
  external

+ in-previous
+ 
+ : do-displate ( interface interface str len -- hres ) \ bind by string, not by ID
+   methkind swap rot getdispID rot DispatchCall ;
+ 
+ in-system
+ 
  : Do-Disp ( interface -- hres ) \ behavior of a dispatcher
    peek s" Words" Istr= if .dispwords skip-word exit then
***************
*** 1002,1014 ****
    abort" Unable to Find ProgID!"
    IDispatch swap CLSCTX_SERVER 0 rot CoCreateInstance abort" Unable to Get IUnknown!"
!   IMMEDIATE does> do-disp ;
! 
! : do-displate ( interface interface str len -- hres ) \ bind by string, not by ID
!   methkind swap rot getdispID rot DispatchCall ;

! : 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

  module

--- 1026,1037 ----
    abort" Unable to Find ProgID!"
    IDispatch swap CLSCTX_SERVER 0 rot CoCreateInstance abort" Unable to Get IUnknown!"
!   IMMEDIATE does> Do-Disp ;

! : DispLate" ( interface "method"" -- hres ) \ late-late bound dispatch
!   state @ if postpone dup postpone (s") ," postpone do-displate
     else dup [CHAR] " parse do-displate then ; IMMEDIATE

+ in-previous
+ 
  module

***************
*** 1032,1036 ****
   \ To Start up a component, you need to call CoCreateInstance (part of OLE32.DLL)

!   SpVoice 0 1 ISpVoice voice CoCreateInstance [IF] ." Can't Load SPVoice!" [THEN]

   \ Now "voice" can be called as if it were an object.  If called
--- 1055,1059 ----
   \ To Start up a component, you need to call CoCreateInstance (part of OLE32.DLL)

!   voice ISpVoice 1 0 SpVoice CoCreateInstance [IF] ." Can't Load SPVoice!" [THEN]

   \ Now "voice" can be called as if it were an object.  If called