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.data alien.accessors
4 arrays words sequences math kernel namespaces fry cpu.architecture
5 io.encodings.utf8 accessors ;
8 INSTANCE: array value-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-align-first first c-type-align-first ;
25 M: array c-type-stack-align? drop f ;
27 M: array unbox-parameter drop void* unbox-parameter ;
29 M: array unbox-return drop void* unbox-return ;
31 M: array box-parameter drop void* box-parameter ;
33 M: array box-return drop void* box-return ;
35 M: array stack-size drop void* stack-size ;
37 M: array c-type-boxer-quot
40 [ [ require-c-array ] keep ] bi*
41 [ <c-direct-array> ] 2curry ;
43 M: array c-type-unboxer-quot drop [ >c-ptr ] ;
45 PREDICATE: string-type < pair
46 first2 [ char* = ] [ word? ] bi* and ;
48 M: string-type c-type ;
50 M: string-type c-type-class drop object ;
52 M: string-type c-type-boxed-class drop object ;
54 M: string-type heap-size
55 drop void* heap-size ;
57 M: string-type c-type-align
58 drop void* c-type-align ;
60 M: string-type c-type-align-first
61 drop void* c-type-align-first ;
63 M: string-type c-type-stack-align?
64 drop void* c-type-stack-align? ;
66 M: string-type unbox-parameter
67 drop void* unbox-parameter ;
69 M: string-type unbox-return
70 drop void* unbox-return ;
72 M: string-type box-parameter
73 drop void* box-parameter ;
75 M: string-type box-return
76 drop void* box-return ;
78 M: string-type stack-size
79 drop void* stack-size ;
81 M: string-type c-type-rep
84 M: string-type c-type-boxer
85 drop void* c-type-boxer ;
87 M: string-type c-type-unboxer
88 drop void* c-type-unboxer ;
90 M: string-type c-type-boxer-quot
91 second '[ _ alien>string ] ;
93 M: string-type c-type-unboxer-quot
94 second '[ _ string>alien ] ;
96 M: string-type c-type-getter
99 M: string-type c-type-setter
100 drop [ set-alien-cell ] ;
102 { char* utf8 } char* typedef
105 char char* "pointer-c-type" set-word-prop
106 uchar uchar* "pointer-c-type" set-word-prop