-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2011 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays sequences kernel kernel.private accessors math
-alien.accessors byte-arrays io io.encodings io.encodings.utf8
-io.encodings.utf16n io.streams.byte-array io.streams.memory system
-system.private alien strings combinators namespaces init ;
+USING: accessors alien arrays byte-arrays byte-vectors init io
+io.encodings io.encodings.ascii io.encodings.utf16
+io.encodings.utf8 io.streams.memory kernel kernel.private math
+namespaces sequences sequences.private strings strings.private
+system system.private ;
IN: alien.strings
-GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
+GENERIC#: alien>string 1 ( c-ptr encoding -- string/f )
M: c-ptr alien>string
[ <memory-stream> ] [ <decoder> ] bi*
ERROR: invalid-c-string string ;
-: check-string ( string -- )
+: check-c-string ( string -- )
0 over member-eq? [ invalid-c-string ] [ drop ] if ;
-GENERIC# string>alien 1 ( string encoding -- byte-array )
+GENERIC#: string>alien 1 ( string encoding -- byte-array )
M: c-ptr string>alien drop ;
+<PRIVATE
+
+: fast-string? ( string encoding -- ? )
+ swap aux>> not [ { ascii utf8 } member-eq? ] [ drop f ] if ; inline
+
+: string>alien-fast ( string encoding -- byte-array )
+ { string object } declare ! aux>> must be f
+ drop [ length ] keep over [
+ 1 + (byte-array) [
+ [
+ [ [ string-nth-fast ] keepd ]
+ [ set-nth-unsafe ] bi*
+ ] 2curry each-integer
+ ] keep
+ ] keep 0 swap pick set-nth-unsafe ;
+
+: string>alien-slow ( string encoding -- byte-array )
+ { string object } declare
+ over length 1 + over guess-encoded-length <byte-vector> [
+ swap <encoder> [ stream-write ] [ 0 swap stream-write1 ] bi
+ ] keep B{ } like ;
+
+PRIVATE>
+
M: string string>alien
- over check-string
- <byte-writer>
- [ stream-write ]
- [ 0 swap stream-write1 ]
- [ stream>> >byte-array ]
- tri ;
+ over check-c-string
+ 2dup fast-string?
+ [ string>alien-fast ]
+ [ string>alien-slow ] if ;
M: tuple string>alien drop underlying>> ;
-HOOK: alien>native-string os ( alien -- string )
-
-M: windows alien>native-string utf16n alien>string ;
+HOOK: native-string-encoding os ( -- encoding ) foldable
-M: unix alien>native-string utf8 alien>string ;
+M: unix native-string-encoding utf8 ;
-HOOK: native-string>alien os ( string -- alien )
+M: windows native-string-encoding utf16n ;
-M: windows native-string>alien utf16n string>alien ;
+: alien>native-string ( alien -- string )
+ native-string-encoding alien>string ; inline
-M: unix native-string>alien utf8 string>alien ;
+: native-string>alien ( string -- alien )
+ native-string-encoding string>alien ; inline
: dll-path ( dll -- string )
path>> alien>native-string ;
-HOOK: string>symbol* os ( str/seq -- alien )
+GENERIC: string>symbol ( str/seq -- alien )
-M: winnt string>symbol* utf8 string>alien ;
+M: string string>symbol utf8 string>alien ;
-M: wince string>symbol* utf16n string>alien ;
+M: sequence string>symbol [ utf8 string>alien ] map ;
-M: unix string>symbol* utf8 string>alien ;
+GENERIC: symbol>string ( symbol(s) -- string )
-GENERIC: string>symbol ( str -- alien )
+M: byte-array symbol>string utf8 alien>string ;
-M: string string>symbol string>symbol* ;
+M: array symbol>string [ utf8 alien>string ] map ", " join ;
-M: sequence string>symbol [ string>symbol* ] map ;
+: special-object>string ( n -- str )
+ special-object utf8 alien>string ;
[
- 8 special-object utf8 alien>string string>cpu \ cpu set-global
- 9 special-object utf8 alien>string string>os \ os set-global
+ OBJ-CPU special-object>string string>cpu \ cpu set-global
+ OBJ-OS special-object>string string>os \ os set-global
+ OBJ-VM-VERSION special-object>string \ vm-version set-global
+ OBJ-VM-GIT-LABEL special-object>string \ vm-git-label set-global
+ OBJ-VM-COMPILER special-object>string \ vm-compiler set-global
+ OBJ-VM-COMPILE-TIME special-object>string \ vm-compile-time set-global
] "alien.strings" add-startup-hook