diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 735f328a67..a8e9066f56 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -542,3 +542,14 @@ USE: vocabs [ f ] [ "x" accessor-exists? ] unit-test [ f ] [ "y" accessor-exists? ] unit-test [ f ] [ "z" accessor-exists? ] unit-test + +TUPLE: another-forget-accessors-test ; + + +[ [ ] ] [ + "IN: classes.tuple.tests GENERIC: another-forget-accessors-test" + + "another-forget-accessors-test" parse-stream +] unit-test + +[ t ] [ \ another-forget-accessors-test class? ] unit-test diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor index fbca22471c..2f58770b1a 100644 --- a/core/generic/standard/standard-tests.factor +++ b/core/generic/standard/standard-tests.factor @@ -1,7 +1,7 @@ IN: generic.standard.tests USING: tools.test math math.functions math.constants generic.standard strings sequences arrays kernel accessors -words float-arrays byte-arrays bit-arrays parser ; +words float-arrays byte-arrays bit-arrays parser namespaces ; GENERIC: lo-tag-test @@ -137,3 +137,99 @@ M: byte-array small-lo-tag drop "byte-array" ; [ "fixnum" ] [ 3 small-lo-tag ] unit-test [ "float-array" ] [ F{ 1.0 } small-lo-tag ] unit-test + +! Testing next-method +TUPLE: person ; + +TUPLE: intern < person ; + +TUPLE: employee < person ; + +TUPLE: tape-monkey < employee ; + +TUPLE: manager < employee ; + +TUPLE: junior-manager < manager ; + +TUPLE: middle-manager < manager ; + +TUPLE: senior-manager < manager ; + +TUPLE: executive < senior-manager ; + +TUPLE: ceo < executive ; + +GENERIC: salary ( person -- n ) + +M: intern salary + #! Intentional mistake. + call-next-method ; + +M: employee salary drop 24000 ; + +M: manager salary call-next-method 12000 + ; + +M: middle-manager salary call-next-method 5000 + ; + +M: senior-manager salary call-next-method 15000 + ; + +M: executive salary call-next-method 2 * ; + +M: ceo salary + #! Intentional error. + drop 5 call-next-method 3 * ; + +[ salary ] must-infer + +[ 24000 ] [ employee construct-boa salary ] unit-test + +[ 24000 ] [ tape-monkey construct-boa salary ] unit-test + +[ 36000 ] [ junior-manager construct-boa salary ] unit-test + +[ 41000 ] [ middle-manager construct-boa salary ] unit-test + +[ 51000 ] [ senior-manager construct-boa salary ] unit-test + +[ 102000 ] [ executive construct-boa salary ] unit-test + +[ ceo construct-boa salary ] +[ T{ inconsistent-next-method f 5 ceo salary } = ] must-fail-with + +[ intern construct-boa salary ] +[ T{ no-next-method f intern salary } = ] must-fail-with + +! Weird shit +TUPLE: a ; +TUPLE: b ; +TUPLE: c ; + +UNION: x a b ; +UNION: y a c ; + +UNION: z x y ; + +GENERIC: funky* ( obj -- ) + +M: z funky* "z" , drop ; + +M: x funky* "x" , call-next-method ; + +M: y funky* "y" , call-next-method ; + +M: a funky* "a" , call-next-method ; + +M: b funky* "b" , call-next-method ; + +M: c funky* "c" , call-next-method ; + +: funky [ funky* ] { } make ; + +[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test + +[ { "c" "y" "z" } ] [ T{ c } funky ] unit-test + +[ t ] [ + T{ a } funky + { { "a" "x" "z" } { "a" "y" "z" } } member? +] unit-test diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index b54dbe256a..038ab1d230 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -233,6 +233,20 @@ M: fixnum annotate-entry-test-1 drop ; \ >float inlined? ] unit-test +GENERIC: detect-float ( a -- b ) + +M: float detect-float ; + +[ t ] [ + [ { real float } declare + detect-float ] + \ detect-float inlined? +] unit-test + +[ t ] [ + [ { float real } declare + detect-float ] + \ detect-float inlined? +] unit-test + [ t ] [ [ 3 + = ] \ equal? inlined? ] unit-test diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 8269952409..033d2cce7a 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -274,7 +274,7 @@ DEFER: (infer-classes) (merge-intervals) r> set-intervals ; : annotate-merge ( nodes #merge/#entry -- ) - 2dup merge-classes merge-intervals ; + [ merge-classes ] [ merge-intervals ] 2bi ; : merge-children ( node -- ) dup node-successor dup #merge? [ @@ -290,28 +290,31 @@ DEFER: (infer-classes) M: #label infer-classes-before ( #label -- ) #! First, infer types under the hypothesis which hold on #! entry to the recursive label. - dup 1array swap annotate-entry ; + [ 1array ] keep annotate-entry ; M: #label infer-classes-around ( #label -- ) #! Now merge the types at every recursion point with the #! entry types. - dup annotate-node - dup infer-classes-before - dup infer-children - dup collect-recursion over suffix - pick annotate-entry - node-child (infer-classes) ; + { + [ annotate-node ] + [ infer-classes-before ] + [ infer-children ] + [ [ collect-recursion ] [ suffix ] [ annotate-entry ] tri ] + [ node-child (infer-classes) ] + } cleave ; M: object infer-classes-around - dup infer-classes-before - dup annotate-node - dup infer-children - merge-children ; + { + [ infer-classes-before ] + [ annotate-node ] + [ infer-children ] + [ merge-children ] + } cleave ; : (infer-classes) ( node -- ) [ - dup infer-classes-around - node-successor (infer-classes) + [ infer-classes-around ] + [ node-successor (infer-classes) ] bi ] when* ; : infer-classes-with ( node classes literals intervals -- ) diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 81f53b5ace..9d41d6eae1 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -71,8 +71,13 @@ DEFER: (flat-length) ! Partial dispatch of math-generic words : normalize-math-class ( class -- class' ) - { fixnum bignum ratio float complex } - [ class< ] with find nip object or ; + { + fixnum bignum integer + ratio rational + float real + complex number + object + } [ class< ] with find nip ; : math-both-known? ( word left right -- ? ) math-class-max swap specific-method ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 5551ac8af0..902bae29b5 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -477,18 +477,22 @@ SYMBOL: interactive-vocabs nl ] when 2drop ; -: filter-moved ( assoc -- newassoc ) - [ +: filter-moved ( assoc1 assoc2 -- seq ) + diff [ drop where dup [ first ] when file get source-file-path = - ] assoc-subset ; + ] assoc-subset keys ; -: removed-definitions ( -- definitions ) +: removed-definitions ( -- assoc1 assoc2 ) new-definitions old-definitions - [ get first2 union ] bi@ diff ; + [ get first2 union ] bi@ ; + +: removed-classes ( -- assoc1 assoc2 ) + new-definitions old-definitions + [ get second ] bi@ ; : smudged-usage ( -- usages referenced removed ) - removed-definitions filter-moved keys [ + removed-definitions filter-moved [ outside-usages [ empty? [ drop f ] [ @@ -506,9 +510,9 @@ SYMBOL: interactive-vocabs #! If a class word had a compound definition which was #! removed, it must go back to being a symbol. new-definitions get first2 - [ diff values [ [ reset-generic ] [ define-symbol ] bi ] each ] - [ swap diff values [ class? ] subset [ reset-class ] each ] - 2bi ; + filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each + removed-classes + filter-moved [ class? ] subset [ reset-class ] each ; : forget-smudged ( -- ) smudged-usage forget-all