Merge branch 'master' of git://factorcode.org/git/factor
commit
b86314ec39
|
@ -122,17 +122,6 @@ GENERIC: void-generic ( obj -- * )
|
|||
|
||||
[ t ] [ \ <tuple>-regression optimized? ] unit-test
|
||||
|
||||
GENERIC: foozul ( a -- b )
|
||||
M: reversed foozul ;
|
||||
M: integer foozul ;
|
||||
M: slice foozul ;
|
||||
|
||||
[ t ] [
|
||||
reversed \ foozul specific-method
|
||||
reversed \ foozul method
|
||||
eq?
|
||||
] unit-test
|
||||
|
||||
! regression
|
||||
: constant-fold-2 ( -- value ) f ; foldable
|
||||
: constant-fold-3 ( -- value ) 4 ; foldable
|
||||
|
|
|
@ -52,7 +52,7 @@ M: callable splicing-nodes splicing-body ;
|
|||
2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [
|
||||
[ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
|
||||
[ swap nth value-info class>> dup ] dip
|
||||
specific-method
|
||||
method-for-class
|
||||
] if
|
||||
] if ;
|
||||
|
||||
|
|
|
@ -14,7 +14,7 @@ IN: compiler.tree.propagation.transforms
|
|||
! If first input has a known type and second input is an
|
||||
! object, we convert this to [ swap equal? ].
|
||||
in-d>> first2 value-info class>> object class= [
|
||||
value-info class>> \ equal? specific-method
|
||||
value-info class>> \ equal? method-for-class
|
||||
[ swap equal? ] f ?
|
||||
] [ drop f ] if
|
||||
] "custom-inlining" set-word-prop
|
||||
|
|
|
@ -147,7 +147,7 @@ SYMBOL: fast-math-ops
|
|||
: math-both-known? ( word left right -- ? )
|
||||
3dup math-op
|
||||
[ 2drop 2drop t ]
|
||||
[ drop math-class-max swap specific-method >boolean ] if ;
|
||||
[ drop math-class-max swap method-for-class >boolean ] if ;
|
||||
|
||||
: (derived-ops) ( word assoc -- words )
|
||||
swap '[ swap first _ eq? nip ] assoc-filter ;
|
||||
|
|
|
@ -6,7 +6,7 @@ IN: windows.fonts
|
|||
MEMO: windows-fonts ( -- fonts )
|
||||
windows-major 6 >=
|
||||
H{
|
||||
{ "sans-serif" "Calibri" }
|
||||
{ "sans-serif" "Segoe UI" }
|
||||
{ "serif" "Cambria" }
|
||||
{ "monospace" "Consolas" }
|
||||
}
|
||||
|
|
|
@ -10,7 +10,6 @@ ARTICLE: "class-operations" "Class operations"
|
|||
{ $subsection class-and }
|
||||
{ $subsection class-or }
|
||||
{ $subsection classes-intersect? }
|
||||
{ $subsection min-class }
|
||||
"Low-level implementation detail:"
|
||||
{ $subsection flatten-class }
|
||||
{ $subsection flatten-builtin-class }
|
||||
|
@ -37,6 +36,7 @@ $nl
|
|||
"Operations:"
|
||||
{ $subsection class< }
|
||||
{ $subsection sort-classes }
|
||||
{ $subsection smallest-class }
|
||||
"Metaclass order:"
|
||||
{ $subsection rank-class } ;
|
||||
|
||||
|
@ -73,6 +73,6 @@ HELP: classes-intersect?
|
|||
{ $values { "first" class } { "second" class } { "?" "a boolean" } }
|
||||
{ $description "Tests if two classes have a non-empty intersection. If the intersection is empty, no object can be an instance of both classes at once." } ;
|
||||
|
||||
HELP: min-class
|
||||
{ $values { "class" class } { "seq" "a sequence of class words" } { "class/f" "a class word or " { $link f } } }
|
||||
{ $description "If all classes in " { $snippet "seq" } " that intersect " { $snippet "class" } " are subtypes of " { $snippet "class" } ", outputs the last such element of " { $snippet "seq" } ". If any conditions fail to hold, outputs " { $link f } "." } ;
|
||||
HELP: smallest-class
|
||||
{ $values { "classes" "a sequence of class words" } { "class/f" { $maybe class } } }
|
||||
{ $description "Outputs a minimum class from the given sequence." } ;
|
||||
|
|
|
@ -4,7 +4,7 @@ tools.test words quotations classes classes.algebra
|
|||
classes.private classes.union classes.mixin classes.predicate
|
||||
vectors source-files compiler.units growable random
|
||||
stack-checker effects kernel.private sbufs math.order
|
||||
classes.tuple accessors ;
|
||||
classes.tuple accessors generic.private ;
|
||||
IN: classes.algebra.tests
|
||||
|
||||
: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;
|
||||
|
@ -150,6 +150,12 @@ UNION: z1 b1 c1 ;
|
|||
] unit-test
|
||||
|
||||
! Test method inlining
|
||||
[ real ] [ { real sequence } smallest-class ] unit-test
|
||||
[ real ] [ { sequence real } smallest-class ] unit-test
|
||||
|
||||
: min-class ( class classes -- class/f )
|
||||
interesting-classes smallest-class ;
|
||||
|
||||
[ f ] [ fixnum { } min-class ] unit-test
|
||||
|
||||
[ string ] [
|
||||
|
|
|
@ -214,10 +214,10 @@ ERROR: topological-sort-failed ;
|
|||
[ dup largest-class [ over delete-nth ] dip ]
|
||||
produce nip ;
|
||||
|
||||
: min-class ( class seq -- class/f )
|
||||
over [ classes-intersect? ] curry filter
|
||||
[ drop f ] [
|
||||
[ nip ] [ [ class<= ] with all? ] 2bi [ last ] [ drop f ] if
|
||||
: smallest-class ( classes -- class/f )
|
||||
[ f ] [
|
||||
natural-sort <reversed>
|
||||
[ ] [ [ class<= ] most ] map-reduce
|
||||
] if-empty ;
|
||||
|
||||
GENERIC: (flatten-class) ( class -- )
|
||||
|
|
|
@ -179,3 +179,20 @@ GENERIC: move-method-generic ( a -- b )
|
|||
[ ] [ "IN: generic.tests.a" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
|
||||
|
||||
[ { string } ] [ \ move-method-generic order ] unit-test
|
||||
|
||||
GENERIC: foozul ( a -- b )
|
||||
M: reversed foozul ;
|
||||
M: integer foozul ;
|
||||
M: slice foozul ;
|
||||
|
||||
[ t ] [
|
||||
reversed \ foozul method-for-class
|
||||
reversed \ foozul method
|
||||
eq?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
fixnum \ <=> method-for-class
|
||||
real \ <=> method
|
||||
eq?
|
||||
] unit-test
|
|
@ -24,20 +24,42 @@ M: generic definition drop f ;
|
|||
: method ( class generic -- method/f )
|
||||
"methods" word-prop at ;
|
||||
|
||||
: order ( generic -- seq )
|
||||
"methods" word-prop keys sort-classes ;
|
||||
<PRIVATE
|
||||
|
||||
: specific-method ( class generic -- method/f )
|
||||
[ nip ] [ order min-class ] 2bi
|
||||
dup [ swap method ] [ 2drop f ] if ;
|
||||
: interesting-class? ( class1 class2 -- ? )
|
||||
{
|
||||
! Case 1: no intersection. Discard and keep going
|
||||
{ [ 2dup classes-intersect? not ] [ 2drop t ] }
|
||||
! Case 2: class1 contained in class2. Add to
|
||||
! interesting set and keep going.
|
||||
{ [ 2dup class<= ] [ nip , t ] }
|
||||
! Case 3: class1 and class2 are incomparable. Give up
|
||||
[ 2drop f ]
|
||||
} cond ;
|
||||
|
||||
: interesting-classes ( class classes -- interesting/f )
|
||||
[ [ interesting-class? ] with all? ] { } make and ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: method-classes ( generic -- classes )
|
||||
"methods" word-prop keys ;
|
||||
|
||||
: order ( generic -- seq )
|
||||
method-classes sort-classes ;
|
||||
|
||||
: nearest-class ( class generic -- class/f )
|
||||
method-classes interesting-classes smallest-class ;
|
||||
|
||||
: method-for-class ( class generic -- method/f )
|
||||
[ nip ] [ nearest-class ] 2bi dup [ swap method ] [ 2drop f ] if ;
|
||||
|
||||
GENERIC: effective-method ( generic -- method )
|
||||
|
||||
\ effective-method t "no-compile" set-word-prop
|
||||
|
||||
: next-method-class ( class generic -- class/f )
|
||||
order [ class<= ] with filter reverse dup length 1 =
|
||||
[ drop f ] [ second ] if ;
|
||||
method-classes [ class< ] with filter smallest-class ;
|
||||
|
||||
: next-method ( class generic -- method/f )
|
||||
[ next-method-class ] keep method ;
|
||||
|
|
|
@ -23,4 +23,4 @@ M: hook-combination mega-cache-quot
|
|||
M: hook-generic definer drop \ HOOK: f ;
|
||||
|
||||
M: hook-generic effective-method
|
||||
[ "combination" word-prop var>> get ] keep (effective-method) ;
|
||||
[ "combination" word-prop var>> get ] keep method-for-object ;
|
|
@ -50,7 +50,7 @@ ERROR: no-math-method left right generic ;
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: applicable-method ( generic class -- quot )
|
||||
: (math-method) ( generic class -- quot )
|
||||
over method
|
||||
[ 1quotation ]
|
||||
[ default-math-method ] ?if ;
|
||||
|
@ -58,13 +58,13 @@ ERROR: no-math-method left right generic ;
|
|||
PRIVATE>
|
||||
|
||||
: object-method ( generic -- quot )
|
||||
object bootstrap-word applicable-method ;
|
||||
object bootstrap-word (math-method) ;
|
||||
|
||||
: math-method ( word class1 class2 -- quot )
|
||||
2dup and [
|
||||
[ 2array [ declare ] curry nip ]
|
||||
[ math-upgrade nip ]
|
||||
[ math-class-max over order min-class applicable-method ]
|
||||
[ math-class-max over nearest-class (math-method) ]
|
||||
3tri 3append
|
||||
] [
|
||||
2drop object-method
|
||||
|
|
|
@ -42,8 +42,8 @@ M: single-combination next-method-quot* ( class generic combination -- quot )
|
|||
] [ 3drop f ] if
|
||||
] with-combination ;
|
||||
|
||||
: (effective-method) ( obj word -- method )
|
||||
[ [ order [ instance? ] with find-last nip ] keep method ]
|
||||
: method-for-object ( obj word -- method )
|
||||
[ [ method-classes [ instance? ] with filter smallest-class ] keep method ]
|
||||
[ "default-method" word-prop ]
|
||||
bi or ;
|
||||
|
||||
|
|
|
@ -40,7 +40,7 @@ M: standard-combination dispatch# #>> ;
|
|||
|
||||
M: standard-generic effective-method
|
||||
[ datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep
|
||||
(effective-method) ;
|
||||
method-for-object ;
|
||||
|
||||
: inline-cache-quot ( word methods miss-word -- quot )
|
||||
[ [ literalize , ] [ , ] [ combination get #>> , { } , , ] tri* ] [ ] make ;
|
||||
|
|
Loading…
Reference in New Issue