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.encodings.utf8 io.streams.byte-array io.streams.memory system
   6 alien strings cpu.architecture fry vocabs.loader combinators ;
   7 IN: alien.strings
   8
   9 GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
  10
  11 M: c-ptr alien>string
  12     [ <memory-stream> ] [ <decoder> ] bi*
  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 c-type-class
  44     drop object ;
  45
  46 M: string-type heap-size
  47     drop "void*" heap-size ;
  48
  49 M: string-type c-type-align
  50     drop "void*" c-type-align ;
  51
  52 M: string-type c-type-stack-align?
  53     drop "void*" c-type-stack-align? ;
  54
  55 M: string-type unbox-parameter
  56     drop "void*" unbox-parameter ;
  57
  58 M: string-type unbox-return
  59     drop "void*" unbox-return ;
  60
  61 M: string-type box-parameter
  62     drop "void*" box-parameter ;
  63
  64 M: string-type box-return
  65     drop "void*" box-return ;
  66
  67 M: string-type stack-size
  68     drop "void*" stack-size ;
  69
  70 M: string-type c-type-reg-class
  71     drop int-regs ;
  72
  73 M: string-type c-type-boxer
  74     drop "void*" c-type-boxer ;
  75
  76 M: string-type c-type-unboxer
  77     drop "void*" c-type-unboxer ;
  78
  79 M: string-type c-type-boxer-quot
  80     second '[ _ alien>string ] ;
  81
  82 M: string-type c-type-unboxer-quot
  83     second '[ _ string>alien ] ;
  84
  85 M: string-type c-type-getter
  86     drop [ alien-cell ] ;
  87
  88 M: string-type c-type-setter
  89     drop [ set-alien-cell ] ;
  90
  91 HOOK: alien>native-string os ( alien -- string )
  92
  93 HOOK: native-string>alien os ( string -- alien )
  94
  95 : dll-path ( dll -- string )
  96     path>> alien>native-string ;
  97
  98 : string>symbol ( str -- alien )
  99     dup string?
 100     [ native-string>alien ]
 101     [ [ native-string>alien ] map ] if ;
 102
 103 { "char*" utf8 } "char*" typedef
 104 "char*" "uchar*" typedef
 105
 106 {
 107     { [ os windows? ] [ "alien.strings.windows" require ] }
 108     { [ os unix? ] [ "alien.strings.unix" require ] }
 109 } cond