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

db4
slava 2008-07-05 03:07:48 -05:00
commit 3dcc04675b
16 changed files with 113 additions and 93 deletions

View File

@ -1,10 +1,22 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes classes.builtin combinators accessors
sequences arrays vectors assocs namespaces words sorting layouts
math hashtables kernel.private sets math.order ;
USING: kernel classes combinators accessors sequences arrays
vectors assocs namespaces words sorting layouts math hashtables
kernel.private sets math.order ;
IN: classes.algebra
TUPLE: anonymous-union members ;
C: <anonymous-union> anonymous-union
TUPLE: anonymous-intersection participants ;
C: <anonymous-intersection> anonymous-intersection
TUPLE: anonymous-complement class ;
C: <anonymous-complement> anonymous-complement
: 2cache ( key1 key2 assoc quot -- value )
>r >r 2array r> [ first2 ] r> compose cache ; inline
@ -18,10 +30,19 @@ DEFER: (class-not)
: class-not ( class -- complement )
class-not-cache get [ (class-not) ] cache ;
DEFER: (classes-intersect?) ( first second -- ? )
GENERIC: (classes-intersect?) ( first second -- ? )
: normalize-class ( class -- class' )
{
{ [ dup members ] [ members <anonymous-union> ] }
{ [ dup participants ] [ participants <anonymous-intersection> ] }
[ ]
} cond ;
: classes-intersect? ( first second -- ? )
classes-intersect-cache get [ (classes-intersect?) ] 2cache ;
classes-intersect-cache get [
normalize-class (classes-intersect?)
] 2cache ;
DEFER: (class-and)
@ -33,18 +54,6 @@ DEFER: (class-or)
: class-or ( first second -- class )
class-or-cache get [ (class-or) ] 2cache ;
TUPLE: anonymous-union members ;
C: <anonymous-union> anonymous-union
TUPLE: anonymous-intersection participants ;
C: <anonymous-intersection> anonymous-intersection
TUPLE: anonymous-complement class ;
C: <anonymous-complement> anonymous-complement
: superclass<= ( first second -- ? )
>r superclass r> class<= ;
@ -63,13 +72,6 @@ C: <anonymous-complement> anonymous-complement
: anonymous-complement<= ( first second -- ? )
[ class>> ] bi@ swap class<= ;
: normalize-class ( class -- class' )
{
{ [ dup members ] [ members <anonymous-union> ] }
{ [ dup participants ] [ participants <anonymous-intersection> ] }
[ ]
} cond ;
: normalize-complement ( class -- class' )
class>> normalize-class {
{ [ dup anonymous-union? ] [
@ -116,40 +118,15 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
} cond
] if ;
: anonymous-union-intersect? ( first second -- ? )
M: anonymous-union (classes-intersect?)
members>> [ classes-intersect? ] with contains? ;
: anonymous-intersection-intersect? ( first second -- ? )
M: anonymous-intersection (classes-intersect?)
participants>> [ classes-intersect? ] with all? ;
: anonymous-complement-intersect? ( first second -- ? )
M: anonymous-complement (classes-intersect?)
class>> class<= not ;
: tuple-class-intersect? ( first second -- ? )
{
{ [ over tuple eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] }
{ [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }
[ swap classes-intersect? ]
} cond ;
: builtin-class-intersect? ( first second -- ? )
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] }
[ swap classes-intersect? ]
} cond ;
: (classes-intersect?) ( first second -- ? )
normalize-class {
{ [ dup anonymous-union? ] [ anonymous-union-intersect? ] }
{ [ dup anonymous-intersection? ] [ anonymous-intersection-intersect? ] }
{ [ dup anonymous-complement? ] [ anonymous-complement-intersect? ] }
{ [ dup tuple-class? ] [ tuple-class-intersect? ] }
{ [ dup builtin-class? ] [ builtin-class-intersect? ] }
{ [ dup superclass ] [ superclass classes-intersect? ] }
} cond ;
: anonymous-union-and ( first second -- class )
members>> [ class-and ] with map <anonymous-union> ;
@ -225,26 +202,13 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
tuck [ class<= ] with all? [ peek ] [ drop f ] if
] if ;
DEFER: (flatten-class)
DEFER: flatten-builtin-class
GENERIC: (flatten-class) ( class -- )
: flatten-intersection-class ( class -- )
participants [ flatten-builtin-class ] map
dup empty? [
drop builtins get [ (flatten-class) ] each
] [
unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
] if ;
M: anonymous-union (flatten-class)
members>> [ (flatten-class) ] each ;
: (flatten-class) ( class -- )
{
{ [ dup tuple-class? ] [ dup set ] }
{ [ dup builtin-class? ] [ dup set ] }
{ [ dup members ] [ members [ (flatten-class) ] each ] }
{ [ dup participants ] [ flatten-intersection-class ] }
{ [ dup superclass ] [ superclass (flatten-class) ] }
[ drop ]
} cond ;
M: word (flatten-class)
normalize-class (flatten-class) ;
: flatten-class ( class -- assoc )
[ (flatten-class) ] H{ } make-assoc ;
@ -258,7 +222,7 @@ DEFER: flatten-builtin-class
flatten-builtin-class keys
[ "type" word-prop ] map natural-sort ;
: class-tags ( class -- tag/f )
: class-tags ( class -- seq )
class-types [
dup num-tags get >=
[ drop \ hi-tag tag-number ] when

View File

@ -1,7 +1,8 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes words kernel kernel.private namespaces
sequences math math.private ;
USING: accessors classes classes.algebra words kernel
kernel.private namespaces sequences math math.private
combinators assocs ;
IN: classes.builtin
SYMBOL: builtins
@ -31,3 +32,24 @@ M: builtin-class rank-class drop 0 ;
M: builtin-class instance?
class>type builtin-instance? ;
M: builtin-class (flatten-class) dup set ;
M: builtin-class (classes-intersect?)
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] }
[ swap classes-intersect? ]
} cond ;
M: anonymous-intersection (flatten-class)
participants>>
participants [ flatten-builtin-class ] map
dup empty? [
drop builtins get sift [ (flatten-class) ] each
] [
unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
] if ;
M: anonymous-complement (flatten-class)
drop builtins get sift [ (flatten-class) ] each ;

