From 556ab7324686d79f53b0e84c9c140d8244fe99d3 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 14 Jul 2008 01:30:33 -0700 Subject: [PATCH 1/5] Tuple array streamlining --- extra/tuple-arrays/tuple-arrays-docs.factor | 12 +++++++---- extra/tuple-arrays/tuple-arrays-tests.factor | 10 +++++++--- extra/tuple-arrays/tuple-arrays.factor | 21 ++++++++++---------- 3 files changed, 25 insertions(+), 18 deletions(-) diff --git a/extra/tuple-arrays/tuple-arrays-docs.factor b/extra/tuple-arrays/tuple-arrays-docs.factor index d0c86986fd..18f5547e7f 100644 --- a/extra/tuple-arrays/tuple-arrays-docs.factor +++ b/extra/tuple-arrays/tuple-arrays-docs.factor @@ -1,9 +1,13 @@ -USING: help.syntax help.markup splitting kernel ; +USING: help.syntax help.markup splitting kernel sequences ; IN: tuple-arrays HELP: tuple-array -{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back.." } ; +{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back. To convert a sequence to a tuple array, use the word " { $link >tuple-array } "." } ; HELP: -{ $values { "example" tuple } { "length" "a non-negative integer" } { "tuple-array" tuple-array } } -{ $description "Creates an instance of the " { $link } " class with the given length and containing the given tuple class. The tuple class is specified in the form of an example tuple. If the example tuple has a delegate, the tuple array will store a delegate for each element. Otherwise, the delegate will be assumed to be " { $link f } "." } ; +{ $values { "class" "a tuple class" } { "length" "a non-negative integer" } { "tuple-array" tuple-array } } +{ $description "Creates an instance of the " { $link } " class with the given length and containing the given tuple class." } ; + +HELP: >tuple-array +{ $values { "seq" sequence } { "tuple-array" tuple-array } } +{ $description "Converts a sequence into a homogeneous unboxed tuple array of the type indicated by the first element." } ; diff --git a/extra/tuple-arrays/tuple-arrays-tests.factor b/extra/tuple-arrays/tuple-arrays-tests.factor index 132a11f4a6..4c288b1c9e 100755 --- a/extra/tuple-arrays/tuple-arrays-tests.factor +++ b/extra/tuple-arrays/tuple-arrays-tests.factor @@ -1,16 +1,20 @@ -USING: tuple-arrays sequences tools.test namespaces kernel math ; +USING: tuple-arrays sequences tools.test namespaces kernel math accessors ; IN: tuple-arrays.tests SYMBOL: mat TUPLE: foo bar ; C: foo -[ 2 ] [ 2 T{ foo } dup mat set length ] unit-test +[ 2 ] [ 2 foo dup mat set length ] unit-test [ T{ foo } ] [ mat get first ] unit-test [ T{ foo 2 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test [ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test [ T{ foo f 3 } t ] [ mat get [ foo-bar 2 + ] map [ first ] keep tuple-array? ] unit-test -[ 2 ] [ 2 T{ foo t } dup mat set length ] unit-test +[ 2 ] [ 2 foo dup mat set length ] unit-test [ T{ foo } ] [ mat get first ] unit-test [ T{ foo 2 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test + +TUPLE: baz { bing integer } bong ; +[ 0 ] [ 1 baz first bing>> ] unit-test +[ f ] [ 1 baz first bong>> ] unit-test diff --git a/extra/tuple-arrays/tuple-arrays.factor b/extra/tuple-arrays/tuple-arrays.factor index 63e7541c95..5da7085773 100644 --- a/extra/tuple-arrays/tuple-arrays.factor +++ b/extra/tuple-arrays/tuple-arrays.factor @@ -4,27 +4,26 @@ USING: splitting grouping classes.tuple classes math kernel sequences arrays accessors ; IN: tuple-arrays -TUPLE: tuple-array seq class ; +TUPLE: tuple-array { seq read-only } { class read-only } ; -: ( length example -- tuple-array ) - [ tuple>array length 1- [ * { } new-sequence ] keep ] - [ class ] bi tuple-array boa ; +: ( length class -- tuple-array ) + [ + new tuple>array 1 tail + [ concat ] [ length ] bi + ] [ ] bi tuple-array boa ; M: tuple-array nth [ seq>> nth ] [ class>> ] bi prefix >tuple ; -: deconstruct ( tuple -- seq ) - tuple>array 1 tail ; - M: tuple-array set-nth ( elt n seq -- ) - >r >r deconstruct r> r> seq>> set-nth ; + >r >r tuple>array 1 tail r> r> seq>> set-nth ; M: tuple-array new-sequence - class>> new ; + class>> ; -: >tuple-array ( seq -- tuple-array/seq ) +: >tuple-array ( seq -- tuple-array ) dup empty? [ - 0 over first clone-like + 0 over first class clone-like ] unless ; M: tuple-array like From 6034e27d781603c39c900b6d30e26b42b0e17c99 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 14 Jul 2008 01:33:13 -0700 Subject: [PATCH 2/5] Removed superfluous mixin in heaps --- core/heaps/heaps.factor | 19 +++++++------------ 1 file changed, 7 insertions(+), 12 deletions(-) diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor index fe1fc4e172..1873db67b5 100755 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -5,8 +5,6 @@ USING: kernel math sequences arrays assocs sequences.private growable accessors math.order ; IN: heaps -MIXIN: priority-queue - GENERIC: heap-push* ( value key heap -- entry ) GENERIC: heap-peek ( heap -- value key ) GENERIC: heap-pop* ( heap -- ) @@ -36,13 +34,10 @@ TUPLE: max-heap < heap ; : ( -- max-heap ) max-heap ; -INSTANCE: min-heap priority-queue -INSTANCE: max-heap priority-queue - -M: priority-queue heap-empty? ( heap -- ? ) +M: heap heap-empty? ( heap -- ? ) data>> empty? ; -M: priority-queue heap-size ( heap -- n ) +M: heap heap-size ( heap -- n ) data>> length ; -M: priority-queue heap-push* ( value key heap -- entry ) +M: heap heap-push* ( value key heap -- entry ) [ dup ] keep [ data-push ] keep up-heap ; : heap-push ( value key heap -- ) heap-push* drop ; @@ -163,7 +158,7 @@ M: priority-queue heap-push* ( value key heap -- entry ) : >entry< ( entry -- key value ) [ value>> ] [ key>> ] bi ; -M: priority-queue heap-peek ( heap -- value key ) +M: heap heap-peek ( heap -- value key ) data-first >entry< ; : entry>index ( entry heap -- n ) @@ -172,7 +167,7 @@ M: priority-queue heap-peek ( heap -- value key ) ] unless entry-index ; -M: priority-queue heap-delete ( entry heap -- ) +M: heap heap-delete ( entry heap -- ) [ entry>index ] keep 2dup heap-size 1- = [ nip data-pop* @@ -182,10 +177,10 @@ M: priority-queue heap-delete ( entry heap -- ) down-heap ] if ; -M: priority-queue heap-pop* ( heap -- ) +M: heap heap-pop* ( heap -- ) dup data-first swap heap-delete ; -M: priority-queue heap-pop ( heap -- value key ) +M: heap heap-pop ( heap -- value key ) dup data-first [ swap heap-delete ] keep >entry< ; : heap-pop-all ( heap -- alist ) From db0b180498157c07847d8ff8e69bacc8f57923cc Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Mon, 14 Jul 2008 14:53:56 +0200 Subject: [PATCH 3/5] Fix errors in new tests --- extra/ctags/ctags-tests.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/ctags/ctags-tests.factor b/extra/ctags/ctags-tests.factor index 700b897657..c54fe99217 100644 --- a/extra/ctags/ctags-tests.factor +++ b/extra/ctags/ctags-tests.factor @@ -3,17 +3,17 @@ IN: ctags.tests [ t ] [ 91 - { { if { "resource:extra/unix/unix.factor" 91 } } } ctag-lineno = + { if { "resource:extra/unix/unix.factor" 91 } } ctag-lineno = ] unit-test [ t ] [ "resource:extra/unix/unix.factor" - { { if { "resource:extra/unix/unix.factor" 91 } } } ctag-path = + { if { "resource:extra/unix/unix.factor" 91 } } ctag-path = ] unit-test [ t ] [ - if - { { if { "resource:extra/unix/unix.factor" 91 } } } ctag-word = + \ if + { if { "resource:extra/unix/unix.factor" 91 } } ctag-word = ] unit-test [ t ] [ From 54fc3316faf1c12665e9841c0b867f08948df9d6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Jul 2008 13:37:24 -0500 Subject: [PATCH 4/5] Fix delegate for slot property change, declarations and inheritance --- extra/benchmark/fannkuch/fannkuch.factor | 1 + extra/delegate/delegate-tests.factor | 12 ++++++++++++ extra/delegate/delegate.factor | 10 ++++++---- 3 files changed, 19 insertions(+), 4 deletions(-) create mode 100644 extra/benchmark/fannkuch/fannkuch.factor diff --git a/extra/benchmark/fannkuch/fannkuch.factor b/extra/benchmark/fannkuch/fannkuch.factor new file mode 100644 index 0000000000..8b13789179 --- /dev/null +++ b/extra/benchmark/fannkuch/fannkuch.factor @@ -0,0 +1 @@ + diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor index ab0ea988ea..bc173ab0c8 100755 --- a/extra/delegate/delegate-tests.factor +++ b/extra/delegate/delegate-tests.factor @@ -79,3 +79,15 @@ CONSULT: beta hey value>> 1- ; [ -1 ] [ 1 four ] unit-test [ ] [ "IN: delegate.tests FORGET: alpha" eval ] unit-test [ f ] [ hey \ one method ] unit-test + +TUPLE: slot-protocol-test-1 a b ; +TUPLE: slot-protocol-test-2 < slot-protocol-test-1 { c integer } ; + +TUPLE: slot-protocol-test-3 d ; + +CONSULT: slot-protocol-test-2 slot-protocol-test-3 d>> ; + +[ "a" "b" 5 ] [ + T{ slot-protocol-test-3 f T{ slot-protocol-test-2 f "a" "b" 5 } } + [ a>> ] [ b>> ] [ c>> ] tri +] unit-test diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 6cea58058e..fd9b9977e1 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Daniel Ehrenberg +! Copyright (C) 2007, 2008 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: accessors parser generic kernel classes classes.tuple words slots assocs sequences arrays vectors definitions @@ -14,9 +14,11 @@ IN: delegate GENERIC: group-words ( group -- words ) M: tuple-class group-words - "slot-names" word-prop [ - [ reader-word ] [ writer-word ] bi - 2array [ 0 2array ] map + all-slots [ + name>> + [ reader-word 0 2array ] + [ writer-word 0 2array ] bi + 2array ] map concat ; ! Consultation From 2b45f45feb79ba22e8e12083fffbf34a0bf3b8fb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Jul 2008 13:37:37 -0500 Subject: [PATCH 5/5] Oops --- extra/benchmark/fannkuch/fannkuch.factor | 1 - 1 file changed, 1 deletion(-) delete mode 100644 extra/benchmark/fannkuch/fannkuch.factor diff --git a/extra/benchmark/fannkuch/fannkuch.factor b/extra/benchmark/fannkuch/fannkuch.factor deleted file mode 100644 index 8b13789179..0000000000 --- a/extra/benchmark/fannkuch/fannkuch.factor +++ /dev/null @@ -1 +0,0 @@ -