[Win32forth-cvs] win32forth/src/lib Unicode.F,NONE,1.1

[Tom D. <phe...@us...>]

Update of /cvsroot/win32forth/win32forth/src/lib
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv8269/src/lib

Added Files:
	Unicode.F 
Log Message:
Unicode words for working with api calls that require unicode.  This was originally part of FCOM.f, but moved into it's own file.

--- NEW FILE: Unicode.F ---
\ Unicode Words
\ Tom Dixon

\ *D doc
\ *! Unicode
\ *T Unicode Wordset
\ *Q Tom Dixon - August 2006
\ ** Unicode wordset for working with Unicode APIs

anew -Unicode.f


winlibrary OLE32.DLL

6 proc MultiByteToWideChar
8 proc WideCharToMultiByte
1 proc SysStringByteLen
2 proc SysAllocStringLen
1 proc SysFreeString


: UniPlace ( addr len destaddr -- )
\ *G Store a unicode string to an address
  2dup ! 4 + 2dup + 0 swap w! swap cmove ;

: +UniPlace ( addr len destaddr -- )
\ *G Append a string to the end of an address
  2dup @ + >r dup >r dup @ + 4 + 2dup + 0 swap ! swap cmove r> r> swap ! ;

: UniCount ( addr -- addr len )
\ *G Fetch a unicode string from an address (stored with uniplace)
  dup 4 + swap @ ;

: ZUniCount ( addr -- addr len )
\ *G Fetch a null-terminated unicode string from an address (null is 16-bit)
  dup 0 begin over w@ while 2 2 d+ repeat nip ;

: UniType ( addr len -- )
\ *G Type a unicode string to the console
  2/ 0 ?do dup i 2* + c@ emit loop drop ;

: (U") r> UniCount 2dup + 2 + aligned >r ;

: Ustr, ( addr n -- )
\ *G Store a unicode string to the dictionary at HERE
  HERE over 6 + allot uniplace ALIGN ;

: Asc>Uni ( str len -- str len ) \ !!! MUST FREE STRING AFTER !!!
\ *G Convert a ascii string to unicode.\n
\ ** must free unicode string with 'free' when no longer needed.
  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 !!!
\ *G Convert a unicode string to ascii\n
\ ** must free ascii string afterwards when no longer needed.
  0 0 2over 0 here 2swap swap 0 0 WideCharToMultiByte 2/ >r
  0 0 2swap r@ dup Allocate abort" Unable to Allocate String!"
  dup >r 2swap swap 0 0 WideCharToMultiByte drop r> r> ;

: >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 )
\ *G Convert unicode string to ascii (uses new$)
  uni>asc 2dup new$ dup >r place drop free drop r> count ;

: U" ( ... " -- str len )
\ *G Unicode string - same as s"
  STATE @ IF COMPILE (U") ascii " PARSE
     asc>uni 2dup ustr, drop free drop EXIT THEN
  ascii " PARSE >unicode ; IMMEDIATE


\ Some APIs require more specific conditions to their unicode strings.
\ (ie: distributed and network apis)
\ bstr has more constraints applied to it.  These words are to convert
\ to bstrs and back again.

: Asc>bstr ( str len -- bstr )
\ *G Convert ascii string to unicode bstr.  bstr must be freed later with 'bstrfree'.
  dup dup 0 SysAllocStringLen dup >r
  2swap swap
  MB_PRECOMPOSED
  CP_ACP
  MultiByteToWideChar drop r> ;

: bstrFree ( bstr -- )
\ *G Free a bstr.
  SysFreeString drop ;
: bstrlen ( ustr -- len )
\ *G Returns the length of the bstr.  From this the bstr can be used with all the
\ ** other unicode functions.
  cell- @ ;

\ *Z