diff --git a/basis/tuple-arrays/tuple-arrays-tests.factor b/basis/tuple-arrays/tuple-arrays-tests.factor index 4606ecdada..2eeae20aa1 100644 --- a/basis/tuple-arrays/tuple-arrays-tests.factor +++ b/basis/tuple-arrays/tuple-arrays-tests.factor @@ -23,3 +23,10 @@ TUPLE-ARRAY: baz [ 0 ] [ 1 first bing>> ] unit-test [ f ] [ 1 first bong>> ] unit-test + +TUPLE: broken x ; +: broken ( -- ) ; + +TUPLE-ARRAY: broken + +[ 100 ] [ 100 length ] unit-test \ No newline at end of file diff --git a/basis/tuple-arrays/tuple-arrays.factor b/basis/tuple-arrays/tuple-arrays.factor index 466262f3e0..35d771416c 100644 --- a/basis/tuple-arrays/tuple-arrays.factor +++ b/basis/tuple-arrays/tuple-arrays.factor @@ -1,26 +1,36 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators.smart fry functors grouping -kernel macros sequences sequences.private stack-checker -parser ; +USING: accessors arrays combinators.smart fry functors kernel +kernel.private macros sequences combinators sequences.private +stack-checker parser math classes.tuple.private ; FROM: inverse => undo ; IN: tuple-arrays ] ; + MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ; +: tuple-arity ( class -- quot ) '[ _ boa ] infer-in ; inline + : smart-tuple>array ( tuple class -- array ) '[ [ _ boa ] undo ] output>array ; inline -: smart-array>tuple ( array class -- tuple ) - '[ _ boa ] inputarray ] bi ; inline +: tuple-slice ( n seq -- slice ) + [ n>> [ * dup ] keep + ] [ seq>> ] bi { array } declare slice boa ; inline + +: read-tuple ( slice class -- tuple ) + '[ _ boa-unsafe ] input [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ] + bi '[ _ dip @ ] ; + PRIVATE> FUNCTOR: define-tuple-array ( CLASS -- ) @@ -35,31 +45,26 @@ CLASS-array? IS ${CLASS-array}? WHERE -TUPLE: CLASS-array { seq sliced-groups read-only } ; +TUPLE: CLASS-array +{ seq array read-only } +{ n array-capacity read-only } +{ length array-capacity read-only } ; : ( length -- tuple-array ) - CLASS tuple-prototype concat - CLASS tuple-arity - CLASS-array boa ; + [ \ CLASS [ tuple-prototype concat ] [ tuple-arity ] bi ] keep + \ CLASS-array boa ; inline -M: CLASS-array nth-unsafe - seq>> nth-unsafe CLASS smart-array>tuple ; +M: CLASS-array length length>> ; -M: CLASS-array set-nth-unsafe - [ CLASS smart-tuple>array ] 2dip seq>> set-nth-unsafe ; +M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ; -M: CLASS-array new-sequence - drop ; +M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ; -: >CLASS-array ( seq -- tuple-array ) - dup empty? [ - 0 clone-like - ] unless ; +M: CLASS-array new-sequence drop ; -M: CLASS-array like - drop dup CLASS-array? [ >CLASS-array ] unless ; +: >CLASS-array ( seq -- tuple-array ) 0 clone-like ; -M: CLASS-array length seq>> length ; +M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ; INSTANCE: CLASS-array sequence