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 ;
   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 M: array heap-size unclip [ product ] [ heap-size ] bi* * ;
  17
  18 M: array c-type-align first c-type-align ;
  19
  20 M: array c-type-stack-align? drop f ;
  21
  22 M: array unbox-parameter drop "void*" unbox-parameter ;
  23
  24 M: array unbox-return drop "void*" unbox-return ;
  25
  26 M: array box-parameter drop "void*" box-parameter ;
  27
  28 M: array box-return drop "void*" box-return ;
  29
  30 M: array stack-size drop "void*" stack-size ;
  31
  32 M: array c-type-boxer-quot
  33     unclip
  34     [ product ]
  35     [ [ require-c-type-arrays ] keep ] bi*
  36     [ <c-type-direct-array> ] 2curry ;
  37
  38 M: array c-type-unboxer-quot drop [ >c-ptr ] ;
  39
  40 M: value-type c-type-rep drop int-rep ;
  41
  42 M: value-type c-type-getter
  43     drop [ swap <displaced-alien> ] ;
  44
  45 M: value-type c-type-setter ( type -- quot )
  46     [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
  47     '[ @ swap @ _ memcpy ] ;
  48
  49 PREDICATE: string-type < pair
  50     first2 [ "char*" = ] [ word? ] bi* and ;
  51
  52 M: string-type c-type ;
  53
  54 M: string-type c-type-class drop object ;
  55
  56 M: string-type c-type-boxed-class drop object ;
  57
  58 M: string-type heap-size
  59     drop "void*" heap-size ;
  60
  61 M: string-type c-type-align
  62     drop "void*" c-type-align ;
  63
  64 M: string-type c-type-stack-align?
  65     drop "void*" c-type-stack-align? ;
  66
  67 M: string-type unbox-parameter
  68     drop "void*" unbox-parameter ;
  69
  70 M: string-type unbox-return
  71     drop "void*" unbox-return ;
  72
  73 M: string-type box-parameter
  74     drop "void*" box-parameter ;
  75
  76 M: string-type box-return
  77     drop "void*" box-return ;
  78
  79 M: string-type stack-size
  80     drop "void*" stack-size ;
  81
  82 M: string-type c-type-rep
  83     drop int-rep ;
  84
  85 M: string-type c-type-boxer
  86     drop "void*" c-type-boxer ;
  87
  88 M: string-type c-type-unboxer
  89     drop "void*" c-type-unboxer ;
  90
  91 M: string-type c-type-boxer-quot
  92     second '[ _ alien>string ] ;
  93
  94 M: string-type c-type-unboxer-quot
  95     second '[ _ string>alien ] ;
  96
  97 M: string-type c-type-getter
  98     drop [ alien-cell ] ;
  99
 100 M: string-type c-type-setter
 101     drop [ set-alien-cell ] ;
 102
 103 { "char*" utf8 } "char*" typedef
 104 "char*" "uchar*" typedef
 105