More efficient singleton predicates

db4
Slava Pestov 2009-07-17 17:41:33 -05:00
parent b76165facf
commit 50a86a8d93
2 changed files with 12 additions and 4 deletions

View File

@ -7,7 +7,9 @@ IN: classes.predicate
PREDICATE: predicate-class < class PREDICATE: predicate-class < class
"metaclass" word-prop predicate-class eq? ; "metaclass" word-prop predicate-class eq? ;
: predicate-quot ( class -- quot ) GENERIC: predicate-quot ( class -- quot )
M: predicate-class predicate-quot
[ [
\ dup , \ dup ,
[ superclass "predicate" word-prop % ] [ superclass "predicate" word-prop % ]

View File

@ -1,17 +1,23 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008, 2009 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: classes classes.algebra classes.predicate kernel USING: classes classes.algebra classes.predicate kernel
sequences words ; sequences words ;
IN: classes.singleton IN: classes.singleton
: singleton-predicate-quot ( class -- quot ) [ eq? ] curry ;
PREDICATE: singleton-class < predicate-class PREDICATE: singleton-class < predicate-class
[ "predicate-definition" word-prop ] [ "predicate-definition" word-prop ]
[ [ eq? ] curry ] bi sequence= ; [ singleton-predicate-quot ]
bi sequence= ;
: define-singleton-class ( word -- ) : define-singleton-class ( word -- )
\ word over [ eq? ] curry define-predicate-class ; \ word over singleton-predicate-quot define-predicate-class ;
M: singleton-class instance? eq? ; M: singleton-class instance? eq? ;
M: singleton-class (classes-intersect?) M: singleton-class (classes-intersect?)
over singleton-class? [ eq? ] [ call-next-method ] if ; over singleton-class? [ eq? ] [ call-next-method ] if ;
M: singleton-class predicate-quot
singleton-predicate-quot ;