View File

@ -65,10 +65,6 @@ HELP: classes
{ $values { "seq" "a sequence of class words" } }
{ $description "Finds all class words in the dictionary." } ;
HELP: tuple-class
{ $class-description "The class of tuple class words." }
{ $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
HELP: update-map
{ $var-description "Assoc mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;

View File

@ -32,9 +32,6 @@ SYMBOL: implementors-map
PREDICATE: class < word
"class" word-prop ;
PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ;
: classes ( -- seq ) implementors-map get keys ;
: predicate-word ( word -- predicate )

View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes
namespaces arrays math quotations ;
classes.algebra classes.builtin namespaces arrays math quotations ;
IN: classes.intersection
PREDICATE: intersection-class < class

View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes kernel namespaces words sequences quotations
arrays kernel.private assocs combinators ;
USING: classes classes.algebra kernel namespaces words sequences
quotations arrays kernel.private assocs combinators ;
IN: classes.predicate
PREDICATE: predicate-class < class
@ -51,3 +51,9 @@ M: predicate-class rank-class drop 1 ;
M: predicate-class instance?
2dup superclass instance?
[ predicate-instance? ] [ 2drop f ] if ;
M: predicate-class (flatten-class)
superclass (flatten-class) ;
M: predicate-class (classes-intersect?)
superclass classes-intersect? ;

View File

@ -332,6 +332,10 @@ $nl
ABOUT: "tuples"
HELP: tuple-class
{ $class-description "The class of tuple class words." }
{ $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
HELP: tuple=
{ $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } }
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }

View File

@ -3,10 +3,13 @@
USING: arrays definitions hashtables kernel kernel.private math
namespaces sequences sequences.private strings vectors words
quotations memory combinators generic classes classes.algebra
classes.private slots.deprecated slots.private slots
compiler.units math.private accessors assocs effects ;
classes.builtin classes.private slots.deprecated slots.private
slots compiler.units math.private accessors assocs effects ;
IN: classes.tuple
PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ;
M: tuple class 1 slot 2 slot { word } declare ;
ERROR: not-a-tuple object ;
@ -290,6 +293,16 @@ M: tuple-class rank-class drop 0 ;
M: tuple-class instance?
dup tuple-layout echelon>> tuple-instance? ;
M: tuple-class (flatten-class) dup set ;
M: tuple-class (classes-intersect?)
{
{ [ over tuple eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] }
{ [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }
[ swap classes-intersect? ]
} cond ;
M: tuple clone
(clone) dup delegate clone over set-delegate ;

View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes
namespaces arrays math quotations ;
classes.algebra namespaces arrays math quotations ;
IN: classes.union
PREDICATE: union-class < class

View File

@ -563,7 +563,7 @@ M: loc lazy-store
] if ;
: class-tag ( class -- tag/f )
class-tags dup length 1 = [ first ] [ drop f ] if ;
dup [ class-tags dup length 1 = [ first ] [ drop f ] if ] when ;
: class-matches? ( actual expected -- ? )
{

View File

@ -309,3 +309,11 @@ M: xref-tuple-2 xref-test (xref-test) ;
\ xref-test
\ xref-tuple-2 \ xref-test method [ usage unique ] closure key?
] unit-test
[ t ] [
{ } \ nth effective-method nip \ sequence \ nth method eq?
] unit-test
[ t ] [
\ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and
] unit-test

View File

@ -105,7 +105,9 @@ ERROR: no-next-method class generic ;
] [ ] make ;
: single-effective-method ( obj word -- method )
[ order [ instance? ] with find-last nip ] keep method ;
[ [ order [ instance? ] with find-last nip ] keep method ]
[ "default-method" word-prop ]
bi or ;
TUPLE: standard-combination # ;

