diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index fec3bdbc6f..322974c3fd 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -2,18 +2,18 @@ USING: definitions generic kernel kernel.private math math.constants parser sequences tools.test words assocs namespaces quotations sequences.private classes continuations generic.standard effects tuples tuples.private arrays vectors -strings compiler.units ; +strings compiler.units accessors ; IN: tuples.tests TUPLE: rect x y w h ; : rect construct-boa ; -: move ( x rect -- ) - [ rect-x + ] keep set-rect-x ; +: move ( x rect -- rect ) + [ + ] change-x ; -[ f ] [ 10 20 30 40 dup clone 5 swap [ move ] keep = ] unit-test +[ f ] [ 10 20 30 40 dup clone 5 swap move = ] unit-test -[ t ] [ 10 20 30 40 dup clone 0 swap [ move ] keep = ] unit-test +[ t ] [ 10 20 30 40 dup clone 0 swap move = ] unit-test GENERIC: delegation-test M: object delegation-test drop 3 ; @@ -34,27 +34,46 @@ TUPLE: quuux-tuple-2 ; [ 4 ] [ delegation-test-2 ] unit-test +! Make sure we handle tuple class redefinition +TUPLE: redefinition-test ; + +C: redefinition-test + + "redefinition-test" set + +[ t ] [ "redefinition-test" get redefinition-test? ] unit-test + +"IN: tuples.tests TUPLE: redefinition-test ;" eval + +[ t ] [ "redefinition-test" get redefinition-test? ] unit-test + ! Make sure we handle changing shapes! TUPLE: point x y ; C: point -100 200 "p" set +[ ] [ 100 200 "p" set ] unit-test ! Use eval to sequence parsing explicitly -"IN: tuples.tests TUPLE: point x y z ;" eval +[ ] [ "IN: tuples.tests TUPLE: point x y z ;" eval ] unit-test -[ 100 ] [ "p" get point-x ] unit-test -[ 200 ] [ "p" get point-y ] unit-test -[ f ] [ "p" get "point-z" "tuples.tests" lookup execute ] unit-test +[ 100 ] [ "p" get x>> ] unit-test +[ 200 ] [ "p" get y>> ] unit-test +[ f ] [ "p" get "z>>" "accessors" lookup execute ] unit-test -300 "p" get "set-point-z" "tuples.tests" lookup execute +"p" get 300 ">>z" "accessors" lookup execute drop + +[ 4 ] [ "p" get tuple-size ] unit-test + +[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test "IN: tuples.tests TUPLE: point z y ;" eval -[ "p" get point-x ] must-fail -[ 200 ] [ "p" get point-y ] unit-test -[ 300 ] [ "p" get "point-z" "tuples.tests" lookup execute ] unit-test +[ 3 ] [ "p" get tuple-size ] unit-test + +[ "p" get x>> ] must-fail +[ 200 ] [ "p" get y>> ] unit-test +[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test TUPLE: predicate-test ; @@ -68,10 +87,10 @@ PREDICATE: tuple silly-pred class \ rect = ; GENERIC: area -M: silly-pred area dup rect-w swap rect-h * ; +M: silly-pred area dup w>> swap h>> * ; TUPLE: circle radius ; -M: circle area circle-radius sq pi * ; +M: circle area radius>> sq pi * ; [ 200 ] [ T{ rect f 0 0 10 20 } area ] unit-test @@ -88,7 +107,7 @@ TUPLE: delegate-clone ; [ T{ delegate-clone T{ empty f } } clone ] unit-test ! Compiler regression -[ t length ] [ no-method-object t eq? ] must-fail-with +[ t length ] [ object>> t eq? ] must-fail-with [ "" ] [ "TUPLE: constructor-test ; C: constructor-test" eval word word-name ] unit-test @@ -96,7 +115,7 @@ TUPLE: delegate-clone ; TUPLE: size-test a b c d ; [ t ] [ - T{ size-test } array-capacity + T{ size-test } tuple-size size-test tuple-size = ] unit-test @@ -213,55 +232,50 @@ C: erg's-reshape-problem ! tuples are reshaped : cons-test-1 \ erg's-reshape-problem construct-empty ; : cons-test-2 \ erg's-reshape-problem construct-boa ; -: cons-test-3 - { set-erg's-reshape-problem-a } - \ erg's-reshape-problem construct ; -"IN: tuples.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval - -[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test - -[ t ] [ cons-test-1 array-capacity "a" get array-capacity = ] unit-test - -[ t ] [ 1 cons-test-3 array-capacity "a" get array-capacity = ] unit-test - -[ - "IN: tuples.tests SYMBOL: not-a-class C: not-a-class" eval -] [ [ no-tuple-class? ] is? ] must-fail-with - -! Hardcore unit tests -USE: threads - -\ thread "slot-names" word-prop "slot-names" set - -[ ] [ - [ - \ thread { "xxx" } "slot-names" get append - define-tuple-class - ] with-compilation-unit - - [ 1337 sleep ] "Test" spawn drop - - [ - \ thread "slot-names" get - define-tuple-class - ] with-compilation-unit -] unit-test - -USE: vocabs - -\ vocab "slot-names" word-prop "slot-names" set - -[ ] [ - [ - \ vocab { "xxx" } "slot-names" get append - define-tuple-class - ] with-compilation-unit - - all-words drop - - [ - \ vocab "slot-names" get - define-tuple-class - ] with-compilation-unit -] unit-test +! "IN: tuples.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval +! +! [ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test +! +! [ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test +! +! [ +! "IN: tuples.tests SYMBOL: not-a-class C: not-a-class" eval +! ] [ [ no-tuple-class? ] is? ] must-fail-with +! +! ! Hardcore unit tests +! USE: threads +! +! \ thread "slot-names" word-prop "slot-names" set +! +! [ ] [ +! [ +! \ thread { "xxx" } "slot-names" get append +! define-tuple-class +! ] with-compilation-unit +! +! [ 1337 sleep ] "Test" spawn drop +! +! [ +! \ thread "slot-names" get +! define-tuple-class +! ] with-compilation-unit +! ] unit-test +! +! USE: vocabs +! +! \ vocab "slot-names" word-prop "slot-names" set +! +! [ ] [ +! [ +! \ vocab { "xxx" } "slot-names" get append +! define-tuple-class +! ] with-compilation-unit +! +! all-words drop +! +! [ +! \ vocab "slot-names" get +! define-tuple-class +! ] with-compilation-unit +! ] unit-test diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index 56fb12fffc..84b4f2eae5 100755 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -3,7 +3,7 @@ USING: arrays definitions hashtables kernel kernel.private math namespaces sequences sequences.private strings vectors words quotations memory combinators generic -classes classes.private slots slots.deprecated slots.private +classes classes.private slots.deprecated slots.private slots compiler.units ; IN: tuples @@ -49,43 +49,6 @@ PRIVATE> 2drop f ] if ; -: permutation ( seq1 seq2 -- permutation ) - swap [ index ] curry map ; - -: reshape-tuple ( oldtuple permutation -- newtuple ) - >r tuple>array 2 cut r> - [ [ swap ?nth ] [ drop f ] if* ] with map - append >tuple ; - -: reshape-tuples ( class newslots -- ) - >r dup "slot-names" word-prop r> permutation - [ - >r [ swap class eq? ] curry instances dup r> - [ reshape-tuple ] curry map - become - ] 2curry after-compilation ; - -: old-slots ( class newslots -- seq ) - swap "slots" word-prop 1 tail-slice - [ slot-spec-name swap member? not ] with subset ; - -: forget-slots ( class newslots -- ) - dupd old-slots [ - 2dup - slot-spec-reader 2array forget - slot-spec-writer 2array forget - ] with each ; - -: check-shape ( class newslots -- ) - over tuple-class? [ - over "slot-names" word-prop over = [ - 2dup forget-slots - 2dup reshape-tuples - over changed-word - over redefined - ] unless - ] when 2drop ; - M: tuple-class tuple-layout "layout" word-prop ; : define-tuple-predicate ( class -- ) @@ -114,15 +77,59 @@ M: tuple-class tuple-layout "layout" word-prop ; dup "slot-names" word-prop length 1+ { } 0 "layout" set-word-prop ; -PRIVATE> +: removed-slots ( class newslots -- seq ) + swap "slot-names" word-prop seq-diff ; -: define-tuple-class ( class slots -- ) - 2dup check-shape - over f tuple tuple-class define-class +: forget-slots ( class newslots -- ) + dupd removed-slots [ + 2dup + reader-word forget-method + writer-word forget-method + ] with each ; + +: permutation ( seq1 seq2 -- permutation ) + swap [ index ] curry map ; + +: reshape-tuple ( oldtuple permutation -- newtuple ) + >r tuple>array 2 cut r> + [ [ swap ?nth ] [ drop f ] if* ] with map + append >tuple ; + +: reshape-tuples ( class newslots -- ) + >r dup "slot-names" word-prop r> permutation + [ + >r [ swap class eq? ] curry instances dup r> + [ reshape-tuple ] curry map + become + ] 2curry after-compilation ; + +: tuple-class-unchanged 2drop ; + +: prepare-tuple-class ( class slots -- ) dupd define-tuple-slots dup define-tuple-layout define-tuple-predicate ; +: redefine-tuple-class ( class slots -- ) + 2dup forget-slots + 2dup reshape-tuples + over changed-word + over redefined + prepare-tuple-class ; + +: define-new-tuple-class ( class slots -- ) + over f tuple tuple-class define-class + prepare-tuple-class ; + +PRIVATE> + +: define-tuple-class ( class slots -- ) + { + { [ over tuple-class? not ] [ define-new-tuple-class ] } + { [ over "slot-names" word-prop over = ] [ tuple-class-unchanged ] } + { [ t ] [ redefine-tuple-class ] } + } cond ; + M: tuple clone (clone) dup delegate clone over set-delegate ;