1 ! Copyright (C) 2011 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.accessors alien.c-types alien.data arrays
4 classes.struct.private combinators compiler.units endian fry
5 generalizations kernel macros math math.bitwise namespaces
6 sequences slots words ;
7 QUALIFIED-WITH: alien.c-types c
10 ERROR: invalid-signed-conversion n ;
12 : convert-signed-quot ( n -- quot )
14 { 1 [ [ char <ref> char deref ] ] }
15 { 2 [ [ c:short <ref> c:short deref ] ] }
16 { 4 [ [ int <ref> int deref ] ] }
17 { 8 [ [ longlong <ref> longlong deref ] ] }
18 [ invalid-signed-conversion ]
21 MACRO: byte-reverse ( n signed? -- quot )
26 [ 1 + - -8 * ] [ nip 8 * ] 2bi
27 '[ _ shift 0xff bitand _ shift ]
29 ] [ 1 - [ bitor ] n*quot ] bi
31 [ convert-signed-quot ] [ drop [ ] ] if
35 SYMBOLS: le8 be8 ule8 ube8
36 ule16 ule32 ule64 ube16 ube32 ube64
37 le16 le32 le64 be16 be32 be64 ;
39 : endian-c-type? ( symbol -- ? )
41 le8 be8 ule8 ube8 ule16 ule32 ule64
42 ube16 ube32 ube64 le16 le32 le64 be16 be32 be64
45 ERROR: unknown-endian-c-type symbol ;
47 : endian-c-type>c-type-symbol ( symbol -- symbol' )
49 { [ dup { ule16 ube16 } member? ] [ drop ushort ] }
50 { [ dup { le16 be16 } member? ] [ drop c:short ] }
51 { [ dup { ule32 ube32 } member? ] [ drop uint ] }
52 { [ dup { le32 be32 } member? ] [ drop int ] }
53 { [ dup { ule64 ube64 } member? ] [ drop ulonglong ] }
54 { [ dup { le64 be64 } member? ] [ drop longlong ] }
55 [ unknown-endian-c-type ]
58 : change-c-type-accessors ( n ? c-type -- c-type' )
59 endian-c-type>c-type-symbol "c-type" word-prop clone
65 [ alien-unsigned-4 4 f byte-reverse 32 shift ]
66 [ 4 + alien-unsigned-4 4 f byte-reverse ] 2bi bitor
68 ] dip [ [ 64 >signed ] compose ] when
71 [ '[ [ [ _ _ byte-reverse ] 2dip ] prepose ] change-setter ] 3bi
73 [ '[ [ _ _ byte-reverse ] compose ] change-getter drop ]
74 [ '[ [ [ _ _ byte-reverse ] 2dip ] prepose ] change-setter ] 3bi
77 : typedef-endian ( n ? c-type endian -- )
78 native-endianness get = [
79 2nip [ endian-c-type>c-type-symbol ] keep typedef
81 [ change-c-type-accessors ] keep typedef
84 : typedef-le ( n ? c-type -- ) little-endian typedef-endian ;
85 : typedef-be ( n ? c-type -- ) big-endian typedef-endian ;
90 \ uchar \ ule8 typedef
91 \ uchar \ ube8 typedef
92 2 f \ ule16 typedef-le
93 2 f \ ube16 typedef-be
96 4 f \ ule32 typedef-le
97 4 f \ ube32 typedef-be
100 8 f \ ule64 typedef-le
101 8 f \ ube64 typedef-be
102 8 t \ le64 typedef-le
103 8 t \ be64 typedef-be
104 ] with-compilation-unit
107 : pair>c-type ( pair -- c-type )
108 [ native-endianness get big-endian = ] dip first2 ? ;
110 ! endian is desired endian type. if we match endianness, return the c type
111 ! otherwise return the opposite of our endianness
112 : endian-slot ( endian c-type pair -- endian-slot )
113 [ native-endianness get = ] 2dip rot [ drop ] [ nip pair>c-type ] if ;
115 ERROR: unsupported-endian-type endian slot ;
117 : slot>endian-slot ( endian slot -- endian-slot )
119 first2 [ slot>endian-slot ] dip 2array
122 { [ dup bool = ] [ 2drop bool ] }
123 { [ dup char = ] [ 2drop char ] }
124 { [ dup uchar = ] [ 2drop uchar ] }
125 { [ dup c:short = ] [ { le16 be16 } endian-slot ] }
126 { [ dup ushort = ] [ { ule16 ube16 } endian-slot ] }
127 { [ dup int = ] [ { le32 be32 } endian-slot ] }
128 { [ dup uint = ] [ { ule32 ube32 } endian-slot ] }
129 { [ dup longlong = ] [ { le64 be64 } endian-slot ] }
130 { [ dup ulonglong = ] [ { ule64 ube64 } endian-slot ] }
131 { [ dup endian-c-type? ] [ nip ] }
132 { [ dup pointer? ] [ nip ] }
133 [ unsupported-endian-type ]
137 : set-endian-slots ( endian slots -- slot-specs )
138 [ [ slot>endian-slot ] change-type ] with map ;
140 : define-endian-struct-class ( class slots endian -- )
141 swap make-slots set-endian-slots
142 [ compute-struct-offsets ] [ struct-alignment ]
143 (define-struct-class) ;
145 : define-endian-packed-struct-class ( class slots endian -- )
146 swap make-packed-slots set-endian-slots
147 [ compute-struct-offsets ] [ drop 1 ]
148 (define-struct-class) ;
151 parse-struct-definition
152 little-endian define-endian-struct-class ;
155 parse-struct-definition
156 big-endian define-endian-struct-class ;
158 SYNTAX: LE-PACKED-STRUCT:
159 parse-struct-definition
160 little-endian define-endian-packed-struct-class ;
162 SYNTAX: BE-PACKED-STRUCT:
163 parse-struct-definition
164 big-endian define-endian-packed-struct-class ;