the start of an endianness library, used by pack

basis/endian/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/endian/endian-tests.factor

@@ -0,0 +1,7 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces tools.test endian ;
+IN: endian.tests
+
+[ t ] [ [ endianness get big-endian = ] with-big-endian ] unit-test
+[ t ] [ [ endianness get little-endian = ] with-little-endian ] unit-test

basis/endian/endian.factor

@@ -0,0 +1,67 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types namespaces io.binary fry
+kernel math ;
+IN: endian
+
+SINGLETONS: big-endian little-endian ;
+
+: native-endianness ( -- class )
+    1 <int> *char 0 = big-endian little-endian ? ;
+
+: >signed ( x n -- y )
+    2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
+
+native-endianness \ native-endianness set-global
+
+SYMBOL: endianness
+
+\ native-endianness get-global endianness set-global
+
+HOOK: >native-endian native-endianness ( obj n -- str )
+
+M: big-endian >native-endian >be ;
+
+M: little-endian >native-endian >le ;
+
+HOOK: unsigned-native-endian> native-endianness ( obj -- str )
+
+M: big-endian unsigned-native-endian> be> ;
+
+M: little-endian unsigned-native-endian> le> ;
+
+: signed-native-endian> ( obj n -- str )
+    [ unsigned-native-endian> ] dip >signed ;
+
+HOOK: >endian endianness ( obj n -- str )
+
+M: big-endian >endian >be ;
+
+M: little-endian >endian >le ;
+
+HOOK: endian> endianness ( seq -- n )
+
+M: big-endian endian> be> ;
+
+M: little-endian endian> le> ;
+
+HOOK: unsigned-endian> endianness ( obj -- str )
+
+M: big-endian unsigned-endian> be> ;
+
+M: little-endian unsigned-endian> le> ;
+
+: signed-endian> ( obj n -- str )
+    [ unsigned-endian> ] dip >signed ;
+
+: with-endianness ( endian quot -- )
+    [ endianness ] dip with-variable ; inline
+
+: with-big-endian ( quot -- )
+    big-endian swap with-endianness ; inline
+
+: with-little-endian ( quot -- )
+    little-endian swap with-endianness ; inline
+
+: with-native-endian ( quot -- )
+    \ native-endianness get-global swap with-endianness ; inline