1 ! Copyright (C) 2004, 2007 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: byte-arrays arrays generator.registers assocs
4 kernel kernel.private libc math namespaces parser sequences
5 strings words assocs splitting math.parser cpu.architecture
6 alien quotations system ;
12 reg-class size align stack-align? ;
14 : <c-type> ( -- type )
15 T{ int-regs } { set-c-type-reg-class } \ c-type construct ;
20 c-types [ H{ } assoc-like ] change
23 TUPLE: no-c-type name ;
25 : no-c-type ( type -- * ) \ no-c-type construct-boa throw ;
27 : (c-type) ( name -- type/f )
28 c-types get-global at dup [
29 dup string? [ (c-type) ] when
32 GENERIC: c-type ( name -- type )
34 : resolve-pointer-type ( name -- name )
35 c-types get at dup string?
36 [ "*" append ] [ drop "void*" ] if
39 : resolve-typedef ( name -- type )
40 dup string? [ c-type ] when ;
42 : parse-array-type ( name -- array )
44 >r [ "]" ?tail drop string>number ] map r> add* ;
46 M: string c-type ( name -- type )
47 CHAR: ] over member? [
53 "*" ?tail [ resolve-pointer-type ] [ no-c-type ] if
57 : c-type-box ( n type -- )
59 swap c-type-boxer [ "No boxer" throw ] unless*
62 : c-type-unbox ( n ctype -- )
64 swap c-type-unboxer [ "No unboxer" throw ] unless*
67 M: string c-type-align c-type c-type-align ;
69 M: string c-type-stack-align? c-type c-type-stack-align? ;
71 GENERIC: box-parameter ( n ctype -- )
73 M: c-type box-parameter c-type-box ;
75 M: string box-parameter c-type box-parameter ;
77 GENERIC: box-return ( ctype -- )
79 M: c-type box-return f swap c-type-box ;
81 M: string box-return c-type box-return ;
83 GENERIC: unbox-parameter ( n ctype -- )
85 M: c-type unbox-parameter c-type-unbox ;
87 M: string unbox-parameter c-type unbox-parameter ;
89 GENERIC: unbox-return ( ctype -- )
91 M: c-type unbox-return f swap c-type-unbox ;
93 M: string unbox-return c-type unbox-return ;
95 ! These words being foldable means that words need to be
96 ! recompiled if a C type is redefined. Even so, folding the
97 ! size facilitates some optimizations.
98 GENERIC: heap-size ( type -- size ) foldable
100 M: string heap-size c-type heap-size ;
102 M: c-type heap-size c-type-size ;
104 GENERIC: stack-size ( type -- size ) foldable
106 M: string stack-size c-type stack-size ;
108 M: c-type stack-size c-type-size ;
110 : c-getter ( name -- quot )
111 c-type c-type-getter [
112 [ "Cannot read struct fields with type" throw ]
115 : c-setter ( name -- quot )
116 c-type c-type-setter [
117 [ "Cannot write struct fields with type" throw ]
120 : <c-array> ( n type -- array )
121 heap-size * <byte-array> ; inline
123 : <c-object> ( type -- array )
124 1 swap <c-array> ; inline
126 : malloc-array ( n type -- alien )
127 heap-size calloc ; inline
129 : malloc-object ( type -- alien )
130 1 swap malloc-array ; inline
132 : malloc-byte-array ( byte-array -- alien )
133 dup length dup malloc [ -rot memcpy ] keep ;
135 : malloc-char-string ( string -- alien )
136 string>char-alien malloc-byte-array ;
138 : malloc-u16-string ( string -- alien )
139 string>u16-alien malloc-byte-array ;
141 : (define-nth) ( word type quot -- )
142 >r heap-size [ rot * ] swap add* r> append define-inline ;
144 : nth-word ( name vocab -- word )
145 >r "-nth" append r> create ;
147 : define-nth ( name vocab -- )
148 dupd nth-word swap dup c-getter (define-nth) ;
150 : set-nth-word ( name vocab -- word )
151 >r "set-" swap "-nth" 3append r> create ;
153 : define-set-nth ( name vocab -- )
154 dupd set-nth-word swap dup c-setter (define-nth) ;
156 : typedef ( old new -- ) c-types get set-at ;
158 : define-c-type ( type name vocab -- )
159 >r tuck typedef r> [ define-nth ] 2keep define-set-nth ;
161 TUPLE: long-long-type ;
163 : <long-long-type> ( type -- type )
164 long-long-type construct-delegate ;
166 M: long-long-type unbox-parameter ( n type -- )
167 c-type-unboxer %unbox-long-long ;
169 M: long-long-type unbox-return ( type -- )
170 f swap unbox-parameter ;
172 M: long-long-type box-parameter ( n type -- )
173 c-type-boxer %box-long-long ;
175 M: long-long-type box-return ( type -- )
176 f swap box-parameter ;
178 : define-deref ( name vocab -- )
179 >r dup CHAR: * add* r> create
180 swap c-getter 0 add* define-inline ;
182 : define-out ( name vocab -- )
183 over [ <c-object> tuck 0 ] over c-setter append swap
184 >r >r constructor-word r> r> add* define-inline ;
186 : >c-array ( seq type word -- )
187 >r >r dup length dup r> <c-array> dup -roll r>
188 [ execute ] 2curry 2each ; inline
190 : >c-array-quot ( type vocab -- quot )
191 dupd set-nth-word [ >c-array ] 2curry ;
193 : to-array-word ( name vocab -- word )
194 >r ">c-" swap "-array" 3append r> create ;
196 : define-to-array ( type vocab -- )
197 [ to-array-word ] 2keep >c-array-quot define-compound ;
199 : c-array>quot ( type vocab -- quot )
202 nth-word 1quotation ,
206 : from-array-word ( name vocab -- word )
207 >r "c-" swap "-array>" 3append r> create ;
209 : define-from-array ( type vocab -- )
210 [ from-array-word ] 2keep c-array>quot define-compound ;
212 : <primitive-type> ( getter setter width boxer unboxer -- type )
214 [ set-c-type-unboxer ] keep
215 [ set-c-type-boxer ] keep
216 [ set-c-type-size ] 2keep
217 [ set-c-type-align ] keep
218 [ set-c-type-setter ] keep
219 [ set-c-type-getter ] keep ;
221 : define-primitive-type ( type name -- )
223 [ define-c-type ] 2keep
224 [ define-deref ] 2keep
225 [ define-to-array ] 2keep
226 [ define-from-array ] 2keep
229 : expand-constants ( c-type -- c-type' )
231 unclip >r [ dup word? [ execute ] when ] map r> add*
238 "alien_offset" <primitive-type>
239 "void*" define-primitive-type
242 [ set-alien-signed-8 ]
245 "to_signed_8" <primitive-type> <long-long-type>
246 "longlong" define-primitive-type
249 [ set-alien-unsigned-8 ]
252 "to_unsigned_8" <primitive-type> <long-long-type>
253 "ulonglong" define-primitive-type
255 [ alien-signed-cell ]
256 [ set-alien-signed-cell ]
259 "to_fixnum" <primitive-type>
260 "long" define-primitive-type
262 [ alien-unsigned-cell ]
263 [ set-alien-unsigned-cell ]
266 "to_cell" <primitive-type>
267 "ulong" define-primitive-type
270 [ set-alien-signed-4 ]
273 "to_fixnum" <primitive-type>
274 "int" define-primitive-type
277 [ set-alien-unsigned-4 ]
280 "to_cell" <primitive-type>
281 "uint" define-primitive-type
284 [ set-alien-signed-2 ]
287 "to_fixnum" <primitive-type>
288 "short" define-primitive-type
291 [ set-alien-unsigned-2 ]
294 "to_cell" <primitive-type>
295 "ushort" define-primitive-type
298 [ set-alien-signed-1 ]
301 "to_fixnum" <primitive-type>
302 "char" define-primitive-type
305 [ set-alien-unsigned-1 ]
308 "to_cell" <primitive-type>
309 "uchar" define-primitive-type
311 [ alien-unsigned-4 zero? not ]
312 [ 1 0 ? set-alien-unsigned-4 ]
315 "to_boolean" <primitive-type>
316 "bool" define-primitive-type
319 [ >r >r >float r> r> set-alien-float ]
322 "to_float" <primitive-type>
323 "float" define-primitive-type
325 T{ float-regs f 4 } "float" c-type set-c-type-reg-class
326 [ >float ] "float" c-type set-c-type-prep
329 [ >r >r >float r> r> set-alien-double ]
332 "to_double" <primitive-type>
333 "double" define-primitive-type
335 T{ float-regs f 8 } "double" c-type set-c-type-reg-class
336 [ >float ] "double" c-type set-c-type-prep
338 [ alien-cell alien>char-string ]
342 "alien_offset" <primitive-type>
343 "char*" define-primitive-type
345 "char*" "uchar*" typedef
347 [ string>char-alien ] "char*" c-type set-c-type-prep
349 [ alien-cell alien>u16-string ]
353 "alien_offset" <primitive-type>
354 "ushort*" define-primitive-type
356 [ string>u16-alien ] "ushort*" c-type set-c-type-prep