85 lines
2.5 KiB
Factor
85 lines
2.5 KiB
Factor
|
! Copyright (C) 2011 Doug Coleman.
|
||
|
|
! See http://factorcode.org/license.txt for BSD license.
|
||
|
|
USING: accessors alien.accessors alien.c-types combinators
|
||
|
|
compiler.units endian fry generalizations kernel macros math
|
||
|
|
namespaces sequences words alien.data ;
|
||
|
|
QUALIFIED-WITH: alien.c-types ac
|
||
|
|
IN: alien.endian
|
||
|
|
|
||
|
|
ERROR: invalid-signed-conversion n ;
|
||
|
|
|
||
|
|
: convert-signed-quot ( n -- quot )
|
||
|
|
{
|
||
|
|
{ 1 [ [ char <ref> char deref ] ] }
|
||
|
|
{ 2 [ [ ac:short <ref> ac:short deref ] ] }
|
||
|
|
{ 4 [ [ int <ref> int deref ] ] }
|
||
|
|
{ 8 [ [ longlong <ref> longlong deref ] ] }
|
||
|
|
[ invalid-signed-conversion ]
|
||
|
|
} case ; inline
|
||
|
|
|
||
|
|
MACRO: byte-reverse ( n signed? -- quot )
|
||
|
|
[
|
||
|
|
drop
|
||
|
|
[
|
||
|
|
dup iota [
|
||
|
|
[ 1 + - -8 * ] [ nip 8 * ] 2bi
|
||
|
|
'[ _ shift HEX: ff bitand _ shift ]
|
||
|
|
] with map
|
||
|
|
] [ 1 - [ bitor ] n*quot ] bi
|
||
|
|
] [
|
||
|
|
[ convert-signed-quot ] [ drop [ ] ] if
|
||
|
|
] 2bi
|
||
|
|
'[ _ cleave @ @ ] ;
|
||
|
|
|
||
|
|
SYMBOLS: le8 be8 ule8 ube8
|
||
|
|
ule16 ule32 ule64 ube16 ube32 ube64
|
||
|
|
le16 le32 le64 be16 be32 be64 ;
|
||
|
|
|
||
|
|
ERROR: unknown-endian-c-type symbol ;
|
||
|
|
|
||
|
|
: endian-c-type>c-type-symbol ( symbol -- symbol' )
|
||
|
|
{
|
||
|
|
{ [ dup { ule16 ube16 } member? ] [ drop ushort ] }
|
||
|
|
{ [ dup { le16 be16 } member? ] [ drop ac:short ] }
|
||
|
|
{ [ dup { ule32 ube32 } member? ] [ drop uint ] }
|
||
|
|
{ [ dup { le32 be32 } member? ] [ drop int ] }
|
||
|
|
{ [ dup { ule64 ube64 } member? ] [ drop ulonglong ] }
|
||
|
|
{ [ dup { le64 be64 } member? ] [ drop longlong ] }
|
||
|
|
[ unknown-endian-c-type ]
|
||
|
|
} cond ;
|
||
|
|
|
||
|
|
: change-c-type-accessors ( n ? c-type -- c-type' )
|
||
|
|
endian-c-type>c-type-symbol "c-type" word-prop clone
|
||
|
|
-rot
|
||
|
|
[ '[ [ _ _ byte-reverse ] compose ] change-getter drop ]
|
||
|
|
[ '[ [ [ _ _ byte-reverse ] 2dip ] prepose ] change-setter ] 3bi ;
|
||
|
|
|
||
|
|
: typedef-endian ( n ? c-type endian -- )
|
||
|
|
native-endianness get = [
|
||
|
|
2nip [ endian-c-type>c-type-symbol ] keep typedef
|
||
|
|
] [
|
||
|
|
[ change-c-type-accessors ] keep typedef
|
||
|
|
] if ;
|
||
|
|
|
||
|
|
: typedef-le ( n ? c-type -- ) little-endian typedef-endian ;
|
||
|
|
: typedef-be ( n ? c-type -- ) big-endian typedef-endian ;
|
||
|
|
|
||
|
|
[
|
||
|
|
\ char \ le8 typedef
|
||
|
|
\ char \ be8 typedef
|
||
|
|
\ uchar \ ule8 typedef
|
||
|
|
\ uchar \ ube8 typedef
|
||
|
|
2 f \ ule16 typedef-le
|
||
|
|
2 f \ ube16 typedef-be
|
||
|
|
2 t \ le16 typedef-le
|
||
|
|
2 t \ be16 typedef-be
|
||
|
|
4 f \ ule32 typedef-le
|
||
|
|
4 f \ ube32 typedef-be
|
||
|
|
4 t \ le32 typedef-le
|
||
|
|
4 t \ be32 typedef-be
|
||
|
|
8 f \ ule64 typedef-le
|
||
|
|
8 f \ ube64 typedef-be
|
||
|
|
8 t \ le64 typedef-le
|
||
|
|
8 t \ be64 typedef-be
|
||
|
|
] with-compilation-unit
|