View File

@ -2,7 +2,7 @@ USING: help.markup help.syntax generic kernel.private parser
words kernel quotations namespaces sequences words arrays
effects generic.standard classes.builtin
slots.private classes strings math assocs byte-arrays alien
math ;
math classes.tuple ;
IN: slots
ARTICLE: "accessors" "Slot accessors"

View File

@ -1,8 +1,8 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: accessors parser generic kernel classes words slots assocs
sequences arrays vectors definitions prettyprint
math hashtables sets macros namespaces ;
USING: accessors parser generic kernel classes classes.tuple
words slots assocs sequences arrays vectors definitions
prettyprint math hashtables sets macros namespaces ;
IN: delegate
: protocol-words ( protocol -- words )

View File

@ -1,6 +1,7 @@
USING: tools.walker io io.streams.string kernel math
math.private namespaces prettyprint sequences tools.test
continuations math.parser threads arrays tools.walker.debug ;
continuations math.parser threads arrays tools.walker.debug
generic.standard ;
IN: tools.walker.tests
[ { } ] [
@ -97,6 +98,9 @@ IN: tools.walker.tests
[ { 6 } ]
[ [ [ 3 throw ] [ 2 * ] recover ] test-walker ] unit-test
[ { T{ no-method f + nth } } ]
[ [ [ 0 \ + nth ] [ ] recover ] test-walker ] unit-test
[ { } ] [
[ "a" "b" set "c" "d" set [ ] test-walker ] with-scope
] unit-test

View File

@ -83,6 +83,9 @@ M: object add-breakpoint ;
: (step-into-continuation) ( -- )
continuation callstack >>call break ;
: (step-into-call-next-method) ( class generic -- )
next-method-quot (step-into-quot) ;
! Messages sent to walker thread
SYMBOL: step
SYMBOL: step-out
@ -132,6 +135,7 @@ SYMBOL: +stopped+
{ if [ (step-into-if) ] }
{ dispatch [ (step-into-dispatch) ] }
{ continuation [ (step-into-continuation) ] }
{ (call-next-method) [ (step-into-call-next-method) ] }
} [ "step-into" set-word-prop ] assoc-each
{