core/classes/predicate/predicate.factor

   1 ! Copyright (C) 2004, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: classes classes.algebra classes.algebra.private
   4 classes.private kernel make words ;
   5 IN: classes.predicate
   6
   7 PREDICATE: predicate-class < class
   8     "metaclass" word-prop predicate-class eq? ;
   9
  10 <PRIVATE
  11
  12 GENERIC: predicate-quot ( class -- quot )
  13
  14 M: predicate-class predicate-quot
  15     [
  16         \ dup ,
  17         [ superclass-of predicate-def % ]
  18         [ "predicate-definition" word-prop , ] bi
  19         [ drop f ] , \ if ,
  20     ] [ ] make ;
  21
  22 PRIVATE>
  23
  24 : define-predicate-class ( class superclass definition -- )
  25     [ drop f f predicate-class define-class ]
  26     [ nip "predicate-definition" set-word-prop ]
  27     [
  28         2drop
  29         [ dup predicate-quot define-predicate ]
  30         [ update-classes ]
  31         bi
  32     ] 3tri ;
  33
  34 M: predicate-class reset-class
  35     [ call-next-method ] [ "predicate-definition" remove-word-prop ] bi ;
  36
  37 M: predicate-class rank-class drop 2 ;
  38
  39 M: predicate-class instance?
  40     2dup superclass-of instance? [
  41         "predicate-definition" word-prop call( object -- ? )
  42     ] [ 2drop f ] if ;
  43
  44 M: predicate-class (flatten-class)
  45     superclass-of (flatten-class) ;
  46
  47 M: predicate-class (classes-intersect?)
  48     superclass-of classes-intersect? ;