Merge branch 'master' of git://factorcode.org/git/factor

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

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,6 +103,7 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
 
 : (class<=) ( first second -- -1/0/1 )
     2dup eq? [ 2drop t ] [
+        2dup superclass<= [ 2drop t ] [
             [ normalize-class ] bi@ {
                 { [ dup empty-intersection? ] [ 2drop t ] }
                 { [ over empty-union? ] [ 2drop t ] }
@@ -113,9 +114,9 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
                 { [ 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
+        ] if
     ] if ;
 
 M: anonymous-union (classes-intersect?)

core/classes/classes-tests.factor

@@ -1,9 +1,9 @@
 USING: alien arrays definitions generic assocs hashtables io
-kernel math namespaces parser prettyprint sequences strings
+io.streams.string kernel math namespaces parser prettyprint
-tools.test vectors words quotations classes
+sequences strings tools.test vectors words quotations classes
 classes.private classes.union classes.mixin classes.predicate
-classes.algebra vectors definitions source-files
+classes.algebra vectors definitions source-files compiler.units
-compiler.units kernel.private sorting vocabs ;
+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 ;"> <string-reader>
+    "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 ;"> <string-reader>
+    "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 ;"> <string-reader>
+    "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 ;"> <string-reader>
+    "class-intersect-no-method-b" parse-stream drop
+] unit-test

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 ;

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 * ;

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 ;
+        2dup [ class? ] both?
+        [ classes-intersect? ] [ 2drop f ] if nip
+    ] curry assoc-filter ;
 
 : compiled-generic-usages ( assoc -- assocs )
     [ (compiled-generic-usages) ] { } assoc>map ;