basis/alien/arrays/arrays.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien alien.strings alien.c-types alien.accessors alien.structs
   4 arrays words sequences math kernel namespaces fry libc cpu.architecture
   5 io.encodings.utf8 accessors ;
   6 IN: alien.arrays
   7
   8 UNION: value-type array struct-type ;
   9
  10 M: array c-type ;
  11
  12 M: array c-type-class drop object ;
  13
  14 M: array c-type-boxed-class drop object ;
  15
  16 : array-length ( seq -- n )
  17     [ dup word? [ def>> call( -- object ) ] when ] [ * ] map-reduce ;
  18
  19 M: array heap-size unclip [ array-length ] [ heap-size ] bi* * ;
  20
  21 M: array c-type-align first c-type-align ;
  22
  23 M: array c-type-stack-align? drop f ;
  24
  25 M: array unbox-parameter drop "void*" unbox-parameter ;
  26
  27 M: array unbox-return drop "void*" unbox-return ;
  28
  29 M: array box-parameter drop "void*" box-parameter ;
  30
  31 M: array box-return drop "void*" box-return ;
  32
  33 M: array stack-size drop "void*" stack-size ;
  34
  35 M: array c-type-boxer-quot
  36     unclip
  37     [ array-length ]
  38     [ [ require-c-array ] keep ] bi*
  39     [ <c-direct-array> ] 2curry ;
  40
  41 M: array c-type-unboxer-quot drop [ >c-ptr ] ;
  42
  43 M: value-type c-type-rep drop int-rep ;
  44
  45 M: value-type c-type-getter
  46     drop [ swap <displaced-alien> ] ;
  47
  48 M: value-type c-type-setter ( type -- quot )
  49     [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
  50     '[ @ swap @ _ memcpy ] ;
  51
  52 PREDICATE: string-type < pair
  53     first2 [ "char*" = ] [ word? ] bi* and ;
  54
  55 M: string-type c-type ;
  56
  57 M: string-type c-type-class drop object ;
  58
  59 M: string-type c-type-boxed-class drop object ;
  60
  61 M: string-type heap-size
  62     drop "void*" heap-size ;
  63
  64 M: string-type c-type-align
  65     drop "void*" c-type-align ;
  66
  67 M: string-type c-type-stack-align?
  68     drop "void*" c-type-stack-align? ;
  69
  70 M: string-type unbox-parameter
  71     drop "void*" unbox-parameter ;
  72
  73 M: string-type unbox-return
  74     drop "void*" unbox-return ;
  75
  76 M: string-type box-parameter
  77     drop "void*" box-parameter ;
  78
  79 M: string-type box-return
  80     drop "void*" box-return ;
  81
  82 M: string-type stack-size
  83     drop "void*" stack-size ;
  84
  85 M: string-type c-type-rep
  86     drop int-rep ;
  87
  88 M: string-type c-type-boxer
  89     drop "void*" c-type-boxer ;
  90
  91 M: string-type c-type-unboxer
  92     drop "void*" c-type-unboxer ;
  93
  94 M: string-type c-type-boxer-quot
  95     second '[ _ alien>string ] ;
  96
  97 M: string-type c-type-unboxer-quot
  98     second '[ _ string>alien ] ;
  99
 100 M: string-type c-type-getter
 101     drop [ alien-cell ] ;
 102
 103 M: string-type c-type-setter
 104     drop [ set-alien-cell ] ;
 105
 106 { "char*" utf8 } "char*" typedef
 107 "char*" "uchar*" typedef
 108