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 ) 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 ] [ 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 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