steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

str -> bytes, utility word in endian

db4
Doug Coleman 2009-02-13 15:47:48 -06:00
parent d7e10c3072
commit 03839aa3cc
1 changed files with 23 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
basis/endian/endian.factor
View File

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