core/alien/strings/strings.factor

   1 ! Copyright (C) 2008, 2011 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien arrays byte-arrays byte-vectors io
   4 io.encodings io.encodings.ascii io.encodings.utf16
   5 io.encodings.utf8 io.streams.memory kernel kernel.private math
   6 namespaces sequences sequences.private strings strings.private
   7 system system.private ;
   8 IN: alien.strings
   9
  10 GENERIC#: alien>string 1 ( c-ptr encoding -- string/f )
  11
  12 M: c-ptr alien>string
  13     [ <memory-stream> ] [ <decoder> ] bi*
  14     "\0" swap stream-read-until drop ;
  15
  16 M: object alien>string
  17     [ underlying>> ] dip alien>string ;
  18
  19 M: f alien>string
  20     drop ;
  21
  22 ERROR: invalid-c-string string ;
  23
  24 : check-c-string ( string -- )
  25     0 over member-eq? [ invalid-c-string ] [ drop ] if ;
  26
  27 GENERIC#: string>alien 1 ( string encoding -- byte-array )
  28
  29 M: c-ptr string>alien drop ;
  30
  31 <PRIVATE
  32
  33 : fast-string? ( string encoding -- ? )
  34     swap aux>> not [ { ascii utf8 } member-eq? ] [ drop f ] if ; inline
  35
  36 : string>alien-fast ( string encoding -- byte-array )
  37     { string object } declare ! aux>> must be f
  38     drop [ length ] keep over [
  39         1 + (byte-array) [
  40             [
  41                 [ [ string-nth-fast ] keepd ]
  42                 [ set-nth-unsafe ] bi*
  43             ] 2curry each-integer
  44         ] keep
  45     ] keep 0 swap pick set-nth-unsafe ;
  46
  47 : string>alien-slow ( string encoding -- byte-array )
  48     { string object } declare
  49     over length 1 + over guess-encoded-length <byte-vector> [
  50         swap <encoder> [ stream-write ] [ 0 swap stream-write1 ] bi
  51     ] keep B{ } like ;
  52
  53 PRIVATE>
  54
  55 M: string string>alien
  56     over check-c-string
  57     2dup fast-string?
  58     [ string>alien-fast ]
  59     [ string>alien-slow ] if ;
  60
  61 M: tuple string>alien drop underlying>> ;
  62
  63 HOOK: native-string-encoding os ( -- encoding ) foldable
  64
  65 M: unix native-string-encoding utf8 ;
  66
  67 M: windows native-string-encoding utf16n ;
  68
  69 : alien>native-string ( alien -- string )
  70     native-string-encoding alien>string ; inline
  71
  72 : native-string>alien ( string -- alien )
  73     native-string-encoding string>alien ; inline
  74
  75 : dll-path ( dll -- string )
  76     path>> alien>native-string ;
  77
  78 GENERIC: string>symbol ( str/seq -- alien )
  79
  80 M: string string>symbol utf8 string>alien ;
  81
  82 M: sequence string>symbol [ utf8 string>alien ] map ;
  83
  84 GENERIC: symbol>string ( symbol(s) -- string )
  85
  86 M: byte-array symbol>string utf8 alien>string ;
  87
  88 M: array symbol>string [ utf8 alien>string ] map ", " join ;
  89
  90 : special-object>string ( n -- str )
  91     special-object utf8 alien>string ;
  92
  93 STARTUP-HOOK: [
  94     OBJ-CPU special-object>string string>cpu \ cpu set-global
  95     OBJ-OS special-object>string string>os \ os set-global
  96     OBJ-VM-VERSION special-object>string \ vm-version set-global
  97     OBJ-VM-GIT-LABEL special-object>string \ vm-git-label set-global
  98     OBJ-VM-COMPILER special-object>string \ vm-compiler set-global
  99     OBJ-VM-COMPILE-TIME special-object>string \ vm-compile-time set-global
 100 ]