diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 99bcfae92a..47c31111a9 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -3,7 +3,7 @@ USING: bootstrap.image.private kernel kernel.private namespaces system cpu.ppc.assembler compiler.codegen.fixup compiler.units compiler.constants math math.private layouts words words.private -vocabs slots.private ; +vocabs slots.private locals.backend ; IN: bootstrap.ppc 4 \ cell set @@ -305,4 +305,45 @@ big-endian on 3 ds-reg 0 STW ] f f f \ fixnum-bitnot define-sub-primitive +[ + 3 ds-reg 0 LWZ + 3 3 tag-bits get SRAWI + ds-reg ds-reg 4 SUBI + 4 ds-reg 0 LWZ + 5 4 3 SLW + 6 3 NEG + 7 4 6 SRAW + 7 7 0 0 31 tag-bits get - RLWINM + 0 3 0 CMPI + 2 BGT + 5 7 MR + 5 ds-reg 0 STW +] f f f \ fixnum-shift-fast define-sub-primitive + +[ + 3 ds-reg 0 LWZ + ds-reg ds-reg 4 SUBI + 4 ds-reg 0 LWZ + 5 4 3 DIVW + 6 5 3 MULLW + 7 6 4 SUBF + 7 ds-reg 0 STW +] f f f \ fixnum-mod define-sub-primitive + +[ + 3 ds-reg 0 LWZ + 3 3 1 SRAWI + 4 4 LI + 4 3 4 SUBF + rs-reg 3 4 LWZX + 3 ds-reg 0 STW +] f f f \ get-local define-sub-primitive + +[ + 3 ds-reg 0 LWZ + ds-reg ds-reg 4 SUBI + 3 3 1 SRAWI + rs-reg 3 rs-reg SUBF +] f f f \ drop-locals define-sub-primitive + [ "bootstrap.ppc" forget-vocab ] with-compilation-unit diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index b32bac3a18..51dad033a9 100644 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -55,7 +55,7 @@ DEFER: (class-or) class-or-cache get [ (class-or) ] 2cache ; : superclass<= ( first second -- ? ) - >r superclass r> class<= ; + swap superclass dup [ swap class<= ] [ 2drop f ] if ; : left-anonymous-union<= ( first second -- ? ) >r members>> r> [ class<= ] curry all? ; @@ -103,19 +103,20 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ; : (class<=) ( first second -- -1/0/1 ) 2dup eq? [ 2drop t ] [ - [ normalize-class ] bi@ { - { [ dup empty-intersection? ] [ 2drop t ] } - { [ over empty-union? ] [ 2drop t ] } - { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] } - { [ over anonymous-union? ] [ left-anonymous-union<= ] } - { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] } - { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] } - { [ dup anonymous-union? ] [ right-anonymous-union<= ] } - { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] } - { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] } - { [ over superclass ] [ superclass<= ] } - [ 2drop f ] - } cond + 2dup superclass<= [ 2drop t ] [ + [ normalize-class ] bi@ { + { [ dup empty-intersection? ] [ 2drop t ] } + { [ over empty-union? ] [ 2drop t ] } + { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] } + { [ over anonymous-union? ] [ left-anonymous-union<= ] } + { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] } + { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] } + { [ dup anonymous-union? ] [ right-anonymous-union<= ] } + { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] } + { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] } + [ 2drop f ] + } cond + ] if ] if ; M: anonymous-union (classes-intersect?) diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 1dee6a095c..c7900da316 100644 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -1,9 +1,9 @@ USING: alien arrays definitions generic assocs hashtables io -kernel math namespaces parser prettyprint sequences strings -tools.test vectors words quotations classes +io.streams.string kernel math namespaces parser prettyprint +sequences strings tools.test vectors words quotations classes classes.private classes.union classes.mixin classes.predicate -classes.algebra vectors definitions source-files -compiler.units kernel.private sorting vocabs ; +classes.algebra vectors definitions source-files compiler.units +kernel.private sorting vocabs memory eval accessors ; IN: classes.tests [ t ] [ 3 object instance? ] unit-test @@ -27,3 +27,55 @@ M: method-forget-class method-forget-test ; implementors-map get keys [ natural-sort ] bi@ = ] unit-test + +! Minor leak +[ ] [ "IN: classes.tests TUPLE: forget-me ;" eval ] unit-test +[ ] [ f \ word set-global ] unit-test +[ ] [ "IN: classes.tests USE: kernel USE: classes.algebra forget-me tuple class<= drop" eval ] unit-test +[ ] [ "IN: classes.tests FORGET: forget-me" eval ] unit-test +[ 0 ] [ + [ word? ] instances + [ [ name>> "forget-me" = ] [ vocabulary>> "classes.tests" = ] bi and ] count +] unit-test + +! Long-standing problem +USE: multiline + +! So the user has some code... +[ ] [ + <" IN: classes.test.a + GENERIC: g ( a -- b ) + TUPLE: x ; + M: x g ; + TUPLE: z < x ;"> + "class-intersect-no-method-a" parse-stream drop +] unit-test + +! Note that q inlines M: x g ; +[ ] [ + <" IN: classes.test.b + USE: classes.test.a + USE: kernel + : q ( -- b ) z new g ;"> + "class-intersect-no-method-b" parse-stream drop +] unit-test + +! Now, the user removes the z class and adds a method, +[ ] [ + <" IN: classes.test.a + GENERIC: g ( a -- b ) + TUPLE: x ; + M: x g ; + TUPLE: j ; + M: j g ;"> + "class-intersect-no-method-a" parse-stream drop +] unit-test + +! And changes the definition of q +[ ] [ + <" IN: classes.test.b + USE: classes.test.a + USE: kernel + : q ( -- b ) j new g ;"> + "class-intersect-no-method-b" parse-stream drop +] unit-test diff --git a/core/classes/classes.factor b/core/classes/classes.factor index dcb69c9149..70fb869c5c 100644 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -176,7 +176,8 @@ GENERIC: class-forgotten ( use class -- ) [ implementors-map- ] [ update-map- ] [ reset-class ] - } cleave ; + } cleave + reset-caches ; M: class class-forgotten nip forget-class ; diff --git a/core/classes/predicate/predicate-tests.factor b/core/classes/predicate/predicate-tests.factor index 9f3b3e2141..3de073f774 100644 --- a/core/classes/predicate/predicate-tests.factor +++ b/core/classes/predicate/predicate-tests.factor @@ -1,9 +1,16 @@ -USING: math tools.test ; +USING: math tools.test classes.algebra ; IN: classes.predicate PREDICATE: negative < integer 0 < ; PREDICATE: positive < integer 0 > ; +[ t ] [ negative integer class< ] unit-test +[ t ] [ positive integer class< ] unit-test +[ f ] [ integer negative class< ] unit-test +[ f ] [ integer positive class< ] unit-test +[ f ] [ negative negative class< ] unit-test +[ f ] [ positive negative class< ] unit-test + GENERIC: abs ( n -- n ) M: integer abs ; M: negative abs -1 * ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 973d9b5c00..1b6b934dae 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -109,10 +109,11 @@ SYMBOL: remake-generics-hook compiled-generic-crossref get at ; : (compiled-generic-usages) ( generic class -- assoc ) - dup class? [ - [ compiled-generic-usage ] dip - [ classes-intersect? nip ] curry assoc-filter - ] [ 2drop f ] if ; + [ compiled-generic-usage ] dip + [ + 2dup [ class? ] both? + [ classes-intersect? ] [ 2drop f ] if nip + ] curry assoc-filter ; : compiled-generic-usages ( assoc -- assocs ) [ (compiled-generic-usages) ] { } assoc>map ;