suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

adjust ffi/unsafe/com to use ffi/unsafe/string-list

Browse Source 
The one-off `_ptr-to-string/utf-16` can be `_string-list/utf-16`.
This commit is contained in:
Matthew Flatt 2021-05-08 09:09:46 -06:00
parent 36195c71f6
commit 98cf4151a9
2 changed files with 5 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
racket/collects/ffi/unsafe/com.rkt
View File

@ -4,6 +4,7 @@
ffi/winapi ffi/winapi
ffi/unsafe/atomic ffi/unsafe/atomic
ffi/unsafe/custodian ffi/unsafe/custodian
ffi/unsafe/string-list
ffi/file ffi/file
racket/date racket/date
racket/runtime-path racket/runtime-path
@ -333,7 +334,7 @@
[GetTypeInfo (_hmfun _UINT _LCID (p : (_ptr o _pointer)) [GetTypeInfo (_hmfun _UINT _LCID (p : (_ptr o _pointer))
-> GetTypeInfo (cast p _pointer _ITypeInfo-pointer)) -> GetTypeInfo (cast p _pointer _ITypeInfo-pointer))
#:release-with-function Release] #:release-with-function Release]
[GetIDsOfNames (_hmfun _REFIID _ptr-to-string/utf-16 [GetIDsOfNames (_hmfun _REFIID _string-list/utf-16
(_UINT = 1) _LCID (_UINT = 1) _LCID
(p : (_ptr o _DISPID)) (p : (_ptr o _DISPID))
-> GetIDsOfNames -> GetIDsOfNames
@ -1937,7 +1938,7 @@
(define (find-memid who obj name) (define (find-memid who obj name)
(define-values (r memid) (define-values (r memid)
(GetIDsOfNames (com-object-get-dispatch obj) IID_NULL name LOCALE_SYSTEM_DEFAULT)) (GetIDsOfNames (com-object-get-dispatch obj) IID_NULL (list name) LOCALE_SYSTEM_DEFAULT))
(cond (cond
[(zero? r) memid] [(zero? r) memid]
[(= r DISP_E_UNKNOWNNAME) (error who "unknown method name: ~e" name)] [(= r DISP_E_UNKNOWNNAME) (error who "unknown method name: ~e" name)]

21
racket/collects/ffi/unsafe/private/win32.rkt
View File

@ -371,29 +371,12 @@
2 2
1)))) 1))))
(define (string->pointer s [alloc SysAllocStringLen]) (define (string->pointer s)
(let ([v (malloc _gcpointer)]) (let ([v (malloc _gcpointer)])
(ptr-set! v _string/utf-16 s) (ptr-set! v _string/utf-16 s)
(let ([p (ptr-ref v _gcpointer)]) (let ([p (ptr-ref v _gcpointer)])
(let ([len (utf-16-length s)]) (let ([len (utf-16-length s)])
(alloc p len))))) (SysAllocStringLen p len)))))
;; Like (_ptr i _string/utf-16), but as a single atomic (and immobile
;; and GCable) object, so it can be passed to a function in CS:
(define _ptr-to-string/utf-16
(make-ctype _gcpointer
(lambda (s)
(string->pointer
s
(lambda (p len)
(define slen (+ len 2)) ; add terminator
(define p2 (malloc 'atomic-interior
(+ slen (ctype-sizeof _pointer))))
(memcpy p2 (ctype-sizeof _pointer) p slen)
(ptr-set! p2 _pointer 0 p)
p2)))
(lambda (p)
(cast p _pointer _string/utf-16))))
(define _SAFEARRAY-pointer (_cpointer 'SAFEARRAY)) (define _SAFEARRAY-pointer (_cpointer 'SAFEARRAY))