diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index d631a91eae..3dba702cf2 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -1,15 +1,17 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser kernel locals.private quotations classes.tuple -classes.tuple.parser make lexer combinators generic words -interpolate namespaces sequences io.streams.string fry -classes.mixin ; +USING: kernel locals.private quotations classes.tuple make +combinators generic words interpolate namespaces sequences +io.streams.string fry classes.mixin effects lexer parser +classes.tuple.parser effects.parser ; IN: functors : scan-param ( -- obj ) scan-object dup special? [ literalize ] unless ; -: define* ( word def -- ) over set-word define ; +: define* ( word def effect -- ) pick set-word define-declared ; + +: DEFINE* ( -- ) effect get parsed \ define* parsed ; : `TUPLE: scan-param parsed @@ -25,21 +27,25 @@ IN: functors \ define-tuple-class parsed ; parsing : `M: + effect off scan-param parsed scan-param parsed \ create-method parsed parse-definition parsed - \ define* parsed ; parsing + DEFINE* ; parsing : `C: + effect off scan-param parsed scan-param parsed - [ [ boa ] curry define* ] over push-all ; parsing + [ [ boa ] curry ] over push-all + DEFINE* ; parsing : `: + effect off scan-param parsed parse-definition parsed - \ define* parsed ; parsing + DEFINE* ; parsing : `INSTANCE: scan-param parsed @@ -50,6 +56,9 @@ IN: functors : `parsing \ parsing parsed ; parsing +: `( + ")" parse-effect effect set ; parsing + : (INTERPOLATE) ( accum quot -- accum ) [ scan interpolate-locals ] dip '[ _ with-string-writer @ ] parsed ; @@ -69,6 +78,7 @@ DEFER: ;FUNCTOR delimiter { "INSTANCE:" POSTPONE: `INSTANCE: } { "inline" POSTPONE: `inline } { "parsing" POSTPONE: `parsing } + { "(" POSTPONE: `( } } ; : push-functor-words ( -- ) diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor index dd5164b8b4..2cde26b731 100644 --- a/basis/specialized-arrays/direct/functor/functor.factor +++ b/basis/specialized-arrays/direct/functor/functor.factor @@ -23,7 +23,7 @@ TUPLE: A { underlying alien read-only } { length fixnum read-only } ; -: A boa ; inline +: ( alien len -- direct-array ) A boa ; inline M: A length length>> ; M: A nth-unsafe underlying>> NTH call ; M: A set-nth-unsafe underlying>> SET-NTH call ; diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 8536e6f81a..52977dc22a 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -1,19 +1,25 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: functors sequences sequences.private -prettyprint.backend kernel words classes math parser -alien.c-types byte-arrays accessors ; +USING: functors sequences sequences.private prettyprint.backend +kernel words classes math parser alien.c-types byte-arrays +accessors summary ; IN: specialized-arrays.functor +ERROR: bad-byte-array-length byte-array type ; + +M: bad-byte-array-length summary + drop "Byte array length doesn't divide type width" ; + FUNCTOR: define-array ( T -- ) -A DEFINES ${T}-array - DEFINES <${A}> ->A DEFINES >${A} -A{ DEFINES ${A}{ +A DEFINES ${T}-array + DEFINES <${A}> +>A DEFINES >${A} +byte-array>A DEFINES byte-array>${A} +A{ DEFINES ${A}{ -NTH [ T dup c-getter array-accessor ] -SET-NTH [ T dup c-setter array-accessor ] +NTH [ T dup c-getter array-accessor ] +SET-NTH [ T dup c-setter array-accessor ] WHERE @@ -21,7 +27,11 @@ TUPLE: A { length array-capacity read-only } { underlying byte-array read-only } ; -: dup T A boa ; inline +: ( n -- specialized-array ) dup T A boa ; inline + +: byte-array>A ( byte-array -- specialized-array ) + dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless + swap A boa ; inline M: A clone [ length>> ] [ underlying>> clone ] bi A boa ; @@ -31,7 +41,7 @@ M: A nth-unsafe underlying>> NTH call ; M: A set-nth-unsafe underlying>> SET-NTH call ; -: >A A new clone-like ; inline +: >A ( seq -- specialized-array ) A new clone-like ; inline M: A like drop dup A instance? [ >A execute ] unless ; diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor index 5810085d47..1ca041191e 100644 --- a/basis/specialized-arrays/specialized-arrays-tests.factor +++ b/basis/specialized-arrays/specialized-arrays-tests.factor @@ -1,6 +1,7 @@ IN: specialized-arrays.tests USING: tools.test specialized-arrays sequences -specialized-arrays.int speicalized-arrays.bool ; +specialized-arrays.int specialized-arrays.bool +specialized-arrays.ushort alien.c-types accessors kernel ; [ t ] [ { 1 2 3 } >int-array int-array? ] unit-test @@ -9,3 +10,9 @@ specialized-arrays.int speicalized-arrays.bool ; [ 2 ] [ int-array{ 1 2 3 } second ] unit-test [ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >int-array underlying>> = ] unit-test + +[ ushort-array{ 1234 } ] [ + little-endian? B{ 210 4 } B{ 4 210 } ? byte-array>ushort-array +] unit-test + +[ B{ 210 4 1 } byte-array>ushort-array ] must-fail