Merge branch 'master' of git://factorcode.org/git/factor
John Benediktsson
commit
612017c837
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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?)
|
||||
|
|
|
|||
|
|
@ -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 ;"> <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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 * ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue