basis/alien/strings/strings.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays sequences kernel accessors math alien.accessors
   4 alien.c-types byte-arrays words io io.encodings
   5 io.streams.byte-array io.streams.memory io.encodings.utf8
   6 io.encodings.utf16 system alien strings cpu.architecture ;
   7 IN: alien.strings
   8
   9 GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
  10
  11 M: c-ptr alien>string
  12     >r <memory-stream> r> <decoder>
  13     "\0" swap stream-read-until drop ;
  14
  15 M: f alien>string
  16     drop ;
  17
  18 ERROR: invalid-c-string string ;
  19
  20 : check-string ( string -- )
  21     0 over memq? [ invalid-c-string ] [ drop ] if ;
  22
  23 GENERIC# string>alien 1 ( string encoding -- byte-array )
  24
  25 M: c-ptr string>alien drop ;
  26
  27 M: string string>alien
  28     over check-string
  29     <byte-writer>
  30     [ stream-write ]
  31     [ 0 swap stream-write1 ]
  32     [ stream>> >byte-array ]
  33     tri ;
  34
  35 : malloc-string ( string encoding -- alien )
  36     string>alien malloc-byte-array ;
  37
  38 PREDICATE: string-type < pair
  39     first2 [ "char*" = ] [ word? ] bi* and ;
  40
  41 M: string-type c-type ;
  42
  43 M: string-type heap-size
  44     drop "void*" heap-size ;
  45
  46 M: string-type c-type-align
  47     drop "void*" c-type-align ;
  48
  49 M: string-type c-type-stack-align?
  50     drop "void*" c-type-stack-align? ;
  51
  52 M: string-type unbox-parameter
  53     drop "void*" unbox-parameter ;
  54
  55 M: string-type unbox-return
  56     drop "void*" unbox-return ;
  57
  58 M: string-type box-parameter
  59     drop "void*" box-parameter ;
  60
  61 M: string-type box-return
  62     drop "void*" box-return ;
  63
  64 M: string-type stack-size
  65     drop "void*" stack-size ;
  66
  67 M: string-type c-type-reg-class
  68     drop int-regs ;
  69
  70 M: string-type c-type-boxer
  71     drop "void*" c-type-boxer ;
  72
  73 M: string-type c-type-unboxer
  74     drop "void*" c-type-unboxer ;
  75
  76 M: string-type c-type-boxer-quot
  77     second [ alien>string ] curry [ ] like ;
  78
  79 M: string-type c-type-unboxer-quot
  80     second [ string>alien ] curry [ ] like ;
  81
  82 M: string-type c-type-getter
  83     drop [ alien-cell ] ;
  84
  85 M: string-type c-type-setter
  86     drop [ set-alien-cell ] ;
  87
  88 ! Native-order UTF-16
  89
  90 SINGLETON: utf16n
  91
  92 : utf16n ( -- descriptor )
  93     little-endian? utf16le utf16be ? ; foldable
  94
  95 M: utf16n <decoder> drop utf16n <decoder> ;
  96
  97 M: utf16n <encoder> drop utf16n <encoder> ;
  98
  99 : alien>native-string ( alien -- string )
 100     os windows? [ utf16n ] [ utf8 ] if alien>string ;
 101
 102 : dll-path ( dll -- string )
 103     path>> alien>native-string ;
 104
 105 : string>symbol ( str -- alien )
 106     [ os wince? [ utf16n ] [ utf8 ] if string>alien ]
 107     over string? [ call ] [ map ] if ;
 108
 109 { "char*" utf8 } "char*" typedef
 110 { "char*" utf16n } "wchar_t*" typedef
 111 "char*" "uchar*" typedef