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 ;
8 UNION: value-type array struct-type ;
12 M: array c-type-class drop object ;
14 M: array c-type-boxed-class drop object ;
16 : array-length ( seq -- n )
17 [ dup word? [ def>> call( -- object ) ] when ] [ * ] map-reduce ;
19 M: array heap-size unclip [ array-length ] [ heap-size ] bi* * ;
21 M: array c-type-align first c-type-align ;
23 M: array c-type-stack-align? drop f ;
25 M: array unbox-parameter drop "void*" unbox-parameter ;
27 M: array unbox-return drop "void*" unbox-return ;
29 M: array box-parameter drop "void*" box-parameter ;
31 M: array box-return drop "void*" box-return ;
33 M: array stack-size drop "void*" stack-size ;
35 M: array c-type-boxer-quot
38 [ [ require-c-type-arrays ] keep ] bi*
39 [ <c-type-direct-array> ] 2curry ;
41 M: array c-type-unboxer-quot drop [ >c-ptr ] ;
43 M: value-type c-type-rep drop int-rep ;
45 M: value-type c-type-getter
46 drop [ swap <displaced-alien> ] ;
48 M: value-type c-type-setter ( type -- quot )
49 [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
50 '[ @ swap @ _ memcpy ] ;
52 PREDICATE: string-type < pair
53 first2 [ "char*" = ] [ word? ] bi* and ;
55 M: string-type c-type ;
57 M: string-type c-type-class drop object ;
59 M: string-type c-type-boxed-class drop object ;
61 M: string-type heap-size
62 drop "void*" heap-size ;
64 M: string-type c-type-align
65 drop "void*" c-type-align ;
67 M: string-type c-type-stack-align?
68 drop "void*" c-type-stack-align? ;
70 M: string-type unbox-parameter
71 drop "void*" unbox-parameter ;
73 M: string-type unbox-return
74 drop "void*" unbox-return ;
76 M: string-type box-parameter
77 drop "void*" box-parameter ;
79 M: string-type box-return
80 drop "void*" box-return ;
82 M: string-type stack-size
83 drop "void*" stack-size ;
85 M: string-type c-type-rep
88 M: string-type c-type-boxer
89 drop "void*" c-type-boxer ;
91 M: string-type c-type-unboxer
92 drop "void*" c-type-unboxer ;
94 M: string-type c-type-boxer-quot
95 second '[ _ alien>string ] ;
97 M: string-type c-type-unboxer-quot
98 second '[ _ string>alien ] ;
100 M: string-type c-type-getter
101 drop [ alien-cell ] ;
103 M: string-type c-type-setter
104 drop [ set-alien-cell ] ;
106 { "char*" utf8 } "char*" typedef
107 "char*" "uchar*" typedef