diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index 4ed7d9b446..ab354bb569 100644 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -9,6 +9,7 @@ system tools.test parser lexer eval layouts generic.single classes vocabs ; FROM: math => float ; FROM: specialized-arrays.private => specialized-array-vocab ; +FROM: classes.struct.private => binary-zero? ; QUALIFIED-WITH: alien.c-types c SPECIALIZED-ARRAY: char SPECIALIZED-ARRAY: int @@ -474,3 +475,32 @@ CONSULT: struct-test-delegate struct-test-delegator del>> ; 7 >>a 8 >>b ] 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 binary-zero? ] unit-test +[ f ] [ 1 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 diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index b0f315b335..43578ba2a5 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -11,6 +11,7 @@ namespaces assocs vocabs.parser math.functions classes.struct.bit-accessors bit-arrays stack-checker.dependencies system layouts ; FROM: delegate.private => group-words slot-group-words ; +FROM: math => float ; QUALIFIED: math IN: classes.struct @@ -237,10 +238,12 @@ M: struct byte-length class "struct-size" word-prop ; foldable c-ptr [ 0 = ] all? ; +M: object binary-zero? drop f ; inline +M: f binary-zero? drop t ; inline +M: integer binary-zero? zero? ; inline +M: float binary-zero? double>bits zero? ; inline +M: complex binary-zero? >rect [ binary-zero? ] both? ; inline +M: struct binary-zero? binary-object [ 0 = ] all? ; inline : struct-needs-prototype? ( class -- ? ) struct-slots [ initial>> binary-zero? ] all? not ; diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor index 5fa88e39a2..9754fd2abc 100644 --- a/basis/specialized-arrays/specialized-arrays.factor +++ b/basis/specialized-arrays/specialized-arrays.factor @@ -137,14 +137,16 @@ M: pointer underlying-type bi ] "" make ; -PRIVATE> - -: direct-slice ( from to seq -- seq' ) - check-slice +: direct-slice-unsafe ( from to seq -- seq' ) [ nip nth-c-ptr ] [ drop swap - ] [ 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-tail ( seq n -- seq' ) (tail) direct-slice ; inline : direct-head* ( seq n -- seq' ) from-end direct-head ; inline