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

classes.struct: fix some bugs in binary-zero?, add unit tests

db4
Joe Groff 2010-06-10 16:49:59 -07:00
parent 7825cb6d10
commit e84b2e8c60
3 changed files with 43 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
basis/classes/struct/struct-tests.factor
View File

@ -9,6 +9,7 @@ system tools.test parser lexer eval layouts generic.single classes
vocabs ; vocabs ;
FROM: math => float ; FROM: math => float ;
FROM: specialized-arrays.private => specialized-array-vocab ; FROM: specialized-arrays.private => specialized-array-vocab ;
FROM: classes.struct.private => binary-zero? ;
QUALIFIED-WITH: alien.c-types c QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: char SPECIALIZED-ARRAY: char
SPECIALIZED-ARRAY: int SPECIALIZED-ARRAY: int
@ -474,3 +475,32 @@ CONSULT: struct-test-delegate struct-test-delegator del>> ;
7 >>a 7 >>a
8 >>b 8 >>b
] unit-test ] unit-test
SPECIALIZED-ARRAY: struct-test-foo
[ t ] [ 0 binary-zero? ] unit-test
[ f ] [ 1 binary-zero? ] unit-test
[ f ] [ -1 binary-zero? ] unit-test
[ t ] [ 0.0 binary-zero? ] unit-test
[ f ] [ 1.0 binary-zero? ] unit-test
[ f ] [ -0.0 binary-zero? ] unit-test
[ t ] [ C{ 0.0 0.0 } binary-zero? ] unit-test
[ f ] [ C{ 1.0 0.0 } binary-zero? ] unit-test
[ f ] [ C{ -0.0 0.0 } binary-zero? ] unit-test
[ f ] [ C{ 0.0 1.0 } binary-zero? ] unit-test
[ f ] [ C{ 0.0 -0.0 } binary-zero? ] unit-test
[ t ] [ f binary-zero? ] unit-test
[ t ] [ 0 <alien> binary-zero? ] unit-test
[ f ] [ 1 <alien> binary-zero? ] unit-test
[ f ] [ B{ } binary-zero? ] unit-test
[ t ] [ S{ struct-test-foo f 0 0 f } binary-zero? ] unit-test
[ f ] [ S{ struct-test-foo f 1 0 f } binary-zero? ] unit-test
[ f ] [ S{ struct-test-foo f 0 1 f } binary-zero? ] unit-test
[ f ] [ S{ struct-test-foo f 0 0 t } binary-zero? ] unit-test
[ t t f ] [
struct-test-foo-array{
S{ struct-test-foo f 0 0 f }
S{ struct-test-foo f 0 0 f }
S{ struct-test-foo f 1 0 f }
} [ first binary-zero? ] [ second binary-zero? ] [ third binary-zero? ] tri
] unit-test

11
basis/classes/struct/struct.factor
View File

@ -11,6 +11,7 @@ namespaces assocs vocabs.parser math.functions
classes.struct.bit-accessors bit-arrays classes.struct.bit-accessors bit-arrays
stack-checker.dependencies system layouts ; stack-checker.dependencies system layouts ;
FROM: delegate.private => group-words slot-group-words ; FROM: delegate.private => group-words slot-group-words ;
FROM: math => float ;
QUALIFIED: math QUALIFIED: math
IN: classes.struct IN: classes.struct
@ -237,10 +238,12 @@ M: struct byte-length class "struct-size" word-prop ; foldable
<PRIVATE <PRIVATE
GENERIC: binary-zero? ( value -- ? ) GENERIC: binary-zero? ( value -- ? )
M: object binary-zero? drop f ; M: object binary-zero? drop f ; inline
M: f binary-zero? drop t ; M: f binary-zero? drop t ; inline
M: number binary-zero? 0 = ; M: integer binary-zero? zero? ; inline
M: struct binary-zero? >c-ptr [ 0 = ] all? ; M: float binary-zero? double>bits zero? ; inline
M: complex binary-zero? >rect [ binary-zero? ] both? ; inline
M: struct binary-zero? binary-object <direct-uchar-array> [ 0 = ] all? ; inline
: struct-needs-prototype? ( class -- ? ) : struct-needs-prototype? ( class -- ? )
struct-slots [ initial>> binary-zero? ] all? not ; struct-slots [ initial>> binary-zero? ] all? not ;

10
basis/specialized-arrays/specialized-arrays.factor
View File

@ -137,14 +137,16 @@ M: pointer underlying-type
bi bi
] "" make ; ] "" make ;
PRIVATE> : direct-slice-unsafe ( from to seq -- seq' )
: direct-slice ( from to seq -- seq' )
check-slice
[ nip nth-c-ptr ] [ nip nth-c-ptr ]
[ drop swap - ] [ drop swap - ]
[ 2nip ] 3tri direct-like ; inline [ 2nip ] 3tri direct-like ; inline
PRIVATE>
: direct-slice ( from to seq -- seq' )
check-slice direct-slice-unsafe ; inline
: direct-head ( seq n -- seq' ) (head) direct-slice ; inline : direct-head ( seq n -- seq' ) (head) direct-slice ; inline
: direct-tail ( seq n -- seq' ) (tail) direct-slice ; inline : direct-tail ( seq n -- seq' ) (tail) direct-slice ; inline
: direct-head* ( seq n -- seq' ) from-end direct-head ; inline : direct-head* ( seq n -- seq' ) from-end direct-head ; inline