diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index a5f3042b38..df008d52bd 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -1,11 +1,12 @@ IN: functors.tests -USING: functors tools.test math words kernel ; +USING: functors tools.test math words kernel multiline parser +io.streams.string generic ; << FUNCTOR: define-box ( T -- ) -B DEFINES ${T}-box +B DEFINES-CLASS ${T}-box DEFINES <${B}> WHERE @@ -62,4 +63,48 @@ WHERE >> -[ 4 ] [ 1 3 blah ] unit-test \ No newline at end of file +[ 4 ] [ 1 3 blah ] unit-test + +GENERIC: some-generic ( a -- b ) + +! Does replacing an ordinary word with a functor-generated one work? +[ [ ] ] [ + <" IN: functors.tests + + TUPLE: some-tuple ; + : some-word ( -- ) ; + M: some-tuple some-generic ; + "> "functors-test" parse-stream +] unit-test + +: test-redefinition ( -- ) + [ t ] [ "some-word" "functors.tests" lookup >boolean ] unit-test + [ t ] [ "some-tuple" "functors.tests" lookup >boolean ] unit-test + [ t ] [ + "some-tuple" "functors.tests" lookup + "some-generic" "functors.tests" lookup method >boolean + ] unit-test ; + +test-redefinition + +FUNCTOR: redefine-test ( W -- ) + +W-word DEFINES ${W}-word +W-tuple DEFINES-CLASS ${W}-tuple +W-generic IS ${W}-generic + +WHERE + +TUPLE: W-tuple ; +: W-word ( -- ) ; +M: W-tuple W-generic ; + +;FUNCTOR + +[ [ ] ] [ + <" IN: functors.tests + << "some" redefine-test >> + "> "functors-test" parse-stream +] unit-test + +test-redefinition \ No newline at end of file diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index f4d35b6932..14151692f0 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -3,8 +3,9 @@ USING: kernel quotations classes.tuple make combinators generic words interpolate namespaces sequences io.streams.string fry classes.mixin effects lexer parser classes.tuple.parser -effects.parser locals.types locals.parser -locals.rewrite.closures vocabs.parser arrays accessors ; +effects.parser locals.types locals.parser generic.parser +locals.rewrite.closures vocabs.parser classes.parser +arrays accessors ; IN: functors ! This is a hack @@ -29,7 +30,7 @@ M: object >fake-quotations ; GENERIC: fake-quotations> ( fake -- quot ) M: fake-quotation fake-quotations> - seq>> [ fake-quotations> ] map >quotation ; + seq>> [ fake-quotations> ] [ ] map-as ; M: array fake-quotations> [ fake-quotations> ] map ; @@ -57,7 +58,7 @@ M: object fake-quotations> ; effect off scan-param parsed scan-param parsed - \ create-method parsed + \ create-method-in parsed parse-definition* DEFINE* ; parsing @@ -96,6 +97,8 @@ PRIVATE> : DEFINES [ create-in ] (INTERPOLATE) ; parsing +: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ; parsing + DEFER: ;FUNCTOR delimiter DEFINES <${TYPE}-blas-matrix> >MATRIX DEFINES >${TYPE}-blas-matrix XMATRIX{ DEFINES ${T}matrix{ diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index 3b7f89f730..4e61f4478e 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -134,7 +134,7 @@ XCOPY IS cblas_${T}copy XSWAP IS cblas_${T}swap IXAMAX IS cblas_i${T}amax -VECTOR DEFINES ${TYPE}-blas-vector +VECTOR DEFINES-CLASS ${TYPE}-blas-vector DEFINES <${TYPE}-blas-vector> >VECTOR DEFINES >${TYPE}-blas-vector diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor index ce23186fc6..0c3999db44 100755 --- a/basis/specialized-arrays/direct/functor/functor.factor +++ b/basis/specialized-arrays/direct/functor/functor.factor @@ -11,7 +11,7 @@ A' IS ${T}-array >A' IS >${T}-array IS <${A'}> -A DEFINES direct-${T}-array +A DEFINES-CLASS direct-${T}-array DEFINES <${A}> NTH [ T dup c-getter array-accessor ] diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 9a56346be4..3c2c53db31 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -15,7 +15,7 @@ M: bad-byte-array-length summary FUNCTOR: define-array ( T -- ) -A DEFINES ${T}-array +A DEFINES-CLASS ${T}-array DEFINES <${A}> (A) DEFINES (${A}) >A DEFINES >${A} diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor index 2410cc284e..9d48a9e79e 100644 --- a/basis/specialized-vectors/functor/functor.factor +++ b/basis/specialized-vectors/functor/functor.factor @@ -9,7 +9,7 @@ FUNCTOR: define-vector ( T -- ) A IS ${T}-array IS <${A}> -V DEFINES ${T}-vector +V DEFINES-CLASS ${T}-vector DEFINES <${V}> >V DEFINES >${V} V{ DEFINES ${V}{